PDL-2.074/0000755000175000017500000000000014200406302012062 5ustar osboxesosboxesPDL-2.074/INSTALL0000644000175000017500000001427414014062163013131 0ustar osboxesosboxesHINT ---- For the latest install and per-platform guidance on how to get and install PDL, see the Install PDL page at: http://pdl.perl.org/?page=install INSTALLATION ------------ To install PDL on your machine, first check that you have a recent enough version of Perl. 5.10.x and above is required. See win32/INSTALL for details on installing PDL on windows platforms. See cygwin/INSTALL for details on installing PDL on cygwin platforms. The file DEPENDENCIES summarizes the dependencies of various PDL modules on libraries/other packages. The location of some of these files needs to be specified in the file perldl.conf. PDL depends on a number of other Perl modules for feature complete operation. These modules are generally available at the CPAN. The easiest way to resolve these dependencies is to use the CPAN module to install PDL. Installation should be as simple as cpan install PDL # if the cpan script is in your path or if you don't have the cpan script try perl -MCPAN -e shell cpan> install PDL NOTE: if this is your first time running the cpan shell, you'll be prompted to configure the running environment. IMPORTANT: Be sure your cpan build_dir location does not have white space in the name. To check or change the setting, start the cpan shell as above, then to check: cpan> o conf build_dir build_dir [/your/build dir/.cpan] Type 'o conf' to view all configuration items And to change to something better: cpan> o conf build_dir '/your/build_dir/.cpan' build_dir [/your/build_dir/.cpan] Please use 'o conf commit' to make the config permanent! perldl.conf ----------- Edit the file perldl.conf in the PDL source directory to specify configuration options for building PDL. The comments in this file specify what the options are and give examples. NOTE: If you are happy with your perldl.conf you can keep the file handy for future reference. Place it in ~/.perldl.conf where it will be picked up automatically or use this command perl Makefile.PL PDLCONF=your_conf_file the next time you configure PDL. (You should check if new config flags were introduced when installing a new version of PDL by consulting its perldl.conf.) After editing the configuration options just say perl Makefile.PL in the directory this file is in. (See 'perldoc ExtUtils::MakeMaker' for info on how to configure the installation location, etc.) and if that seems ok, try: make If there are any strange error messages, please contact the developers with a full bug report; response is often rapid (We would like to have PDL work right out of the box on as many platforms as possible). If the make command completed successfully, try: make test to run the regression tests. If you have issues, please read Known_problems to see if they have been seen before. Again, if there are errors, please contact the developers (via the pdl-devel mailing list, see Basic/Pod/FAQ.pod). If everything works and you wish to install PDL, type make install There is also another make item: make doctest which creates the documentation database for use in the PDL shell (pdl2 or perldl). It will be run automatically on PDL install, but you may wish to run it by hand to have access to PDL on-line docs when running from the build directory before/without install. F77 Configuration ----------------- F77 configuration information is normally picked up from ExtUtils::F77 to build modules like PDL::Slatec that rely on a working fortran compiler. In cases where you don't want to rely on ExtUtils::F77 for one reason or another (e.g., a win32 build or other platform without ExtUtils::F77 support) there is now the config variable F77CONF. It is supposed to point to a perl file that implements a minimal F77Conf class (see debian/f77conf.pl for an example). The use of F77CONF is similar to the PDLCONF variable, e.g. perl Makefile.PL F77CONF=debian/f77conf.pl Note that almost always it is better to use ExtUtils::F77. Only use the F77CONF mechanism if you have a good reason to. Win32 is special. See win32/INSTALL. COMMON PROBLEMS --------------- If you have problems building or installing PDL, we suggest contacting the PDL users and developers via the PDL mailing lists. See http://pdl.perl.org/?page=mailing-lists to get started. Links to searchable archives of the lists are available on the same page. The build process has been significantly cleaned up since PDL-2.4.3. If you are unable to install PDL, even after consulting the list archives or other users and developers on the PDL lists, please do submit a bug report (see the BUGS file for directions). * Test failures in t/gis_proj.t, t/proj_transform.t, or t/proj_transform2.t with error messages that look like this (in the body of the test output, not the summary): ... not found _fwd_trans_inplace[BADCODE](): Projection initialization failed: major axis or radius = 0 or not given ... This indicates that the PROJ4 library on the system is either missing or cannot find the transformation parameter files. They are typically in a directory like /usr/share/proj and contain files with names like: epsg, nad27, nad83, conus,... If you find such a directory, try setting the PROJ_LIB environment variable to that location. If you do not have that directory, you may need to use your platform's package manager to install the missing component. E.g.: - Ubuntu: These are included in the libproj-dev. - Fedora: You have to install the proj-nad package. * make failures for PDL with error messages like: make: Warning: File `Makefile.PL' has modification time 3.1e+05 s in the future Makefile out-of-date with respect to Makefile.PL This problem has been seen on some Linux Virtual Machines where there was a problem with the synchronization of the VM time with the host OS system time. A quick work- around for the problem is to 'touch Makefile.PL' which updates the file time for Makefile.PL to "now" so make runs correctly. * If you wish to avoid interactive prompts during the PDL configure process (e.g., the perl Makefile.PL stage), you can set the environment variable PERL_MM_USE_DEFAULT to 1 so the default values are taken automatically. PDL-2.074/DEPENDENCIES0000644000175000017500000002306714164221257013660 0ustar osboxesosboxes+----------------------------------------------------------------------------+ | PDL Module Dependencies | +----------------------------------------------------------------------------+ This file lists dependencies of PDL modules on external programs or libraries. Some of the modules will build ok without the external software but in general are not very useful without it. Others require certain libraries/include files to be installed. See INSTALL on hints how to enable/disable building of some modules in the distribution if required. The easiest way to resolve dependencies on other Perl modules is to use the CPAN module to install PDL. Installation should be as simple as cpan install PDL # if the cpan script is in your path or if you don't have the cpan script try perl -MCPAN -e shell cpan> install PDL +----------------+---------------------+-------------------------------------+ | MODULE | DEPENDS ON | COMMENT | +----------------+---------------------+-------------------------------------+ PDL (all) perl >= 5.10.x PDL requires at least this version of perl to build and run. Devel::CheckLib >= 1.01 File::Spec >= 0.6 perl5 core module. File::Temp >= 0 perl5 core module. Pod::Parser >= 0 perl5 core module. Pod::Select >= 0 perl5 core module. ExtUtils::MakeMaker >= 6.56 This version of EU::MM is the first with support for CONFIGURE_REQUIRES. Test::Exception >= 0 Needed for test suite. PDL::NiceSlice Text::Balanced >= 1.89 A nicer way to index ndarrays. Filter::Util::Call Filter::Simple Required for new PDL::NiceSlice Module::Compile implementation under development. Inline::Pdlpp Inline >= 0.68 This module allows defining fast Inline::C >= 0.62 PP code inline in your scripts. NOTE: Though Inline is listed as as PDL prerequisite for CPAN, you can build PDL manually without it. PDL::ParallelCPU pthreads library Multi-CPU support will be enabled if libpthreads is detected and built against. A pthreads for win32 can be found at http://sourceware.org/pthreads-win32/ PDL::IO::Dumper Data::Dumper >= 2.121 Convert::UU Convert::UU is required. uuencode/uudecode (Optional) Better performance on unix flavor platforms! They will be used instead of Convert::UU if detected. PDL::IO::Storable Storable >=1.03 perl >= 5.10.x Will build but won't work for perl versions prior to 5.10.0 pdl2 (shell) Devel::REPL >= 1.003011 and Term::ReadLine::Perl or Term::ReadLine::Gnu Devel::REPL requires Data::Dump::Streamer and Sys::SigAction to support pdl2. They may need to be hand-installed if you are doing a manual PDL build. perldl (shell) Term::ReadLine::Perl or Term::ReadLine::Gnu pdl2 (and perldl) will be installed by default. If Devel::REPL is not installed, pdl2 uses perldl. The same thing if a Term::ReadLine::Perl or Term::ReadLine::Gnu is not installed. PDL::GIS::Proj PDL::Transform::Proj A PDL interface to the PROJ4 geographic projection library and the PDL::Transform interface to PROJ4. See http://trac.osgeo.org/proj/ Module will be built if the PROJ4 library is installed and detected. PDL::Graphics::TriD Requires the perl OpenGL module be installed. See the POGL_VERSION entry in perldl.conf for the minimum required version. Perl OpenGL requires you have the OpenGL graphics library and FreeGLUT (Apple GLUT on Mac OS X) installed. PDL::Graphics::TriD will be built if Perl OpenGL is detected and of version greater than the POGL_VERSION in perldl.conf. To disable the build, edit perldl.conf and set WITH_3D => 0. PDL::Graphics::PGPLOT Requires both the PGPLOT perl module **and** the PGPLOT fortran library. See http://astro.caltech.edu/~tjp/pgplot for the library and http://metacpan.org/pod/PGPLOT for the perl module (on CPAN). NOTE: These are two separate items to be installed. PDL::Graphics::PGPLOT Module builds ok without PGPLOT module and library. PDL::Graphics::IIS To be useful an application that supports the 'IIS' protocol must be installed, e.g. SAOimage or Ximtool, see http://tdc-www.harvard.edu/software/saoimage.html http://iraf.noao.edu/iraf/web/projects/x11iraf/ PDL::Graphics::IIS builds without viewers. PDL::GSL modules Needs the GSL (Gnu Scientific Library) to build. Version >= 1.0 is required See http://www.gnu.org/software/gsl/ Will not be built unless an appropriate GSL version is installed and detected. PDL::IO::Browser Requires a 'curses'-compatible library. You'll need to enable in perldl.conf if you wish to try the new configure and build, no guarantees... Not built by default. PDL::IO::FastRaw PDL::IO::FlexRaw Memory-mapped file IO functions (mapfraw and mapflex) require File::Map 0.57 or higher. Built by default if File::Map dependencies are met. PDL::IO::FITS Needs Astro::FITS::Header for full support of all FITS header features. Will build ok, and run, without it but for given that Astro::FITS::Header is a Perl only module, you should install it unless you specifically need not. NOTE: It is currently listed as an official prerequisite module for the purposes of building with the cpan shell. PDL::IO::GD PDL interface to the GD image library. See http://www.libgd.org Will not be built unless libgd is already installed and detected. PDL::IO::HDF PDL interface to HDF4 library. See PDL::IO::HDF5 on CPAN for HDF5 bindings. Not all HDF4 types are supported. See http://www.hdfgroup.org/products/hdf4/ Will not be built unless the HDF4 libraries are detected. PDL::IO::Pic rpic/wpic: NetPBM converters See http://netpbm.sourceforge.net/ wmpeg: requires the ffmpeg program See http://ffmpeg.org/ Module builds ok without converters. Recommend at least version 10.58.00 of NetPBM. PDL::Minuit PDL interface to Minuit minimization routines in the CERN library, http://wwwasdoc.web.cern.ch/wwwasdoc/minuit/minmain.html The Minuit library code is included. A fortran compiler is required and ExtUtils:F77 (version >= 1.03). Will not be built unless ExtUtils::F77 is installed *and* supports your platform. PDL::Slatec Linear algebra routines. Several other PDL modules use PDL::Slatec Slatec fortran lib is included but requires a fortran compiler and ExtUtils::F77 (version >= 1.03). Will not be built unless ExtUtils::F77 is installed *and* supports your platform. PDL-2.074/Basic/0000755000175000017500000000000014200406301013102 5ustar osboxesosboxesPDL-2.074/Basic/SourceFilter/0000755000175000017500000000000014200406301015510 5ustar osboxesosboxesPDL-2.074/Basic/SourceFilter/FilterUtilCall.pm0000644000175000017500000000223314165550713020746 0ustar osboxesosboxes# This original Filter::Util::Call-based # PDL::NiceSlice engine. # use strict; use warnings; use Filter::Util::Call; ############################## # If you mess with the import filter, please also change the pdlpp importer # just above this comment! They both do similar things, but one to an eval string # and one to an import file. # --CED 5-Nov-2007 # sub import { my ($class) = @_; my ($file,$offset) = (caller)[1,2]; # for error reporting $offset++; ## Parse class name into a regexp suitable for filtration my $terminator = terminator_regexp($class); filter_add( sub { my ($status, $off, $end); my $count = 0; my $data = ""; while ($status = filter_read()) { return $status if $status < 0; if (defined($terminator) && m/$terminator/) { $off=1; last; } if (m/^\s*(__END__|__DATA__)\s*$/) { $end=$1; $off = 1; last; } $data .= $_; $count++; $_ = ""; } $_ = $data; $_ = findslice $_ unless $status < 0; # the actual filter $_ .= "no $class;\n" if $off; $_ .= "$end\n" if $end; return $count; } ); } sub unimport { filter_del(); } 1; PDL-2.074/Basic/SourceFilter/example0000644000175000017500000000171114014062163017075 0ustar osboxesosboxesuse PDL::LiteF; use PDL::NiceSlice; $x = sequence(10); print "\n",'source $x'.'((4)) translated -> $x((4))',"\n"; print "Result ",$x((4)),"\n\n"; print 'alternative syntax: $x->'.'((4)) translated -> $x->((4))',"\n\n"; print 'source $x'.'(1:4) .= 2; translated -> $x(1:4) .= 2;',"\n"; # this should be rewritten ($tmp = $x(1:4)) .= 2; print "Result: $x","\n\n"; print << 'EOP'; The arglist is split at commas but commas within matched brackets are protected. That should allow function invocations etc within the arglist: EOP print '$x'.'(1:end(0,22)) -> $x(1:end(0,22))',"\n\n"; print "recursive invocation is also supported:\n"; print '$x'.'(1,$y'.'(0:22)) -> $x(1,$y(0:22))',"\n\n"; no PDL::NiceSlice; print << 'EOP'; Now we have switched off source filtering by issuing no PDL::NiceSlice; Therefore, the next slice expression should not be touched: EOP # this shouldn't be touched print 'Source $x'.'(1:4) translation -> $x(1:4)',"\n\n"; PDL-2.074/Basic/SourceFilter/FilterSimple.pm0000644000175000017500000000070014174725051020462 0ustar osboxesosboxes# This is the new Filter::Simple engine for PDL::NiceSlice # use Filter::Simple; use strict; use warnings; FILTER_ONLY code_no_comments => sub { my ($text1,$text2) = ($_,''); ## print STDERR "**************** Input: \n$text1\n"; $text2 = perldlpp('PDL::NiceSlice', $text1); ## print STDERR "**************** Output: $text2\n"; $_ = $text2; }, all => sub { print if $PDL::NiceSlice::debug_filter }; 1; PDL-2.074/Basic/SourceFilter/t/0000755000175000017500000000000014200406301015753 5ustar osboxesosboxesPDL-2.074/Basic/SourceFilter/t/niceslice.t0000644000175000017500000001033114173454016020113 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::LiteF; require PDL::NiceSlice; # these are accessible inside sub my $pa = sequence 10; my $pb = pdl(1); my $c = PDL->pdl(7,6); my $idx = pdl 1,4,5; my $rg = pdl(2,7,2); sub translate_and_run { local $Test::Builder::Level = $Test::Builder::Level + 1; my ($txt, $expected_error) = @_; $expected_error ||= qr/^$/; my $retval = eval { my $etxt = PDL::NiceSlice::findslice($txt); note "$txt -> \n\t$etxt\n"; eval $etxt; }; like $@, $expected_error; $retval; } $pb = translate_and_run '$pa((5));'; cmp_ok($pb->at, '==', 5); $pb = translate_and_run '$pa->((5));'; cmp_ok($pb->at, '==', 5); $pb = translate_and_run '$pa(($c(1)->at(0)));'; is $pb->getndims, 0; ok(all $pb == 6); # the latest versions should do the 'at' automatically $pb = translate_and_run '$pa(($c(1)));'; is $pb->getndims, 0; ok(all $pb == 6); $c = translate_and_run '$pa(:);'; ok ($c->getdim(0) == 10 && all $c == $pa); $pb = translate_and_run '$pa($idx);'; ok(all $pb == $idx); # use 1-el ndarrays as indices my $cmp = pdl(2,4,6); $pb = translate_and_run '$pa($rg(0):$rg(1):$rg(2));'; ok(all $pb == $cmp); # mix ranges and index ndarrays $pa = sequence 5,5; $idx = pdl 2,3,0; $cmp = $pa->slice('-1:0')->dice_axis(1,$idx); translate_and_run '$pb = $pa(-1:0,$idx);'; ok(all $pb == $cmp); # # modifiers # $pa = sequence 10; $pb = translate_and_run '$pa($pa<3;?)' ; ok(all $pb == pdl(0,1,2)); # flat modifier $pa = sequence 3,3; $pb = translate_and_run '$pa(0:-2;_);'; ok(all $pb == sequence 8); # where modifier cannot be mixed with other modifiers $pa = sequence 10; $pb = translate_and_run '$pa($pa<3;?_)', qr/more than 1/; # more than one identifier $pa = sequence 3,3; $pb = translate_and_run '$pa(0;-|)'; eval {$pb++}; ok($pb->dim(0) == 3 && all $pb == 3*sequence(3)+1) or diag $pb; ok($pa->at(0,0) == 0) or diag $pa; # do we ignore whitspace correctly? $c = translate_and_run '$pa(0; - | )'; ok (all $c == $pb-1); # empty modifier block $pa = sequence 10; $pb = translate_and_run '$pa(0; )'; ok ($pb == $pa->at(0)); # modifiers repeated $pb = translate_and_run '$pa(0;-||)', qr/twice or more/; # foreach/for blocking $pa = ''; translate_and_run "foreach \n" . ' $pb(1,2,3,4) {$pa .= $pb;}'; is($pa, '1234'); $pa = ''; translate_and_run 'for $pb(1,2,3,4) {$pa .= $pb;}'; is($pa, '1234'); $pa = ''; translate_and_run 'for my $pb(1,2,3,4) {$pa .= $pb;}'; is($pa, '1234'); $pa = ''; translate_and_run 'for our $pb(1,2,3,4) {$pa .= $pb;}'; is($pa, '1234'); $pa = ''; # foreach and whitespace translate_and_run 'foreach my $pb (1,2,3,4) {$pa .= $pb;}'; is($pa, '1234'); # foreach and embedded expression $pa = ''; translate_and_run 'my $t = ones 10; foreach my $type ( $t(0)->list ) { $pa .= $type }'; is($pa, '1'); # block method access translation $pa = pdl(5,3,2); $c = translate_and_run 'my $method = "dim"; $pa->$method(0)'; is($c, $pa->dim(0)); # # todo ones # # whitespace tolerance $pa= sequence 10; translate_and_run '$c = $pa (0)'; is($c, $pa->at(0)); # comment tolerance translate_and_run << 'EOT'; $c = $pa-> # comment (0); EOT is($c, $pa->at(0)); translate_and_run << 'EOT'; $c = $pa-> # comment # comment line 2 (0); EOT is($c, $pa->at(0)); $pa = ''; # foreach and whitespace + comments translate_and_run << 'EOT'; foreach my $pb # a random comment thrown in (1,2,3,4) {$pa .= $pb;} EOT is($pa, '1234'); # test for correct header propagation $pa = ones(10,10); my $h = {NAXIS=>2, NAXIS1=>100, NAXIS=>100, COMMENT=>"Sample FITS-style header"}; $pa->sethdr($h); $pa->hdrcpy(1); translate_and_run '$pb = $pa(1:2,pdl(0,2));'; if ( !$@ ) { my %bh = %{$pb->gethdr}; my (@bhkeys) = sort keys %bh; my %hh = %{$h}; my (@hhkeys) = sort keys %hh; ok(join("",@bh{@bhkeys}) eq join("",@hh{@hhkeys})); } $pa = ones(10); my $ai = translate_and_run 'my $i = which $pa < 0; $pa($i);'; ok(isempty $ai ); { my $expected = q{ CREATE TABLE $table ( CHECK ( yr = $yr ) ) INHERITS ($schema.master_table) }; use PDL::NiceSlice; my $got = q{ CREATE TABLE $table ( CHECK ( yr = $yr ) ) INHERITS ($schema.master_table) }; is $got, $expected, 'NiceSlice leaves strings along'; my $data = join '', ; like $data, qr/we've got data/, "we've got data"; } done_testing; __DATA__ we've got data PDL-2.074/Basic/SourceFilter/ModuleCompile.pm0000644000175000017500000000041414165550762020630 0ustar osboxesosboxes## package Foo; use Module::Compile -base; use strict; use warnings; sub pmc_compile { my ($class, $source) = @_; # Convert $source into (most likely Perl 5) $compiled_output my $filtered = perldlpp('PDL::NiceSlice', $source); return $filtered; } 1; PDL-2.074/Basic/SourceFilter/local.perldlrc0000644000175000017500000000140714014062163020344 0ustar osboxesosboxes# some useful functions to experiment with # the new PDL source filter within the perldl shell # report switches translation reporting on/off # trans and notrans switch source filtering on/off # include the perl code below in your standard # perldl startup file ($ENV{HOME}/.perldlrc) # to have it always available when working # in the perldl shell $PERLDL::report = 0; sub report { my $ret = $PERLDL::report; $PERLDL::report = $_[0] if $#_ > -1; return $ret; } use PDL::NiceSlice; my $preproc = sub { my ($txt) = @_; my $new = PDL::NiceSlice::perldlpp $txt; print STDERR "processed $new\n" if report && $new ne $txt; return $new; }; sub trans { $PERLDL::PREPROCESS = $preproc } sub notrans { $PERLDL::PREPROCESS = undef } trans; # switch on by default 1; PDL-2.074/Basic/SourceFilter/NiceSlice.pm0000644000175000017500000011131614174725265017736 0ustar osboxesosboxesBEGIN { my %engine_ok = ( 'Filter::Util::Call' => 'PDL/NiceSlice/FilterUtilCall.pm', 'Filter::Simple' => 'PDL/NiceSlice/FilterSimple.pm', 'Module::Compile' => 'PDL/NiceSlice/ModuleCompile.pm', ); # to validate names ## TODO: Add configuration argument to perldl.conf $PDL::NiceSlice::engine = $engine_ok{'Filter::Simple'}; # default engine type ## $PDL::NiceSlice::engine = $engine_ok{'Filter::Util::Call'}; # default engine type if ( exists $ENV{PDL_NICESLICE_ENGINE} ) { my $engine = $ENV{PDL_NICESLICE_ENGINE}; if ( exists $engine_ok{$engine} and $engine_ok{$engine} ) { $PDL::NiceSlice::engine = $engine_ok{$engine}; warn "PDL::NiceSlice using engine '$engine'\n" if $PDL::verbose; } elsif ( exists $engine_ok{$engine} and not $engine_ok{$engine} ) { warn "PDL::NiceSlice using default engine\n" if $PDL::verbose; } else { die "PDL::NiceSlice: PDL_NICESLICE_ENGINE set to invalid engine '$engine'\n"; } } } package PDL::NiceSlice; use strict; use warnings; our $VERSION = '1.001'; $VERSION = eval $VERSION; $PDL::NiceSlice::debug = defined($PDL::NiceSlice::debug) ? $PDL::NiceSlice::debug : 0; # replace all occurrences of the form # # $pdl(args); # or # $pdl->(args); # with # # $pdl->slice(processed_args); # # # Modified 2-Oct-2001: don't modify $var(LIST) if it's part of a # "for $var(LIST)" or "foreach $var(LIST)" statement. CED. # # Modified 5-Nov-2007: stop processing if we encounter m/^no\s+PDL\;:\;:NiceSlice\;\s*$/. # the next one is largely stolen from Regexp::Common my $RE_cmt = qr'(?:(?:\#)(?:[^\n]*)(?:\n))'; require PDL; # get PDL version number use Text::Balanced; # used to find parenthesis-delimited blocks # this is purely for performance reasons - patch submitted to repo my %ref_not_regex = map +($_=>1), qw(CODE Text::Balanced::Extractor); sub my_extract_multiple (;$$$$) # ($text, $functions_ref, $max_fields, $ignoreunknown) { my $textref = defined($_[0]) ? \$_[0] : \$_; my $posbug = pos; my ($lastpos, $firstpos); my @fields = (); #for ($$textref) { my @func = defined $_[1] ? @{$_[1]} : die "in overridden extract_multiple must supply functions"; my $max = defined $_[2] && $_[2]>0 ? $_[2] : 1_000_000_000; my $igunk = $_[3]; pos $$textref ||= 0; unless (wantarray) { use Carp; carp "extract_multiple reset maximal count to 1 in scalar context" if $^W && defined($_[2]) && $max > 1; $max = 1 } my $unkpos; my $func; my $class; my @class; foreach $func ( @func ) { if (ref($func) eq 'HASH') { push @class, (keys %$func)[0]; $func = (values %$func)[0]; } else { push @class, undef; } $func = qr/\G$func/ if !$ref_not_regex{ref $func}; } FIELD: while (pos($$textref) < length($$textref)) { my ($field, $rem); my @bits; foreach my $i ( 0..$#func ) { my $pref; $func = $func[$i]; $class = $class[$i]; $lastpos = pos $$textref; if (ref($func) eq 'CODE') { ($field,$rem,$pref) = @bits = $func->($$textref) } elsif (ref($func) eq 'Text::Balanced::Extractor') { @bits = $field = $func->extract($$textref) } elsif( $$textref =~ m/$func[$i]/gc ) { @bits = $field = defined($1) ? $1 : substr($$textref, $-[0], $+[0] - $-[0]) } $pref ||= ""; if (defined($field) && length($field)) { if (!$igunk) { $unkpos = $lastpos if length($pref) && !defined($unkpos); if (defined $unkpos) { push @fields, substr($$textref, $unkpos, $lastpos-$unkpos).$pref; $firstpos = $unkpos unless defined $firstpos; undef $unkpos; last FIELD if @fields == $max; } } push @fields, $class ? bless (\$field, $class) : $field; $firstpos = $lastpos unless defined $firstpos; $lastpos = pos $$textref; last FIELD if @fields == $max; next FIELD; } } if ($$textref =~ /\G(.)/gcs) { $unkpos = pos($$textref)-1 unless $igunk || defined $unkpos; } } if (defined $unkpos) { push @fields, substr($$textref, $unkpos); $firstpos = $unkpos unless defined $firstpos; $lastpos = length $$textref; } last; } pos $$textref = $lastpos; return @fields if wantarray; $firstpos ||= 0; eval { substr($$textref,$firstpos,$lastpos-$firstpos)=""; pos $$textref = $firstpos }; return $fields[0]; } sub my_extract_quotelike (;$$) { my $textref = $_[0] ? \$_[0] : \$_; my $wantarray = wantarray; my $pre = defined $_[1] ? $_[1] : '\s*'; my @match = Text::Balanced::_match_quotelike($textref,$pre,0,0); # do not match // alone as m// return Text::Balanced::_fail($wantarray, $textref) unless @match; return Text::Balanced::_succeed($wantarray, $textref, $match[2], $match[18]-$match[2], # MATCH @match[18,19], # REMAINDER @match[0,1], # PREFIX @match[2..17], # THE BITS @match[20,21], # ANY FILLET? ); } BEGIN { # override the current extract_quotelike() routine # needed before using Filter::Simple to work around a bug # between Text::Balanced and Filter::Simple for our purpose. no warnings 'redefine'; *Text::Balanced::extract_quotelike = \&my_extract_quotelike; *Text::Balanced::extract_multiple = \&my_extract_multiple; } # a call stack for error processing my @callstack = ('stackbottom'); sub curarg { my $arg = $callstack[-1]; # return top element of stack $arg =~ s/\((.*)\)/$1/s; return $arg; } sub savearg ($) {push @callstack,$_[0]} sub poparg () {pop @callstack} my @srcstr = (); # stack for refs to current source strings my $offset = 1; # line offset my $file = 'unknown'; my $mypostfix = ''; sub autosever { my ($this,$arg) = @_; $arg = 1 unless defined $arg; if ($arg) {$mypostfix = '->sever'} else {$mypostfix = ''} } sub line { die __PACKAGE__." internal error: can't determine line number" if $#srcstr < 0; my $pretext = substr ${$srcstr[0]}, 0, pos(${$srcstr[0]})-1; return ($pretext =~ tr/\n/\n/)+$offset; } sub filterdie { my ($msg) = @_; die "$msg\n\t at $file near line ". line().", slice expression '".curarg()."'\n"; } # non-bracketed prefix matching regexp my $prebrackreg = qr/^([^\(\{\[]*)/; # split regex $re separated arglist # but ignore bracket-protected bits # (i.e. text that is within matched brackets) sub splitprotected ($$) { my ($re,$txt) = @_; my ($got,$pre) = (1,''); my @chunks = (''); my $ct = 0; # infinite loop protection while ($got && $txt =~ /[({\[]/ && $ct++ < 1000) { # print "iteration $ct\n"; ($got,$txt,$pre) = Text::Balanced::extract_bracketed($txt,'{}()[]',$prebrackreg); my @partialargs = split $re, $pre, -1; $chunks[-1] .= shift @partialargs if @partialargs; push @chunks, @partialargs; $chunks[-1] .= $got; } filterdie "possible infinite parse loop, slice arg '".curarg()."'" if $ct == 1000; my @partialargs = split $re, $txt, -1; $chunks[-1] .= shift @partialargs if @partialargs; push @chunks, @partialargs; return @chunks; } # a pattern that finds occurrences of the form # # $var( # # and # # ->( # # used as the prefix pattern for findslice my $prefixpat = qr/.*? # arbitrary leading stuff ((?) # or just '->' (\s|$RE_cmt)* # ignore comments \s* # more whitespace (?=\()/smx; # directly followed by open '(' (look ahead) # translates a single arg into corresponding slice format sub onearg ($) { my ($arg) = @_; print STDERR "processing arg '$arg'\n" if $PDL::NiceSlice::debug; return q|'X'| if $arg =~ /^\s*:??\s*$/; # empty arg or just colon # recursively process args for slice syntax $arg = findslice($arg,$PDL::debug) if $arg =~ $prefixpat; # no doubles colon are matched to avoid confusion with Perl's C<::> if ($arg =~ /(? 3; $args[0] = 0 if !defined $args[0] || $args[0] =~ /^\s*$/; $args[1] = -1 if !defined $args[1] || $args[1] =~ /^\s*$/; $args[2] = undef if !defined $args[2] || $args[2] =~ /^\s*$/; return "[".join(',',grep defined,@args)."]"; # replace single ':' with ',' } # the (pos) syntax, i.e. 0D slice return "[$arg,0,0]" if $arg =~ s/^\s*\((.*)\)\s*$/$1/; # use the new [x,x,0] # we don't allow [] syntax (although that's what slice uses) filterdie "invalid slice expression containing '[', expression was '". curarg()."'" if $arg =~ /^\s*\[/; # If the arg starts with '*' it's a dummy call -- force stringification # and prepend a '*' for handling by slice. return "(q(*).($arg))" if($arg =~ s/^\s*\*//); # this must be a simple position, leave as is return "$arg"; } # process the arg list sub procargs { my ($txt) = @_; print STDERR "procargs: got '$txt'\n" if $PDL::NiceSlice::debug; # $txt =~ s/^\s*\((.*)\)\s*$/$1/s; # this is now done by findslice # push @callstack, $txt; # for later error reporting my $args = $txt =~ /^\s*$/s ? '' : join ',', map {onearg $_} splitprotected ',', $txt; ## Leave whitespace/newlines in so line count ## is preserved in error messages. Makes the ## filtered output ugly---iffi the input was ## ugly... ## ## $args =~ s/\s//sg; # get rid of whitespace # pop @callstack; # remove from call stack print STDERR "procargs: returned '($args)'\n" if $PDL::NiceSlice::debug; return "($args)"; } # this is the real workhorse that translates occurrences # of $x(args) into $args->slice(processed_arglist) # sub findslice { my ($src,$verb) = @_; push @srcstr, \$src; $verb = 0 unless defined $verb; my $processed = ''; my $ct=0; # protect against infinite loop my ($found,$prefix,$dummy); while ( $src =~ m/\G($prefixpat)/ && (($found,$dummy,$prefix) = Text::Balanced::extract_bracketed($src,'()',$prefixpat))[0] && $ct++ < 1000) { print STDERR "pass $ct: found slice expr $found at line ".line()."\n" if $verb; # Do final check for "for $var(LIST)" and "foreach $var(LIST)" syntax. # Process into an 'slice' call only if it's not that. if ($prefix =~ m/for(each)?(\s+(my|our))?\s+\$\w+(\s|$RE_cmt)*$/s || # foreach statement: Don't translate $prefix =~ m/->\s*\$\w+$/s) # e.g. $x->$method(args) # method invocation via string, don't translate either { # note: even though we reject this one we need to call # findslice on $found in case # it contains slice expressions $processed .= "$prefix".findslice($found); } else { # statement is a real slice and not a foreach my ($call,$pre,$post,$arg); # the following section got an overhaul in v0.99 # to fix modifier parsing and allow >1 modifier # this code still needs polishing savearg $found; # error reporting print STDERR "findslice: found '$found'\n" if $PDL::NiceSlice::debug; $found =~ s/^\s*\((.*)\)\s*$/$1/s; my ($slicearg,@mods) = splitprotected ';', $found; filterdie "more than 1 modifier group: @mods" if @mods > 1; # filterdie "invalid modifier $1" # if $found =~ /(;\s*[[:graph:]]{2,}?\s*)\)$/; print STDERR "MODS: " . join(',',@mods) . "\n" if $PDL::NiceSlice::debug; my @post = (); # collects all post slice operations my @pre = (); if (@mods) { (my $mod = $mods[0]) =~ s/\s//sg; # eliminate whitespace my @modflags = split '', $mod; print STDERR "MODFLAGS: @modflags\n" if $PDL::NiceSlice::debug; filterdie "more than 1 modifier incompatible with ?: @modflags" if @modflags > 1 && grep (/\?/, @modflags); # only one flag with where my %seen = (); if (@modflags) { for my $mod1 (@modflags) { if ($mod1 eq '?') { $seen{$mod1}++ && filterdie "modifier $mod1 used twice or more"; $call = 'where'; $arg = "(" . findslice($slicearg) . ")"; # $post = ''; # no post action required } elsif ($mod1 eq '_') { $seen{$mod1}++ && filterdie "modifier $mod1 used twice or more"; push @pre, 'flat->'; $call ||= 'slice'; # do only once $arg = procargs($slicearg); # $post = ''; # no post action required } elsif ($mod1 eq '|') { $seen{$mod1}++ && filterdie "modifier $mod1 used twice or more"; $call ||= 'slice'; $arg ||= procargs($slicearg); push @post, '->sever'; } elsif ($mod1 eq '-') { $seen{$mod1}++ && filterdie "modifier $mod1 used twice or more"; $call ||= 'slice'; $arg ||= procargs($slicearg); push @post, '->reshape(-1)'; } else { filterdie "unknown modifier $mod1"; } } } else { # empty modifier block $call = 'slice'; $arg = procargs($slicearg); # $post = ''; } } else { # no modifier block $call = 'slice'; $arg = procargs($slicearg); # $post = ''; # $call = 'slice_if_pdl'; # handle runtime checks for $self type # $arg =~ s/\)$/,q{$found})/; # add original argument string # in case $self is not an ndarray # and the original call must be # generated } $pre = join '', @pre; # assumption here: sever should be last # and order of other modifiers doesn't matter $post = join '', sort @post; # need to ensure that sever is last $processed .= "$prefix". ($prefix =~ /->(\s*$RE_cmt*)*$/ ? '' : '->'). $pre.$call.$arg.$post.$mypostfix; } } # end of while loop poparg; # clean stack pop @srcstr; # clear stack # append the remaining text portion # use substr only if we have had at least one pass # through above loop (otherwise pos is uninitialized) $processed .= $ct > 0 ? substr $src, pos($src) : $src; } ############################## # termstr - generate a regexp to find turn-me-off strings # CED 5-Nov-2007 sub terminator_regexp{ my $clstr = shift; $clstr =~ s/([^a-zA-Z0-9])/\\$1/g; my $termstr = '^\s*no\s+'.$clstr.'\s*;\s*(#.*)*$'; return qr/$termstr/o; # allow trailing comments } sub reinstator_regexp{ my $clstr = shift; $clstr =~ s/([^a-zA-Z0-9])/\\$1/g; my $reinstr = '^\s*use\s+'.$clstr.'\s*;\s*(#.*)*$'; return qr/$reinstr/o; # allow trailing comments } # safe eval of findslice that should be used within perldl or pdl2 # as a preprocessor sub perldlpp { my ($class, $txt) = @_; local($_); ############################## # Backwards compatibility to before the two-parameter form. The only # call should be around line 206 of PDL::AutoLoader, but one never # knows.... # -- CED 5-Nov-2007 if(!defined($txt)) { print "PDL::NiceSlice::perldlpp -- got deprecated one-argument form, from ".(join("; ",caller))."...\n"; $txt = $class; $class = "PDL::NiceSlice"; } ## Debugging to track exactly what is going on -- left in, in case it's needed again if($PDL::debug > 1) { print "PDL::NiceSlice::perldlpp - got:\n$txt\n"; my $i; for $i(0..5){ my($package,$filename,$line,$subroutine, $hasargs) = caller($i); printf("layer %d: %20s, %40s, line %5d, sub %20s, args: %d\n",$i,$package,$filename,$line,$subroutine,$hasargs); } } ############################## ## This block sort-of echoes import(), below... ## Crucial difference: we don't give up the ghost on termination conditions, only ## mask out current findslices. That's because future uses won't be processed ## (for some reason source filters don't work on evals). my @lines= split /\n/,$txt; my $terminator = terminator_regexp($class); my $reinstator = reinstator_regexp($class); my($status, $off, $end, $new, $count); eval { do { my $data = ""; while(@lines) { $_= shift @lines; if(defined($terminator) && m/$terminator/) { $_ = "## $_"; $off = 1; last; } if(defined($reinstator) && m/$reinstator/) { $_ = "## $_"; } if(m/^\s*(__END__|__DATA__)\s*$/) { $end=$1; $off = 1; last; } $data .= "$_\n"; $count++; $_=""; } $_ = $data; $_ = findslice $_ ; $_ .= "no $class;\n" if $off; $_ .= "$end\n" if $end; $new .= "$_"; while($off && @lines) { $_ = shift @lines; if(defined($reinstator) && m/$reinstator/) { $off = 0; $_ = "## $_"; } if(defined($terminator) && m/$terminator/) { $_ = "## $_"; } $new .= "$_\n"; } } while(@lines && !$end); }; if ($@) { my $err = $@; for (split '','#!|\'"%~/') { return "print q${_}NiceSlice error: $err${_}" unless $err =~ m{[$_]}; } return "print q{NiceSlice error: $err}"; # if this doesn't work # we're stuffed } if($PDL::debug > 1) { print "PDL::NiceSlice::perldlpp - returning:\n$new\n"; } return $new; } BEGIN { require "$PDL::NiceSlice::engine"; } =head1 NAME PDL::NiceSlice - toward a nicer slicing syntax for PDL =head1 SYNOPSYS use PDL::NiceSlice; $x(1:4) .= 2; # concise syntax for ranges print $y((0),1:$end); # use variables in the slice expression $x->transpose->(($pos-1)) .= 0; # default method syntax $idx = long 1, 7, 3, 0; # an ndarray of indices $x(-3:2:2,$idx) += 3; # mix explicit indexing and ranges $x->clump(1,2)->(0:30); # 'default method' syntax $x(myfunc(0,$var),1:4)++; # when using functions in slice expressions # use parentheses around args! $y = $x(*3); # Add dummy dimension of order 3 # modifiers are specified in a ;-separated trailing block $x($x!=3;?)++; # short for $x->where($x!=3)++ $x(0:1114;_) .= 0; # short for $x->flat->(0:1114) $y = $x(0:-1:3;|); # short for $x(0:-1:3)->sever $n = sequence 3,1,4,1; $y = $n(;-); # drop all dimensions of size 1 (AKA squeeze) $y = $n(0,0;-|); # squeeze *and* sever $c = $x(0,3,0;-); # more compact way of saying $x((0),(3),(0)) =head1 DESCRIPTION Slicing is a basic, extremely common operation, and PDL's L method would be cumbersome to use in many cases. C rectifies that by incorporating new slicing syntax directly into the language via a perl I (see L). NiceSlice adds no new functionality, only convenient syntax. NiceSlice is loaded automatically in the perldl or pdl2 shell, but (to avoid conflicts with other modules) must be loaded explicitly in standalone perl/PDL scripts (see below). If you prefer not to use a prefilter on your standalone scripts, you can use the L method in those scripts, rather than the more compact NiceSlice constructs. =head1 Use in scripts and C or C shell The new slicing syntax can be switched on and off in scripts and perl modules by using or unloading C. But now back to scripts and modules. Everything after C will be translated and you can use the new slicing syntax. Source filtering will continue until the end of the file is encountered. You can stop sourcefiltering before the end of the file by issuing a C statement. Here is an example: use PDL::NiceSlice; # this code will be translated # and you can use the new slicing syntax no PDL::NiceSlice; # this code won't # and the new slicing syntax will raise errors! See also L and F in this distribution for further examples. NOTE: Unlike "normal" modules you need to include a C call in each and every file that contains code that uses the new slicing syntax. Imagine the following situation: a file F # start test0.pl use PDL; use PDL::NiceSlice; $x = sequence 10; print $x(0:4),"\n"; require 'test1.pl'; # end test0.pl that Cs a second file F # begin test1.pl $aa = sequence 11; print $aa(0:7),"\n"; 1; # end test1.pl Following conventional perl wisdom everything should be alright since we Cd C and C already from within F and by the time F is Cd things should be defined and imported, etc. A quick test run will, however, produce something like the following: perl test0.pl [0 1 2 3 4] syntax error at test1.pl line 3, near "0:" Compilation failed in require at test0.pl line 7. This can be fixed by adding the line use PDL::NiceSlice; C the code in F that uses the new slicing syntax (to play safe just include the line near the top of the file), e.g. # begin corrected test1.pl use PDL::NiceSlice; $aa = sequence 11; print $aa(0:7),"\n"; 1; # end test1.pl Now things proceed more smoothly perl test0.pl [0 1 2 3 4] [0 1 2 3 4 5 6 7] Note that we don't need to issue C again. C is a somewhat I module in that respect. It is a consequence of the way source filtering works in Perl (see also the IMPLEMENTATION section below). =head2 evals and C Due to C being a source filter it won't work in the usual way within evals. The following will I do what you want: $x = sequence 10; eval << 'EOE'; use PDL::NiceSlice; $y = $x(0:5); EOE print $y; Instead say: use PDL::NiceSlice; $x = sequence 10; eval << 'EOE'; $y = $x(0:5); EOE print $y; Source filters I be executed at compile time to be effective. And C is just a source filter (although it is not necessarily obvious for the casual user). =head1 The new slicing syntax Using C slicing ndarrays becomes so much easier since, first of all, you don't need to make explicit method calls. No $pdl->slice(....); calls, etc. Instead, C introduces two ways in which to slice ndarrays without too much typing: =over 2 =item * using parentheses directly following a scalar variable name, for example $c = $y(0:-3:4,(0)); =item * using the so called I invocation in which the ndarray object is treated as if it were a reference to a subroutine (see also L). Take this example that slices an ndarray that is part of a perl list C<@b>: $c = $b[0]->(0:-3:4,(0)); =back The format of the argument list is the same for both types of invocation and will be explained in more detail below. =head2 Parentheses following a scalar variable name An arglist in parentheses following directly after a scalar variable name that is I preceded by C<&> will be resolved as a slicing command, e.g. $x(1:4) .= 2; # only use this syntax on ndarrays $sum += $x(,(1)); However, if the variable name is immediately preceded by a C<&>, for example &$x(4,5); it will not be interpreted as a slicing expression. Rather, to avoid interfering with the current subref syntax, it will be treated as an invocation of the code reference C<$x> with argumentlist C<(4,5)>. The $x(ARGS) syntax collides in a minor way with the perl syntax. In particular, ``foreach $var(LIST)'' appears like a PDL slicing call. NiceSlice avoids translating the ``for $var(LIST)'' and ``foreach $var(LIST)'' constructs for this reason. Since you can't use just any old lvalue expression in the 'foreach' 'for' constructs -- only a real perl scalar will do -- there's no functionality lost. If later versions of perl accept ``foreach (LIST)'', then you can use the code ref syntax, below, to get what you want. =head2 The I syntax The second syntax that will be recognized is what I called the I syntax. It is the method arrow C<-E> directly followed by an open parenthesis, e.g. $x->transpose->(($pos)) .= 0; Note that this conflicts with the use of normal code references, since you can write in plain Perl $sub = sub { print join ',', @_ }; $sub->(1,'a'); NOTE: Once C is in effect (you can always switch it off with a line C anywhere in the script) the source filter will incorrectly replace the above call to C<$sub> with an invocation of the slicing method. This is one of the pitfalls of using a source filter that doesn't know anything about the runtime type of a variable (cf. the Implementation section). This shouldn't be a major problem in practice; a simple workaround is to use the C<&>-way of calling subrefs, e.g.: $sub = sub { print join ',', @_ }; &$sub(1,'a'); =head2 When to use which syntax? Why are there two different ways to invoke slicing? The first syntax C<$x(args)> doesn't work with chained method calls. E.g. $x->xchg(0,1)(0); won't work. It can I be used directly following a valid perl variable name. Instead, use the I syntax in such cases: $x->transpose->(0); Similarly, if you have a list of ndarrays C<@pdls>: $y = $pdls[5]->(0:-1); =head2 The argument list The argument list is a comma separated list. Each argument specifies how the corresponding dimension in the ndarray is sliced. In contrast to usage of the L method the arguments should I be quoted. Rather freely mix literals (1,3,etc), perl variables and function invocations, e.g. $x($pos-1:$end,myfunc(1,3)) .= 5; There can even be other slicing commands in the arglist: $x(0:-1:$pdl($step)) *= 2; NOTE: If you use function calls in the arglist make sure that you use parentheses around their argument lists. Otherwise the source filter will get confused since it splits the argument list on commas that are not protected by parentheses. Take the following example: sub myfunc { return 5*$_[0]+$_[1] } $x = sequence 10; $sl = $x(0:myfunc 1, 2); print $sl; PDL barfed: Error in slice:Too many dims in slice Caught at file /usr/local/bin/perldl, line 232, pkg main The simple fix is $sl = $x(0:myfunc(1, 2)); print $sl; [0 1 2 3 4 5 6 7] Note that using prototypes in the definition of myfunc does not help. At this stage the source filter is simply not intelligent enough to make use of this information. So beware of this subtlety. Another pitfall to be aware of: currently, you can't use the conditional operator in slice expressions (i.e., C, since the parser confuses them with ranges). For example, the following will cause an error: $x = sequence 10; $y = rand > 0.5 ? 0 : 1; # this one is ok print $x($y ? 1 : 2); # error ! syntax error at (eval 59) line 3, near "1, For the moment, just try to stay clear of the conditional operator in slice expressions (or provide us with a patch to the parser to resolve this issue ;). =head2 Modifiers Following a suggestion originally put forward by Karl Glazebrook the latest versions of C implement I in slice expressions. Modifiers are convenient shorthands for common variations on PDL slicing. The general syntax is $pdl(;) Four modifiers are currently implemented: =over =item * C<_> : I the ndarray before applying the slice expression. Here is an example $y = sequence 3, 3; print $y(0:-2;_); # same as $y->flat->(0:-2) [0 1 2 3 4 5 6 7] which is quite different from the same slice expression without the modifier print $y(0:-2); [ [0 1] [3 4] [6 7] ] =item * C<|> : L the link to the ndarray, e.g. $x = sequence 10; $y = $x(0:2;|)++; # same as $x(0:2)->sever++ print $y; [1 2 3] print $x; # check if $x has been modified [0 1 2 3 4 5 6 7 8 9] =item * C : short hand to indicate that this is really a L expression As expressions like $x->where($x>5) are used very often you can write that shorter as $x($x>5;?) With the C-modifier the expression preceding the modifier is I really a slice expression (e.g. ranges are not allowed) but rather an expression as required by the L method. For example, the following code will raise an error: $x = sequence 10; print $x(0:3;?); syntax error at (eval 70) line 3, near "0:" That's about all there is to know about this one. =item * C<-> : I out any singleton dimensions. In less technical terms: reduce the number of dimensions (potentially) by deleting all dims of size 1. It is equivalent to doing a L(-1). That can be very handy if you want to simplify the results of slicing operations: $x = ones 3, 4, 5; $y = $x(1,0;-); # easier to type than $x((1),(0)) print $y->info; PDL: Double D [5] It also provides a unique opportunity to have smileys in your code! Yes, PDL gives new meaning to smileys. =back =head2 Combining modifiers Several modifiers can be used in the same expression, e.g. $c = $x(0;-|); # squeeze and sever Other combinations are just as useful, e.g. C<;_|> to flatten and sever. The sequence in which modifiers are specified is not important. A notable exception is the C modifier (C) which must not be combined with other flags (let me know if you see a good reason to relax this rule). Repeating any modifier will raise an error: $c = $x(-1:1;|-|); # will cause error NiceSlice error: modifier | used twice or more Modifiers are still a new and experimental feature of C. I am not sure how many of you are actively using them. I. I think modifiers are very useful and make life a lot easier. Feedback is welcome as usual. The modifier syntax will likely be further tuned in the future but we will attempt to ensure backwards compatibility whenever possible. =head2 Argument formats In slice expressions you can use ranges and secondly, ndarrays as 1D index lists (although compare the description of the C-modifier above for an exception). =over 2 =item * ranges You can access ranges using the usual C<:> separated format: $x($start:$stop:$step) *= 4; Note that you can omit the trailing step which then defaults to 1. Double colons (C<::>) are not allowed to avoid clashes with Perl's namespace syntax. So if you want to use steps different from the default you have to also at least specify the stop position. Examples: $x(::2); # this won't work (in the way you probably intended) $x(:-1:2); # this will select every 2nd element in the 1st dim Just as with L negative indices count from the end of the dimension backwards with C<-1> being the last element. If the start index is larger than the stop index the resulting ndarray will have the elements in reverse order between these limits: print $x(-2:0:2); [8 6 4 2 0] A single index just selects the given index in the slice print $x(5); [5] Note, however, that the corresponding dimension is not removed from the resulting ndarray but rather reduced to size 1: print $x(5)->info PDL: Double D [1] If you want to get completely rid of that dimension enclose the index in parentheses (again similar to the L syntax): print $x((5)); 5 In this particular example a 0D ndarray results. Note that this syntax is only allowed with a single index. All these will be errors: print $x((0,4)); # will work but not in the intended way print $x((0:4)); # compile time error An empty argument selects the whole dimension, in this example all of the first dimension: print $x(,(0)); Alternative ways to select a whole dimension are $x = sequence 5, 5; print $x(:,(0)); print $x(0:-1,(0)); print $x(:-1,(0)); print $x(0:,(0)); Arguments for trailing dimensions can be omitted. In that case these dimensions will be fully kept in the sliced ndarray: $x = random 3,4,5; print $x->info; PDL: Double D [3,4,5] print $x((0))->info; PDL: Double D [4,5] print $x((0),:,:)->info; # a more explicit way PDL: Double D [4,5] print $x((0),,)->info; # similar PDL: Double D [4,5] =item * dummy dimensions As in L, you can insert a dummy dimension by preceding a single index argument with '*'. A lone '*' inserts a dummy dimension of order 1; a '*' followed by a number inserts a dummy dimension of that order. =item * ndarray index lists The second way to select indices from a dimension is via 1D ndarrays of indices. A simple example: $x = random 10; $idx = long 3,4,7,0; $y = $x($idx); This way of selecting indices was previously only possible using L (C attempts to unify the C and C interfaces). Note that the indexing ndarrays must be 1D or 0D. Higher dimensional ndarrays as indices will raise an error: $x = sequence 5, 5; $idx2 = ones 2,2; $sum = $x($idx2)->sum; ndarray must be <= 1D at /home/XXXX/.perldlrc line 93 Note that using index ndarrays is not as efficient as using ranges. If you can represent the indices you want to select using a range use that rather than an equivalent index ndarray. In particular, memory requirements are increased with index ndarrays (and execution time I be longer). That said, if an index ndarray is the way to go use it! =back As you might have expected ranges and index ndarrays can be freely mixed in slicing expressions: $x = random 5, 5; $y = $x(-1:2,pdl(3,0,1)); =head2 ndarrays as indices in ranges You can use ndarrays to specify indices in ranges. No need to turn them into proper perl scalars with the new slicing syntax. However, make sure they contain not more than one element! Otherwise a runtime error will be triggered. First a couple of examples that illustrate proper usage: $x = sequence 5, 5; $rg = pdl(1,-1,3); print $x($rg(0):$rg(1):$rg(2),2); [ [11 14] ] print $x($rg+1,:$rg(0)); [ [2 0 4] [7 5 9] ] The next one raises an error print $x($rg+1,:$rg(0:1)); multielement ndarray where only one allowed at XXX/Core.pm line 1170. The problem is caused by using the 2-element ndarray C<$rg(0:1)> as the stop index in the second argument C<:$rg(0:1)> that is interpreted as a range by C. You I use multielement ndarrays as index ndarrays as described above but not in ranges. And C treats any expression with unprotected C<:>'s as a range. I means as usual I<"not occurring between matched parentheses">. =head1 IMPLEMENTATION C exploits the ability of Perl to use source filtering (see also L). A source filter basically filters (or rewrites) your perl code before it is seen by the compiler. C searches through your Perl source code and when it finds the new slicing syntax it rewrites the argument list appropriately and splices a call to the C method using the modified arg list into your perl code. You can see how this works in the L or L shells by switching on reporting (see above how to do that). =head1 BUGS =head2 Conditional operator The conditional operator can't be used in slice expressions (see above). =head2 The C file handle I: To avoid clobbering the C filehandle C switches itself off when encountering the C<__END__> or C<__DATA__> tokens. This should not be a problem for you unless you use C to load PDL code including the new slicing from that section. It is even desirable when working with L, see below. =head2 Possible interaction with L There is currently an undesired interaction between C and L. Since PP code generally contains expressions of the type C<$var()> (to access ndarrays, etc) C recognizes those I as slice expressions and does its substitutions. This is not a problem if you use the C section for your Pdlpp code -- the recommended place for Inline code anyway. In that case C will have switched itself off before encountering any Pdlpp code (see above): # use with Inline modules use PDL; use PDL::NiceSlice; use Inline Pdlpp; $x = sequence(10); print $x(0:5); __END__ __Pdlpp__ ... inline stuff Otherwise switch C explicitly off around the Inline::Pdlpp code: use PDL::NiceSlice; $x = sequence 10; $x(0:3)++; $x->inc; no PDL::NiceSlice; # switch off before Pdlpp code use Inline Pdlpp => "Pdlpp source code"; The cleaner solution is to always stick with the C way of including your C code as in the first example. That way you keep your nice Perl code at the top and all the ugly Pdlpp stuff etc at the bottom. =head2 Bug reports Feedback and bug reports are welcome. Please include an example that demonstrates the problem. Log bug reports in the PDL issues tracker at L or send them to the pdl-devel mailing list (see L). =head1 COPYRIGHT Copyright (c) 2001, 2002 Christian Soeller. All Rights Reserved. This module is free software. It may be used, redistributed and/or modified under the same terms as PDL itself (see L). =cut 1; PDL-2.074/Basic/SourceFilter/Changes0000644000175000017500000000213314146003631017012 0ustar osboxesosboxes1.0.0 - fix parsing foreach: detect embedded niceslice expressions 0.99.2 - changed to 2 dot version number - fix parsing problems with interspersed whitespace and comments 0.991 - don't translate method invocation via string, e.g. $a->$method(0) - require PDL in Makefile.PL 0.99 - allow more than one modifier - fix modifier parsing 0.97 - nslice updates (indexing with multidim ndarrays) yet undocumented I think 0.96 - splitprotected interface similar to split's 0.95 - squeeze modifier (;-) 0.91 - leave 'for(each)? (my|our) $y(0,1) {}' alone 0.9 - source filters clobber the DATA file handle unless they are disabled upon encountering __DATA__|__END__ ! Fixed NiceSlice to avoid that. (now uses Filter::Util::Call directly) - doc updates - doc updates 0.8 - CED: leave 'for(each)? $x(...) {}' alone - fix error bug (reported by Doug Burke) - docs clarification 0.7 - fixed a bug that sometimes screwed up error reporting - modifiers: _,?,| 0.6 - doc updates - declare nslice lvalue sub if perl version >= 5.6.0 - KGB: fix multiline parsing 0.5 - initial public release PDL-2.074/Basic/SourceFilter/Makefile.PL0000644000175000017500000000136414146003631017476 0ustar osboxesosboxesuse strict; use warnings; use ExtUtils::MakeMaker; undef &MY::postamble; # suppress warning *MY::postamble = sub { " README: README.head NiceSlice.pm \tcp README.head README \tpod2text NiceSlice.pm >> README "; }; WriteMakefile( NAME => 'PDL::NiceSlice', VERSION_FROM => 'NiceSlice.pm', PM => { 'NiceSlice.pm' => '$(INST_LIBDIR)/NiceSlice.pm', 'FilterUtilCall.pm' => '$(INST_LIBDIR)/NiceSlice/FilterUtilCall.pm', 'FilterSimple.pm' => '$(INST_LIBDIR)/NiceSlice/FilterSimple.pm', 'ModuleCompile.pm' => '$(INST_LIBDIR)/NiceSlice/ModuleCompile.pm', }, PREREQ_PM => { 'Filter::Util::Call' => 0, 'Text::Balanced' => 0, 'PDL' => 2.003000, # 'Module::Compile' => '0.23', }, NO_MYMETA => 1, ); PDL-2.074/Basic/Ops/0000755000175000017500000000000014200406301013643 5ustar osboxesosboxesPDL-2.074/Basic/Ops/ops.pd0000644000175000017500000005124214200051601014774 0ustar osboxesosboxesuse strict; use warnings; use PDL::Types qw(types ppdefs ppdefs_all ppdefs_complex); require PDL::Core::Dev; my $A = [ppdefs_all]; my $C = [ppdefs_complex]; my $F = [map $_->ppsym, grep $_->real && !$_->integer, types]; my $AF = [map $_->ppsym, grep !$_->integer, types]; my $T = [map $_->ppsym, grep $_->integer, types]; my $U = [map $_->ppsym, grep $_->unsigned, types]; my $S = [map $_->ppsym, grep $_->real && !$_->unsigned, types]; my %is_real; @is_real{ppdefs()} = (); my @Rtypes = grep $_->real, types(); my @Ctypes = grep !$_->real, types(); my @Ftypes = grep !$_->integer, types(); pp_addpm({At=>'Top'},<<'EOD'); use strict; use warnings; my %OVERLOADS; =head1 NAME PDL::Ops - Fundamental mathematical operators =head1 DESCRIPTION This module provides the functions used by PDL to overload the basic mathematical operators (C<+ - / *> etc.) and functions (C etc.) It also includes the function C, which should be a perl function so that we can overload it! Matrix multiplication (the operator C) is handled by the module L. =head1 SYNOPSIS none =cut EOD pp_addpm({At=>'Bot'},<<'EOPM'); =head1 AUTHOR Tuomas J. Lukka (lukka@fas.harvard.edu), Karl Glazebrook (kgb@aaoepp.aao.gov.au), Doug Hunt (dhunt@ucar.edu), Christian Soeller (c.soeller@auckland.ac.nz), Doug Burke (burke@ifa.hawaii.edu), and Craig DeForest (deforest@boulder.swri.edu). =cut EOPM pp_addhdr(' #include /* MOD requires hackage to map properly into the positive-definite numbers. */ /* Resurrect the old MOD operator as the unsigned BU_MOD to get around this. --DAL 27-Jun-2008 */ /* Q_MOD is the same as MOD except the internal casts are to longlong. -DAL 18-Feb-2015 */ /* Also changed the typecast in MOD to (long), and added a N==0 conditional to BU_MOD. -DAL 06-Mar-2015 */ #define MOD(X,N) ( ((N) == 0) ? 0 : ( (X) - (ABS(N)) * ((long )((X)/(ABS(N))) + ( ( ((N) * ((long )((X)/(N)))) != (X) ) ? ( ( ((N)<0) ? 1 : 0 ) + ( (((X)<0) ? -1 : 0))) : 0 )))) #define Q_MOD(X,N) (((N) == 0) ? 0 : ( (X) - (ABS(N)) * ((long long)((X)/(ABS(N))) + ( ( ((N) * ((long long)((X)/(N)))) != (X) ) ? ( ( ((N)<0) ? 1 : 0 ) + ( (((X)<0) ? -1 : 0))) : 0 )))) #define BU_MOD(X,N)(((N) == 0) ? 0 : ( (X)-(N)*((int)((X)/(N))) )) #define SPACE(A,B) ( ((A)<(B)) ? -1 : ((A)!=(B)) ) #define ABS(A) ( (A)>=0 ? (A) : -(A) ) '); sub protect_chars { my ($txt) = @_; $txt =~ s/>/E;gt#/g; $txt =~ s//g; return $txt; } # simple binary operators sub biop { my ($name,$op,$mutator,$doc,%extra) = @_; my $optxt = protect_chars ref $op eq 'ARRAY' ? $op->[1] : $op; $op = $op->[0] if ref $op eq 'ARRAY'; $extra{HdrCode} = << 'EOH'; pdl *tmp; if (swap) { tmp = a; a = b; b = tmp; } EOH # handle exceptions my $badcode = ' ( $PDLSTATEISBAD(a) && $ISBAD(a()) ) || ( $PDLSTATEISBAD(b) && $ISBAD(b()) )'; if ( exists $extra{Exception} ) { # NOTE This option is unused ($badcode is not set). # See also `ufunc()`. delete $extra{Exception}; } if ($extra{Comparison}) { my $first_complex = $Ctypes[0]->sym; $extra{HdrCode} .= < 1; if ((a->datatype >= $first_complex) || (b->datatype >= $first_complex)) barf("Can't compare complex numbers"); EOF $extra{HdrCode} .= <<'EOH'; { complex double bad_a, bad_b; PDL_Anyval a_badval = PDL->get_pdl_badvalue(a); if (a_badval.type < 0) barf("Error getting badvalue, type=%d", a_badval.type); ANYVAL_TO_CTYPE(bad_a, complex double, a_badval); PDL_Anyval b_badval = PDL->get_pdl_badvalue(b); if (b_badval.type < 0) barf("Error getting badvalue, type=%d", b_badval.type); ANYVAL_TO_CTYPE(bad_b, complex double, b_badval); if( bad_a == 0 || bad_a == 1 || bad_b == 0 || bad_b == 1 ) { warn("Badvalue is set to 0 or 1. This will cause data loss when using badvalues for comparison operators."); } } EOH delete $extra{Comparison}; } pp_addpm(make_overload($op, $name, $mutator, delete $extra{Bitwise})); pp_def($name, Pars => 'a(); b(); [o]c();', OtherPars => 'int swap', OtherParsDefaults => { swap => 0 }, HandleBad => 1, NoBadifNaN => 1, Inplace => [ 'a' ], # quick and dirty solution to get ->inplace do its job Code => pp_line_numbers(__LINE__-1, qq{ PDL_IF_BAD(if ( $badcode ) \$SETBAD(c()); else,) \$c() = \$a() $op \$b(); }), CopyBadStatusCode => pp_line_numbers(__LINE__, 'if ( $BADFLAGCACHE() ) { if ( a == c && $ISPDLSTATEGOOD(a) ) { PDL->propagate_badflag( c, 1 ); /* have inplace op AND badflag has changed */ } $SETPDLSTATEBAD(c); }'), %extra, Doc => << "EOD"); =for ref $doc =for example \$c = \$x $op \$y; # overloaded call \$c = $name \$x, \$y; # explicit call with default swap of 0 \$c = $name \$x, \$y, 1; # explicit call with trailing 1 to swap args \$x->inplace->$name(\$y); # modify \$x inplace It can be made to work inplace with the C<< \$x->inplace >> syntax. This function is used to overload the binary C<$optxt> operator. As of 2.065, when calling this function explicitly you can omit the third argument (see second example), or supply it (see third one). =cut EOD } # sub: biop() sub make_overload { my ($op, $name, $mutator, $bitwise, $one_arg) = @_; my $ret; my $bitwise_passon = $bitwise ? '$_[2]?@_[1,0]:@_[0,1]' : '@_'; if ($one_arg) { $ret = <(\$_[1], \$_[0], !\$_[2]); }; } } EOF } $ret .= <[1] : $func; my $isop=0; if ($funcov =~ s/^op//) { $isop = 1; } my $funcovp = protect_chars $funcov; $func = $func->[0] if ref $func eq 'ARRAY'; my $got_complex = PDL::Core::Dev::got_complex_version($func, 2); $extra{GenericTypes} = [ grep exists $is_real{$_}, @{$extra{GenericTypes}} ] if !$got_complex and $extra{GenericTypes}; $extra{HdrCode} .= << 'EOH'; pdl *tmp; if (swap) { tmp = a; a = b; b = tmp; } EOH my $ovcall; # is this one to be used as a function or operator ? if ($isop) { $ovcall = "\$c = \$a $funcov \$b; # overloaded use"; } else { $ovcall = "\$c = $funcov \$a, \$b; # overloaded use"; } my $codestr; if ($extra{unsigned}){ #a little dance to avoid the MOD macro warnings for byte & ushort datatypes my $t = join '', map $_->ppsym, grep $_->real, types(); my $v = join ',', map $_->unsigned ? 'BU_' : $_->ppsym eq 'Q' ? 'Q_' : '', grep $_->real, types(); $codestr = << "ENDCODE"; \$c() = (\$GENERIC(c))\$T$t($v)$func(\$a(),\$b()); ENDCODE #end dance } else { $codestr = '$c() = ($GENERIC(c))'.$func.'($a(),$b());'; } delete $extra{unsigned}; #remove the key so it doesn't get added in pp_def. pp_addpm(make_overload($funcov, $name, $mutator)); pp_def($name, HandleBad => 1, NoBadifNaN => 1, Pars => 'a(); b(); [o]c();', OtherPars => 'int swap', Inplace => [ 'a' ], # quick and dirty solution to get ->inplace do its job Code => pp_line_numbers(__LINE__, qq{ PDL_IF_BAD(if ( \$ISBAD(a()) || \$ISBAD(b()) ) \$SETBAD(c()); else {,) $codestr PDL_IF_BAD(},) }), CopyBadStatusCode => pp_line_numbers(__LINE__, 'if ( $BADFLAGCACHE() ) { if ( a == c && $ISPDLSTATEGOOD(a) ) { PDL->propagate_badflag( c, 1 ); /* have inplace op AND badflag has changed */ } $SETPDLSTATEBAD(c); }'), %extra, Doc => << "EOD"); =for ref $doc =for example \$c = \$x->$name(\$y,0); # explicit function call $ovcall \$x->inplace->$name(\$y,0); # modify \$x inplace It can be made to work inplace with the C<\$x-Einplace> syntax. This function is used to overload the binary C<$funcovp> function. Note that when calling this function explicitly you need to supply a third argument that should generally be zero (see first example). This restriction is expected to go away in future releases. =cut EOD } # sub: bifunc() # simple unary functions and operators sub ufunc { my ($name,$func,$overload,$doc,%extra) = @_; my $funcov = ref $func eq 'ARRAY' ? $func->[1] : $func; my $funcovp = protect_chars $funcov; $func = $func->[0] if ref $func eq 'ARRAY'; my $got_complex = PDL::Core::Dev::got_complex_version($func, 1); $extra{GenericTypes} = [ grep exists $is_real{$_}, @{$extra{GenericTypes}} ] if !$got_complex and $extra{GenericTypes}; # handle exceptions my $badcode = '$ISBAD(a())'; if ( exists $extra{Exception} ) { # $badcode .= " || $extra{Exception}"; # print "Warning: ignored exception for $name\n"; # NOTE This option is unused ($badcode is commented out above). # See also `biop()`. delete $extra{Exception}; } my $codestr = '$b() = ($GENERIC(b))'.$func.'($a());'; if (delete $extra{NoTgmath} and $got_complex) { # don't bother if not got complex version $codestr = join "\n", 'types('.join('', map $_->ppsym, @Rtypes).') %{'.$codestr.'%}', (map 'types('.$_->ppsym.') %{$b() = c'.$func.$_->floatsuffix.'($a());%}', @Ctypes), ; } pp_addpm(make_overload($funcov, $name, 0, 0, 1)) if $overload; # do not have to worry about propagation of the badflag when # inplace since only input ndarray is a, hence its badflag # won't change # UNLESS an exception occurs... pp_def($name, Pars => 'a(); [o]b()', HandleBad => 1, NoBadifNaN => 1, Inplace => 1, Code => pp_line_numbers(__LINE__, qq{ PDL_IF_BAD(if ( $badcode ) \$SETBAD(b()); else {,) $codestr PDL_IF_BAD(},) }), %extra, Doc => << "EOD"); =for ref $doc =for example \$y = $funcov \$x; \$x->inplace->$name; # modify \$x inplace It can be made to work inplace with the C<\$x-Einplace> syntax. This function is used to overload the unary C<$funcovp> operator/function. =cut EOD } # sub: ufunc() ###################################################################### # we trap some illegal operations here -- see the Exception option # note, for the ufunc()'s, the checks do not work too well # for unsigned integer types (ie < 0) # # XXX needs thinking about # - have to integrate into Code section as well (so # 12/pdl(2,4,0,3) is trapped and flagged bad) # --> complicated # - perhaps could use type %{ %} ? # # ==> currently have commented out the exception code, since # want to see if can use NaN/Inf for bad values # (would solve many problems for F,D types) # # there is an issue over how we handle comparison operators # - see Primitive/primitive.pd/zcover() for more discussion # ## arithmetic ops biop('plus','+',1,'add two ndarrays',GenericTypes => $A); biop('mult','*',1,'multiply two ndarrays',GenericTypes => $A); biop('minus','-',1,'subtract two ndarrays',GenericTypes => $A); biop('divide','/',1,'divide two ndarrays', Exception => '$b() == 0', GenericTypes => $A); ## note: divide should perhaps trap division by zero as well ## comparison ops # not defined for complex numbers biop('gt','>',0,'the binary E (greater than) operation', Comparison => 2); biop('lt','<',0,'the binary E (less than) operation', Comparison => 2); biop('le','<=',0,'the binary E= (less equal) operation', Comparison => 2); biop('ge','>=',0,'the binary E= (greater equal) operation', Comparison => 2); biop('eq','==',0,'binary I operation (C<==>)', Comparison => 1, GenericTypes => $A); biop('ne','!=',0,'binary I operation (C)', Comparison => 1, GenericTypes => $A); ## bit ops # those need to be limited to the right types biop('shiftleft','<<',1,'leftshift C<$a> by C<$b>',GenericTypes => $T); biop('shiftright','>>',1,'rightshift C<$a> by C<$b>',GenericTypes => $T); biop('or2','|',1,'binary I of two ndarrays',GenericTypes => $T, Bitwise => 1); biop('and2','&',1,'binary I of two ndarrays',GenericTypes => $T, Bitwise => 1); biop('xor','^',1,'binary I of two ndarrays',GenericTypes => $T, Bitwise => 1); # really an ufunc ufunc('bitnot','~',1,'unary bit negation',GenericTypes => $T); # some standard binary functions bifunc('power',['pow','op**'],1,'raise ndarray C<$a> to the power C<$b>',GenericTypes => [@$C, @$F]); bifunc('atan2','atan2',0,'elementwise C of two ndarrays',GenericTypes => $F); bifunc('modulo',['MOD','op%'],1,'elementwise C operation',unsigned=>1); bifunc('spaceship',['SPACE','op<=>'],0,'elementwise "<=>" operation'); # some standard unary functions ufunc('sqrt','sqrt',1,'elementwise square root', GenericTypes => $A); # Exception => '$a() < 0'); ufunc('sin','sin',1,'the sin function', GenericTypes => $A); ufunc('cos','cos',1,'the cos function', GenericTypes => $A); ufunc('not','!',1,'the elementwise I operation'); ufunc('exp','exp',1,'the exponential function',GenericTypes => [@$C, @$F]); ufunc('log','log',1,'the natural logarithm',GenericTypes => [@$C, @$F], Exception => '$a() <= 0'); # no export these because clash with Test::Deep (re) or internal (_*abs) cfunc('re', 'creal', 1, 'Returns the real part of a complex number.', '$complexv() = $b() + I * cimag($complexv());' ); cfunc('im', 'cimag', 1, 'Returns the imaginary part of a complex number.', '$complexv() = creal($complexv()) + I * $b();' ); cfunc('_cabs', 'cabs', 1, 'Returns the absolute (length) of a complex number.', undef, PMFunc=>'', ); my $rabs_code = ' types('.join('', @$U).') %{ $b()=$a(); %} types('.join('', @$S).') %{ $b()=ABS($a()); %} '; pp_def ( '_rabs', Pars=>'a(); [o]b()', HandleBad => 1, NoBadifNaN => 1, Inplace => 1, Code => pp_line_numbers(__LINE__, qq{ PDL_IF_BAD(if ( \$ISBAD(a()) ) \$SETBAD(b()); else,) $rabs_code }), Doc=>undef, PMFunc=>'', ); pp_export_nothing(); # make log10() work on scalars (returning scalars) # as well as ndarrays ufunc('log10','log10',0,'the base 10 logarithm', GenericTypes => $A, Exception => '$a() <= 0', NoTgmath => 1, # glibc for at least GCC 8.3.0 won't tgmath log10 though 7.1.0 did PMCode => ' sub PDL::log10 { my $x = shift; if ( ! UNIVERSAL::isa($x,"PDL") ) { return log($x) / log(10); } my $y; if ( $x->is_inplace ) { $x->set_inplace(0); $y = $x; } elsif( ref($x) eq "PDL"){ #PDL Objects, use nullcreate: $y = PDL->nullcreate($x); }else{ #PDL-Derived Object, use copy: (Consistent with # Auto-creation docs in Objects.pod) $y = $x->copy; } &PDL::_log10_int( $x, $y ); return $y; }; ' ); pp_def( 'assgn', HandleBad => 1, GenericTypes => $A, Pars => 'a(); [o]b();', Code => pp_line_numbers(__LINE__-1, q{ PDL_IF_BAD(if ( $ISBAD(a()) ) $SETBAD(b()); else,) $b() = $a(); }), Doc => 'Plain numerical assignment. This is used to implement the ".=" operator', BadDoc => 'If C is a child ndarray (e.g., the result of a slice) and bad values are generated in C, the bad value flag is set in C, but it is B automatically propagated back to the parent of C. The following idiom ensures that the badflag is propagated back to the parent of C: $pdl->slice(":,(1)") .= PDL::Bad_aware_func(); $pdl->badflag(1); $pdl->check_badflag(); This is unnecessary if $pdl->badflag is known to be 1 before the slice is performed. See http://pdl.perl.org/PDLdocs/BadValues.html#dataflow_of_the_badflag for details.' ); # pp_def assgn # special functions for complex data types that don't work well with # the ufunc/bifunc logic sub cfunc { my ($name, $func, $make_real, $doc, $backcode, %extra) = @_; my $codestr = pp_line_numbers(__LINE__-1,"\$b() = $func(\$complexv());"); pp_def($name, GenericTypes=>$C, Pars => 'complexv(); '.($make_real ? 'real' : '').' [o]b()', HandleBad => 1, NoBadifNaN => 1, Inplace => 1, Code => pp_line_numbers(__LINE__, qq{ PDL_IF_BAD(if ( \$ISBAD(complexv()) ) \$SETBAD(b()); else,) $codestr }), !$backcode ? () : ( DefaultFlow => 1, TwoWay => 1, BackCode => pp_line_numbers(__LINE__, qq{ PDL_IF_BAD(if ( \$ISBAD(b()) ) \$SETBAD(complexv()); else {,) $backcode PDL_IF_BAD(},) }), ), %extra, Doc => $doc); } cfunc('carg', 'carg', 1, 'Returns the polar angle of a complex number.', undef); cfunc('conj', 'conj', 0, 'complex conjugate.', undef); pp_def('czip', Pars => 'r(); i(); complex [o]c()', Doc => <<'EOF', convert real, imaginary to native complex, (sort of) like LISP zip function. Will add the C ndarray to "i" times the C ndarray. Only takes real ndarrays as input. EOF Code => '$c() = $r() + $i() * I;' ); pp_def('ipow', Doc => qq{ =for ref raise ndarray C<\$a> to integer power C<\$b> =for example \$c = \$x->ipow(\$y,0); # explicit function call \$c = ipow \$x, \$y; \$x->inplace->ipow(\$y,0); # modify \$x inplace It can be made to work inplace with the C<\$x-Einplace> syntax. Note that when calling this function explicitly you need to supply a third argument that should generally be zero (see first example). This restriction is expected to go away in future releases. Algorithm from L =cut }, Pars => 'a(); indx b(); [o] ans()', GenericTypes => $AF, Code => pp_line_numbers(__LINE__, q{ PDL_Indx n = $b(); $GENERIC() y = 1; $GENERIC() x = $a(); if (n < 0) { x = 1 / x; n = -n; } if (n == 0) { $ans() = 1; } else { while (n > 1) { if (n % 2 == 0) { x = x * x; n = n / 2; } else { y = x * y; x = x * x; n = (n - 1) / 2; } } $ans() = x * y; } }) ); pp_addpm(<<'EOPM'); =head2 abs =for ref Returns the absolute value of a number. =cut sub PDL::abs { $_[0]->type->real ? goto &PDL::_rabs : goto &PDL::_cabs } EOPM pp_addpm(make_overload(qw(abs abs), 0, 0, 1)); pp_addpm(<<'EOPM'); =head2 abs2 =for ref Returns the square of the absolute value of a number. =cut sub PDL::abs2 ($) { my $r = &PDL::abs; $r * $r } EOPM pp_def('r2C', GenericTypes=>[qw(G C F D)], # last one is default so here = D Pars => 'r(); complex [o]c()', Doc => 'convert real to native complex, with an imaginary part of zero', PMCode => << 'EOF', sub PDL::r2C ($) { return $_[0] if UNIVERSAL::isa($_[0], 'PDL') and !$_[0]->type->real; my $r = $_[1] // PDL->nullcreate($_[0]); PDL::_r2C_int($_[0], $r); $r; } EOF Code => '$c() = $r();' ); pp_def('i2C', GenericTypes=>[qw(G C F D)], # last one is default so here = D Pars => 'i(); complex [o]c()', Doc => 'convert imaginary to native complex, with a real part of zero', PMCode => << 'EOF', sub PDL::i2C ($) { return $_[0] if UNIVERSAL::isa($_[0], 'PDL') and !$_[0]->type->real; my $r = $_[1] // PDL->nullcreate($_[0]); PDL::_i2C_int($_[0], $r); $r; } EOF Code => '$c() = $i() * I;' ); pp_addpm(<<'EOF'); # This is to used warn if an operand is non-numeric or non-PDL. sub warn_non_numeric_op_wrapper { require Scalar::Util; my ($cb, $op_name) = @_; return sub { my ($op1, $op2) = @_; warn "'$op2' is not numeric nor a PDL in operator $op_name" unless Scalar::Util::looks_like_number($op2) || ( Scalar::Util::blessed($op2) && $op2->isa('PDL') ); $cb->(@_); } } { package PDL; use Carp; use overload %OVERLOADS, "eq" => PDL::Ops::warn_non_numeric_op_wrapper(\&PDL::eq, 'eq'), "=" => sub {$_[0]}, # Don't deep copy, just copy reference ".=" => sub { my @args = !$_[2] ? @_[1,0] : @_[0,1]; PDL::Ops::assgn(@args); return $args[1]; }, 'bool' => sub { return 0 if $_[0]->isnull; confess("multielement ndarray in conditional expression (see PDL::FAQ questions 6-10 and 6-11)") unless $_[0]->nelem == 1; $_[0]->clump(-1)->at(0); }, '++' => sub { $_[0] += 1 }, '--' => sub { $_[0] -= 1 }, ; } EOF pp_done(); PDL-2.074/Basic/Ops/Makefile.PL0000644000175000017500000000043014112170343015620 0ustar osboxesosboxesuse strict; use warnings; use ExtUtils::MakeMaker; my @pack = (["ops.pd",qw(Ops PDL::Ops)]); my %hash = pdlpp_stdargs_int(@pack); $hash{LIBS}->[0] .= ' -lm '; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.074/Basic/Primitive/0000755000175000017500000000000014200406301015052 5ustar osboxesosboxesPDL-2.074/Basic/Primitive/primitive.pd0000644000175000017500000027756114200050621017431 0ustar osboxesosboxesuse strict; use warnings; use PDL::Types qw(ppdefs_all types); my $F = [map $_->ppsym, grep $_->real && !$_->integer, types()]; pp_addpm({At=>'Top'},<<'EOD'); use strict; use warnings; use PDL::Slices; use Carp; { package PDL; use overload ( 'x' => sub { PDL::Primitive::matmult(@_[0,1], my $foo=$_[0]->null()); $foo; }, ); } =head1 NAME PDL::Primitive - primitive operations for pdl =head1 DESCRIPTION This module provides some primitive and useful functions defined using PDL::PP and able to use the new indexing tricks. See L for how to use indices creatively. For explanation of the signature format, see L. =head1 SYNOPSIS # Pulls in PDL::Primitive, among other modules. use PDL; # Only pull in PDL::Primitive: use PDL::Primitive; =cut EOD ################################################################ # a whole bunch of quite basic functions for inner, outer # and matrix products (operations that are not normally # available via operator overloading) ################################################################ pp_def( 'inner', HandleBad => 1, Pars => 'a(n); b(n); [o]c();', GenericTypes => [ppdefs_all], Code => 'double tmp = 0; loop(n) %{ tmp += $a() * $b(); %} $c() = tmp;', BadCode => 'double tmp = 0; int badflag = 0; loop(n) %{ if ( $ISGOOD(a()) && $ISGOOD(b()) ) { tmp += $a() * $b(); } else { badflag = 1; } %} if ( badflag ) { $SETBAD(c()); $PDLSTATESETBAD(c); } else { $c() = tmp; }', CopyBadStatusCode => '', Doc => ' =for ref Inner product over one dimension c = sum_i a_i * b_i =cut ', BadDoc => ' =for bad If C contains only bad data, C is set bad. Otherwise C will have its bad flag cleared, as it will not contain any bad values. =cut ', ); # pp_def( inner ) pp_def( 'outer', HandleBad => 1, Pars => 'a(n); b(m); [o]c(n,m);', GenericTypes => [ppdefs_all], Code => 'loop(n,m) %{ $c() = $a() * $b(); %}', BadCode => 'loop(n,m) %{ if ( $ISBAD(a()) || $ISBAD(b()) ) { $SETBAD(c()); } else { $c() = $a() * $b(); } %}', Doc => ' =for ref outer product over one dimension Naturally, it is possible to achieve the effects of outer product simply by threading over the "C<*>" operator but this function is provided for convenience. '); # pp_def( outer ) pp_addpm(<<'EOD'); =head2 x =for sig Signature: (a(i,z), b(x,i),[o]c(x,z)) =for ref Matrix multiplication PDL overloads the C operator (normally the repeat operator) for matrix multiplication. The number of columns (size of the 0 dimension) in the left-hand argument must normally equal the number of rows (size of the 1 dimension) in the right-hand argument. Row vectors are represented as (N x 1) two-dimensional PDLs, or you may be sloppy and use a one-dimensional PDL. Column vectors are represented as (1 x N) two-dimensional PDLs. Threading occurs in the usual way, but as both the 0 and 1 dimension (if present) are included in the operation, you must be sure that you don't try to thread over either of those dims. Of note, due to how Perl v5.14.0 and above implement operator overloading of the C operator, the use of parentheses for the left operand creates a list context, that is pdl> ( $x * $y ) x $z ERROR: Argument "..." isn't numeric in repeat (x) ... treats C<$z> as a numeric count for the list repeat operation and does not call the scalar form of the overloaded operator. To use the operator in this case, use a scalar context: pdl> scalar( $x * $y ) x $z or by calling L directly: pdl> ( $x * $y )->matmult( $z ) EXAMPLES Here are some simple ways to define vectors and matrices: pdl> $r = pdl(1,2); # A row vector pdl> $c = pdl([[3],[4]]); # A column vector pdl> $c = pdl(3,4)->(*1); # A column vector, using NiceSlice pdl> $m = pdl([[1,2],[3,4]]); # A 2x2 matrix Now that we have a few objects prepared, here is how to matrix-multiply them: pdl> print $r x $m # row x matrix = row [ [ 7 10] ] pdl> print $m x $r # matrix x row = ERROR PDL: Dim mismatch in matmult of [2x2] x [2x1]: 2 != 1 pdl> print $m x $c # matrix x column = column [ [ 5] [11] ] pdl> print $m x 2 # Trivial case: scalar mult. [ [2 4] [6 8] ] pdl> print $r x $c # row x column = scalar [ [11] ] pdl> print $c x $r # column x row = matrix [ [3 6] [4 8] ] INTERNALS The mechanics of the multiplication are carried out by the L method. =cut EOD pp_add_exported('', 'matmult'); pp_def('matmult', HandleBad=>0, Pars => 'a(t,h); b(w,t); [o]c(w,h);', GenericTypes => [ppdefs_all], PMCode => <<'EOPM', sub PDL::matmult { my ($x,$y,$c) = @_; $y = pdl($y) unless eval { $y->isa('PDL') }; $c = PDL->null unless eval { $c->isa('PDL') }; while($x->getndims < 2) {$x = $x->dummy(-1)} while($y->getndims < 2) {$y = $y->dummy(-1)} return ($c .= $x * $y) if( ($x->dim(0)==1 && $x->dim(1)==1) || ($y->dim(0)==1 && $y->dim(1)==1) ); if($y->dim(1) != $x->dim(0)) { barf(sprintf("Dim mismatch in matmult of [%dx%d] x [%dx%d]: %d != %d",$x->dim(0),$x->dim(1),$y->dim(0),$y->dim(1),$x->dim(0),$y->dim(1))); } PDL::_matmult_int($x,$y,$c); $c; } EOPM Code => <<'EOC', PDL_Indx ih, iw, it, ow, oh, ot, wlim, hlim, tlim; $GENERIC() *ad, *bd; PDL_Indx atdi, btdi; PDL_Indx tsiz = 64; // Zero the output loop(w) %{ loop(h) %{ $c() = 0; %} %} // Make sure we're physical // (Not needed if we don't need dimincs, see below) // PDL->make_physdims($PDL(a)); // PDL->make_physdims($PDL(b)); // Cache the dimincs to avoid constant lookups // These two lines are what I wanted, but they break sometimes (dimincs not set right despite calling physdims?) // I deleted them in favor of explicit offset calculation, which appears more robust. // atdi = $PDL(a)->dimincs[0]; // btdi = $PDL(b)->dimincs[1]; atdi = &($a(t=>1, h=>0)) - &($a(t=>0,h=>0)); btdi = &($b(t=>1, w=>0)) - &($b(t=>0,w=>0)); // Loop over tiles for( oh=0; oh < $SIZE(h); oh += tsiz ) { hlim = PDLMIN(oh + tsiz, $SIZE(h)); for( ow=0; ow < $SIZE(w); ow += tsiz ) { wlim = PDLMIN(ow + tsiz, $SIZE(w)); for( ot=0; ot < $SIZE(t); ot += tsiz ) { tlim = PDLMIN(ot + tsiz, $SIZE(t)); for( ih=oh; ihot, h=>ih)); bd = &($b(w=>iw, t=>ot)); // Cache the accumulated value for the output cc = $c(w=>iw, h=>ih); // Hotspot - run the 't' summation for( it=ot; itiw, h=>ih) = cc; } } } } } EOC Doc => <<'EOD' =for ref Matrix multiplication Notionally, matrix multiplication $x x $y is equivalent to the threading expression $x->dummy(1)->inner($y->xchg(0,1)->dummy(2),$c); but for large matrices that breaks CPU cache and is slow. Instead, matmult calculates its result in 32x32x32 tiles, to keep the memory footprint within cache as long as possible on most modern CPUs. For usage, see L, a description of the overloaded 'x' operator EOD ); pp_def( 'innerwt', HandleBad => 1, Pars => 'a(n); b(n); c(n); [o]d();', GenericTypes => [ppdefs_all], Code => 'double tmp = 0; loop(n) %{ tmp += $a() * $b() * $c(); %} $d() = tmp;', BadCode => 'double tmp = 0; int flag = 0; loop(n) %{ if ( $ISGOOD(a()) && $ISGOOD(b()) && $ISGOOD(c()) ) { tmp += $a() * $b() * $c(); flag = 1; } %} if ( flag ) { $d() = tmp; } else { $SETBAD(d()); }', Doc => ' =for ref Weighted (i.e. triple) inner product d = sum_i a(i) b(i) c(i) =cut ' ); pp_def( 'inner2', HandleBad => 1, Pars => 'a(n); b(n,m); c(m); [o]d();', GenericTypes => [ppdefs_all], Code => 'double tmp=0; loop(n,m) %{ tmp += $a() * $b() * $c(); %} $d() = tmp;', BadCode => 'double tmp = 0; int flag = 0; loop(n,m) %{ if ( $ISGOOD(a()) && $ISGOOD(b()) && $ISGOOD(c()) ) { tmp += $a() * $b() * $c(); flag = 1; } %} if ( flag ) { $d() = tmp; } else { $SETBAD(d()); }', Doc => ' =for ref Inner product of two vectors and a matrix d = sum_ij a(i) b(i,j) c(j) Note that you should probably not thread over C and C since that would be very wasteful. Instead, you should use a temporary for C. ' ); pp_def( 'inner2d', HandleBad => 1, Pars => 'a(n,m); b(n,m); [o]c();', GenericTypes => [ppdefs_all], Code => 'double tmp=0; loop(n,m) %{ tmp += $a() * $b(); %} $c() = tmp;', BadCode => 'double tmp = 0; int flag = 0; loop(n,m) %{ if ( $ISGOOD(a()) && $ISGOOD(b()) ) { tmp += $a() * $b(); flag = 1; } %} if ( flag ) { $c() = tmp; } else { $SETBAD(c()); }', Doc => ' =for ref Inner product over 2 dimensions. Equivalent to $c = inner($x->clump(2), $y->clump(2)) =cut ' ); pp_def( 'inner2t', HandleBad => 1, Pars => 'a(j,n); b(n,m); c(m,k); [t]tmp(n,k); [o]d(j,k));', GenericTypes => [ppdefs_all], Code => 'loop(n,k) %{ double tmp0 = 0; loop(m) %{ tmp0 += $b() * $c(); %} $tmp() = tmp0; %} loop(j,k) %{ double tmp1 = 0; loop(n) %{ tmp1 += $a() * $tmp(); %} $d() = tmp1; %}', BadCode => 'loop(n,k) %{ double tmp0 = 0; int flag = 0; loop(m) %{ if ( $ISGOOD(b()) && $ISGOOD(c()) ) { tmp0 += $b() * $c(); flag = 1; } %} if ( flag ) { $tmp() = tmp0; } else { $SETBAD(tmp()); } %} loop(j,k) %{ double tmp1 = 0; int flag = 0; loop(n) %{ if ( $ISGOOD(a()) && $ISGOOD(tmp()) ) { tmp1 += $a() * $tmp(); flag = 1; } %} if ( flag ) { $d() = tmp1; } else { $SETBAD(d()); } %}', Doc => ' =for ref Efficient Triple matrix product C Efficiency comes from by using the temporary C. This operation only scales as C whereas threading using L would scale as C. The reason for having this routine is that you do not need to have the same thread-dimensions for C as for the other arguments, which in case of large numbers of matrices makes this much more memory-efficient. It is hoped that things like this could be taken care of as a kind of closures at some point. =cut ' ); # pp_def inner2t() # a helper function for the cross product definition sub crassgn { "\$c(tri => $_[0]) = \$a(tri => $_[1])*\$b(tri => $_[2]) - \$a(tri => $_[2])*\$b(tri => $_[1]);" } pp_def('crossp', Doc => <<'EOD', =for ref Cross product of two 3D vectors After =for example $c = crossp $x, $y the inner product C<$c*$x> and C<$c*$y> will be zero, i.e. C<$c> is orthogonal to C<$x> and C<$y> =cut EOD Pars => 'a(tri=3); b(tri); [o] c(tri)', GenericTypes => [ppdefs_all], Code => crassgn(0,1,2)."\n". crassgn(1,2,0)."\n". crassgn(2,0,1), ); pp_def('norm', HandleBad => 1, Pars => 'vec(n); [o] norm(n)', GenericTypes => [ppdefs_all], Doc => 'Normalises a vector to unit Euclidean length', Code => 'long double sum=0; int flag = 0; loop(n) %{ PDL_IF_BAD(if ( $ISGOOD(vec()) ) {,) sum += PDL_IF_GENTYPE_REAL( $vec()*$vec(), creall($vec())*creall($vec()) + cimagl($vec())*cimagl($vec()) ); PDL_IF_BAD(flag = 1; },) %} PDL_IF_BAD(if ( flag ) {,) if (sum > 0) { sum = sqrt(sum); loop(n) %{ PDL_IF_BAD(if ( $ISBAD(vec()) ) { $SETBAD(norm()); } else {,) $norm() = $vec()/sum; PDL_IF_BAD(},) %} } else { loop(n) %{ if ( $ISBAD(vec()) ) { $SETBAD(norm()); } else { $norm() = $vec(); } %} } PDL_IF_BAD(} else { loop(n) %{ $SETBAD(norm()); %} },) ', ); # this one was motivated by the need to compute # the circular mean efficiently # without it could not be done efficiently or without # creating large intermediates (check pdl-porters for # discussion) # see PDL::ImageND for info about the circ_mean function pp_def( 'indadd', HandleBad => 1, Pars => 'a(n); indx ind(n); [o] sum(m)', GenericTypes => [ppdefs_all], Code => 'loop(n) %{ register PDL_Indx foo = $ind(); if ( foo<0 || foo>=$SIZE(m) ) { $CROAK("PDL::indadd: invalid index"); } $sum(m => foo) += $a(); %}', BadCode => 'loop(n) %{ register PDL_Indx foo = $ind(); if( $ISBADVAR(foo,ind) || foo<0 || foo>=$SIZE(m) ) { $CROAK("PDL::indadd: invalid index"); } if ( $ISBAD(a()) ) { $SETBAD(sum(m => foo)); } else { $sum(m => foo) += $a(); } %}', BadDoc => ' =for bad The routine barfs if any of the indices are bad. =cut ', Doc=>' =for ref Threaded Index Add: Add C to the C element of C, i.e: sum(ind) += a =for example Simple Example: $x = 2; $ind = 3; $sum = zeroes(10); indadd($x,$ind, $sum); print $sum #Result: ( 2 added to element 3 of $sum) # [0 0 0 2 0 0 0 0 0 0] Threaded Example: $x = pdl( 1,2,3); $ind = pdl( 1,4,6); $sum = zeroes(10); indadd($x,$ind, $sum); print $sum."\n"; #Result: ( 1, 2, and 3 added to elements 1,4,6 $sum) # [0 1 0 0 2 0 3 0 0 0] =cut '); # 1D convolution # useful for threaded 1D filters pp_addhdr(' /* Fast Modulus with proper negative behaviour */ #define REALMOD(a,b) while ((a)>=(b)) (a) -= (b); while ((a)<0) (a) += (b); '); pp_def('conv1d', Doc => << 'EOD', =for ref 1D convolution along first dimension The m-th element of the discrete convolution of an input ndarray C<$a> of size C<$M>, and a kernel ndarray C<$kern> of size C<$P>, is calculated as n = ($P-1)/2 ==== \ ($a conv1d $kern)[m] = > $a_ext[m - n] * $kern[n] / ==== n = -($P-1)/2 where C<$a_ext> is either the periodic (or reflected) extension of C<$a> so it is equal to C<$a> on C< 0..$M-1 > and equal to the corresponding periodic/reflected image of C<$a> outside that range. =for example $con = conv1d sequence(10), pdl(-1,0,1); $con = conv1d sequence(10), pdl(-1,0,1), {Boundary => 'reflect'}; By default, periodic boundary conditions are assumed (i.e. wrap around). Alternatively, you can request reflective boundary conditions using the C option: {Boundary => 'reflect'} # case in 'reflect' doesn't matter The convolution is performed along the first dimension. To apply it across another dimension use the slicing routines, e.g. $y = $x->mv(2,0)->conv1d($kernel)->mv(0,2); # along third dim This function is useful for threaded filtering of 1D signals. Compare also L, L, L, L, L =for bad WARNING: C processes bad values in its inputs as the numeric value of C<< $pdl->badvalue >> so it is not recommended for processing pdls with bad values in them unless special care is taken. =cut EOD Pars => 'a(m); kern(p); [o]b(m);', GenericTypes => [ppdefs_all], OtherPars => 'int reflect;', HandleBad => 0, PMCode => ' sub PDL::conv1d { my $opt = pop @_ if ref($_[$#_]) eq \'HASH\'; die \'Usage: conv1d( a(m), kern(p), [o]b(m), {Options} )\' if $#_<1 || $#_>2; my($x,$kern) = @_; my $c = $#_ == 2 ? $_[2] : PDL->null; PDL::_conv1d_int($x,$kern,$c, !(defined $opt && exists $$opt{Boundary}) ? 0 : lc $$opt{Boundary} eq "reflect"); return $c; } ', Code => ' int i,i1,i2,poff,pflip; double tmp; int reflect = $COMP(reflect); int m_size = $SIZE(m); int p_size = $SIZE(p); poff = (p_size-1)/2; for(i=0; i=m_size) i2 = m_size-(i2-m_size+1); REALMOD(i2,m_size); tmp += $a(m=>i2) * $kern(p=>pflip); } $b(m=>i) = tmp; } '); # this can be achieved by # ($x->dummy(0) == $y)->orover # but this one avoids a larger intermediate and potentially shortcuts pp_def('in', Pars => 'a(); b(n); [o] c()', GenericTypes => [ppdefs_all], Code => '$c() = 0; loop(n) %{ if ($a() == $b()) {$c() = 1; break;} %}', Doc => <<'EOD', =for ref test if a is in the set of values b =for example $goodmsk = $labels->in($goodlabels); print pdl(3,1,4,6,2)->in(pdl(2,3,3)); [1 0 0 0 1] C is akin to the I of set theory. In principle, PDL threading could be used to achieve its functionality by using a construct like $msk = ($labels->dummy(0) == $goodlabels)->orover; However, C doesn't create a (potentially large) intermediate and is generally faster. =cut EOD ); pp_add_exported ('', 'uniq'); pp_addpm (<< 'EOPM'); =head2 uniq =for ref return all unique elements of an ndarray The unique elements are returned in ascending order. =for example PDL> p pdl(2,2,2,4,0,-1,6,6)->uniq [-1 0 2 4 6] # 0 is returned 2nd (sorted order) PDL> p pdl(2,2,2,4,nan,-1,6,6)->uniq [-1 2 4 6 nan] # NaN value is returned at end Note: The returned pdl is 1D; any structure of the input ndarray is lost. C values are never compare equal to any other values, even themselves. As a result, they are always unique. C returns the NaN values at the end of the result ndarray. This follows the Matlab usage. See L if you need the indices of the unique elements rather than the values. =for bad Bad values are not considered unique by uniq and are ignored. $x=sequence(10); $x=$x->setbadif($x%3); print $x->uniq; [0 3 6 9] =cut *uniq = \&PDL::uniq; # return unique elements of array # find as jumps in the sorted array # flattens in the process sub PDL::uniq { use PDL::Core 'barf'; my ($arr) = @_; return $arr if($arr->nelem == 0); # The null list is unique (CED) my $srt = $arr->clump(-1)->where($arr==$arr)->qsort; # no NaNs or BADs for qsort my $nans = $arr->clump(-1)->where($arr!=$arr); my $uniq = ($srt->nelem > 0) ? $srt->where($srt != $srt->rotate(-1)) : $srt; # make sure we return something if there is only one value my $answ = $nans; # NaN values always uniq if ( $uniq->nelem > 0 ) { $answ = $uniq->append($answ); } else { $answ = ( ($srt->nelem == 0) ? $srt : PDL::pdl( ref($srt), [$srt->index(0)] ) )->append($answ); } return $answ; } EOPM pp_add_exported ('', 'uniqind'); pp_addpm (<< 'EOPM'); =head2 uniqind =for ref Return the indices of all unique elements of an ndarray The order is in the order of the values to be consistent with uniq. C values never compare equal with any other value and so are always unique. This follows the Matlab usage. =for example PDL> p pdl(2,2,2,4,0,-1,6,6)->uniqind [5 4 1 3 6] # the 0 at index 4 is returned 2nd, but... PDL> p pdl(2,2,2,4,nan,-1,6,6)->uniqind [5 1 3 6 4] # ...the NaN at index 4 is returned at end Note: The returned pdl is 1D; any structure of the input ndarray is lost. See L if you want the unique values instead of the indices. =for bad Bad values are not considered unique by uniqind and are ignored. =cut *uniqind = \&PDL::uniqind; # return unique elements of array # find as jumps in the sorted array # flattens in the process sub PDL::uniqind { use PDL::Core 'barf'; my ($arr) = @_; return $arr if($arr->nelem == 0); # The null list is unique (CED) # Different from uniq we sort and store the result in an intermediary my $aflat = $arr->flat; my $nanind = which($aflat!=$aflat); # NaN indexes my $good = PDL->sequence(indx, $aflat->dims)->where($aflat==$aflat); # good indexes my $i_srt = $aflat->where($aflat==$aflat)->qsorti; # no BAD or NaN values for qsorti my $srt = $aflat->where($aflat==$aflat)->index($i_srt); my $uniqind; if ($srt->nelem > 0) { $uniqind = which($srt != $srt->rotate(-1)); $uniqind = $i_srt->slice('0') if $uniqind->isempty; } else { $uniqind = which($srt); } # Now map back to the original space my $ansind = $nanind; if ( $uniqind->nelem > 0 ) { $ansind = ($good->index($i_srt->index($uniqind)))->append($ansind); } else { $ansind = $uniqind->append($ansind); } return $ansind; } EOPM pp_add_exported ('', 'uniqvec'); pp_addpm (<< 'EOPM'); =head2 uniqvec =for ref Return all unique vectors out of a collection NOTE: If any vectors in the input ndarray have NaN values they are returned at the end of the non-NaN ones. This is because, by definition, NaN values never compare equal with any other value. NOTE: The current implementation does not sort the vectors containing NaN values. The unique vectors are returned in lexicographically sorted ascending order. The 0th dimension of the input PDL is treated as a dimensional index within each vector, and the 1st and any higher dimensions are taken to run across vectors. The return value is always 2D; any structure of the input PDL (beyond using the 0th dimension for vector index) is lost. See also L for a unique list of scalars; and L for sorting a list of vectors lexicographcally. =for bad If a vector contains all bad values, it is ignored as in L. If some of the values are good, it is treated as a normal vector. For example, [1 2 BAD] and [BAD 2 3] could be returned, but [BAD BAD BAD] could not. Vectors containing BAD values will be returned after any non-NaN and non-BAD containing vectors, followed by the NaN vectors. =cut sub PDL::uniqvec { my($pdl) = shift; return $pdl if ( $pdl->nelem == 0 || $pdl->ndims < 2 ); return $pdl if ( $pdl->slice("(0)")->nelem < 2 ); # slice isn't cheap but uniqvec isn't either my $pdl2d = $pdl->clump(1..$pdl->ndims-1); my $ngood = $pdl2d->ngoodover; $pdl2d = $pdl2d->mv(0,-1)->dice($ngood->which)->mv(-1,0); # remove all-BAD vectors my $numnan = ($pdl2d!=$pdl2d)->sumover; # works since no all-BADs to confuse my $presrt = $pdl2d->mv(0,-1)->dice($numnan->not->which)->mv(0,-1); # remove vectors with any NaN values my $nanvec = $pdl2d->mv(0,-1)->dice($numnan->which)->mv(0,-1); # the vectors with any NaN values # use dice instead of slice since qsortvec might be packing # the badvals to the front of the array instead of the end like # the docs say. If that is the case and it gets fixed, it won't # bust uniqvec. DAL 14-March 2006 my $srt = $presrt->qsortvec->mv(0,-1); # BADs are sorted by qsortvec my $srtdice = $srt; my $somebad = null; if ($srt->badflag) { $srtdice = $srt->dice($srt->mv(0,-1)->nbadover->not->which); $somebad = $srt->dice($srt->mv(0,-1)->nbadover->which); } my $uniq = $srtdice->nelem > 0 ? ($srtdice != $srtdice->rotate(-1))->mv(0,-1)->orover->which : $srtdice->orover->which; my $ans = $uniq->nelem > 0 ? $srtdice->dice($uniq) : ($srtdice->nelem > 0) ? $srtdice->slice("0,:") : $srtdice; return $ans->append($somebad)->append($nanvec->mv(0,-1))->mv(0,-1); } EOPM ##################################################################### # clipping routines ##################################################################### # clipping for my $opt ( ['hclip','PDLMIN'], ['lclip','PDLMAX'] ) { my $name = $opt->[0]; my $op = $opt->[1]; my $code = '$c() = '.$op.'($b(), $a());'; pp_def( $name, HandleBad => 1, Pars => 'a(); b(); [o] c()', Code => $code, BadCode => 'if ( $ISBAD(a()) || $ISBAD(b()) ) { $SETBAD(c()); } else { '.$code.' }', Doc => 'clip (threshold) C<$a> by C<$b> (C<$b> is '. ($name eq 'hclip' ? 'upper' : 'lower').' bound)', PMCode=><<"EOD", sub PDL::$name { my (\$x,\$y) = \@_; my \$c; if (\$x->is_inplace) { \$x->set_inplace(0); \$c = \$x; } elsif (\$#_ > 1) {\$c=\$_[2]} else {\$c=PDL->nullcreate(\$x)} PDL::_${name}_int(\$x,\$y,\$c); return \$c; } EOD ); # pp_def $name } # for: my $opt pp_add_exported('', 'clip'); pp_addpm(<<'EOD'); =head2 clip =for ref Clip (threshold) an ndarray by (optional) upper or lower bounds. =for usage $y = $x->clip(0,3); $c = $x->clip(undef, $x); =for bad clip handles bad values since it is just a wrapper around L and L. =cut EOD pp_def( 'clip', HandleBad => 1, Pars => 'a(); l(); h(); [o] c()', Code => '$c() = PDLMIN($h(), PDLMAX($l(), $a()));', BadCode => <<'EOBC', if( $ISBAD(a()) || $ISBAD(l()) || $ISBAD(h()) ) { $SETBAD(c()); } else { $c() = PDLMIN($h(), PDLMAX($l(), $a())); } EOBC PMCode => <<'EOPM', *clip = \&PDL::clip; sub PDL::clip { my($x, $l, $h) = @_; my $d; unless(defined($l) || defined($h)) { # Deal with pathological case if($x->is_inplace) { $x->set_inplace(0); return $x; } else { return $x->copy; } } if($x->is_inplace) { $x->set_inplace(0); $d = $x } elsif ($#_ > 2) { $d=$_[3] } else { $d = PDL->nullcreate($x); } if(defined($l) && defined($h)) { PDL::_clip_int($x,$l,$h,$d); } elsif( defined($l) ) { PDL::_lclip_int($x,$l,$d); } elsif( defined($h) ) { PDL::_hclip_int($x,$h,$d); } else { die "This can't happen (clip contingency) - file a bug"; } return $d; } EOPM ); # end of clip pp_def call ############################################################ # elementary statistics and histograms ############################################################ pp_def( 'wtstat', HandleBad => 1, Pars => 'a(n); wt(n); avg(); [o]b();', GenericTypes => [ppdefs_all], OtherPars => 'int deg', Code => 'double wtsum = 0; double statsum = 0; loop(n) %{ register double tmp; register int i; wtsum += $wt(); tmp=1; for(i=0; i<$COMP(deg); i++) tmp *= $a(); statsum += $wt() * (tmp - $avg()); %} $b() = statsum / wtsum;', BadCode => 'double wtsum = 0; double statsum = 0; int flag = 0; loop(n) %{ if ( $ISGOOD(wt()) && $ISGOOD(a()) && $ISGOOD(avg()) ) { register double tmp; register int i; wtsum += $wt(); tmp=1; for(i=0; i<$COMP(deg); i++) tmp *= $a(); statsum += $wt() * (tmp - $avg()); flag = 1; } %} if ( flag ) { $b() = statsum / wtsum; } else { $SETBAD(b()); $PDLSTATESETBAD(b); }', CopyBadStatusCode => '', Doc => ' =for ref Weighted statistical moment of given degree This calculates a weighted statistic over the vector C. The formula is b() = (sum_i wt_i * (a_i ** degree - avg)) / (sum_i wt_i) ', BadDoc => ' =for bad Bad values are ignored in any calculation; C<$b> will only have its bad flag set if the output contains any bad data. ', ); pp_def('statsover', HandleBad => 1, Pars => 'a(n); w(n); float+ [o]avg(); float+ [o]prms(); int+ [o]median(); int+ [o]min(); int+ [o]max(); float+ [o]adev(); float+ [o]rms()', Code => '$GENERIC(avg) tmp = 0; $GENERIC(avg) tmp1 = 0; $GENERIC(avg) diff = 0; $GENERIC(min) curmin = 0, curmax = 0; $GENERIC(avg) norm = 0; loop(n) %{ /* Accumulate sum and summed weight. */ tmp += $a()*$w(); norm += ($GENERIC(avg)) $w(); if (!n) { curmin = $a(); curmax = $a();} if ($a() < curmin) { curmin = $a(); } else if ($a() > curmax) { curmax = $a(); } %} $avg() = tmp / norm; /* Find mean */ $min() = curmin; $max() = curmax; /* Calculate the RMS and standard deviation. */ tmp = 0; loop(n) %{ diff = ($a() - $avg()); tmp += diff * diff * $w(); tmp1 += fabs(diff) * $w(); %} $rms() = sqrt ( tmp/norm ); $prms() = (norm>1) ? sqrt( tmp/(norm-1) ) : 0; $adev() = tmp1/norm ; ', BadCode => '$GENERIC(avg) tmp = 0; $GENERIC(avg) tmp1 = 0; $GENERIC(avg) diff = 0; $GENERIC(min) curmin = 0, curmax = 0; $GENERIC(w) norm = 0; int flag = 0; loop(n) %{ /* perhaps should check w() for bad values too ? */ if ( $ISGOOD(a()) ) { tmp += $a()*$w(); norm += $w(); if (!flag) { curmin = $a(); curmax = $a(); flag=1; } if ($a() < curmin) { curmin = $a(); } else if ($a() > curmax) { curmax = $a(); } } %} /* have at least one valid point if flag == 1 */ if ( flag ) { $avg() = tmp / norm; /* Find mean */ $min() = curmin; $max() = curmax; /* Calculate the RMS and standard deviation. */ tmp = 0; loop(n) %{ if ($ISGOOD(a())) { diff = $a()-$avg(); tmp += diff * diff * $w(); tmp1 += fabs(diff) * $w(); } %} $rms() = sqrt( tmp/norm ); if(norm>1) $prms() = sqrt( tmp/(norm-1) ); else $SETBAD(prms()); $adev() = tmp1 / norm ; } else { $SETBAD(avg()); $PDLSTATESETBAD(avg); $SETBAD(rms()); $PDLSTATESETBAD(rms); $SETBAD(adev()); $PDLSTATESETBAD(adev); $SETBAD(min()); $PDLSTATESETBAD(min); $SETBAD(max()); $PDLSTATESETBAD(max); $SETBAD(prms()); $PDLSTATESETBAD(prms); }', CopyBadStatusCode => '', PMCode => ' sub PDL::statsover { barf(\'Usage: ($mean,[$prms, $median, $min, $max, $adev, $rms]) = statsover($data,[$weights])\') if $#_>1; my ($data, $weights) = @_; $weights = $data->ones() if !defined($weights); my $median = $data->medover(); my $mean = PDL->nullcreate($data); my $rms = PDL->nullcreate($data); my $min = PDL->nullcreate($data); my $max = PDL->nullcreate($data); my $adev = PDL->nullcreate($data); my $prms = PDL->nullcreate($data); PDL::_statsover_int($data, $weights, $mean, $prms, $median, $min, $max, $adev, $rms); return $mean unless wantarray; return ($mean, $prms, $median, $min, $max, $adev, $rms); } ', Doc => ' =for ref Calculate useful statistics over a dimension of an ndarray =for usage ($mean,$prms,$median,$min,$max,$adev,$rms) = statsover($ndarray, $weights); This utility function calculates various useful quantities of an ndarray. These are: =over 3 =item * the mean: MEAN = sum (x)/ N with C being the number of elements in x =item * the population RMS deviation from the mean: PRMS = sqrt( sum( (x-mean(x))^2 )/(N-1) The population deviation is the best-estimate of the deviation of the population from which a sample is drawn. =item * the median The median is the 50th percentile data value. Median is found by L, so WEIGHTING IS IGNORED FOR THE MEDIAN CALCULATION. =item * the minimum =item * the maximum =item * the average absolute deviation: AADEV = sum( abs(x-mean(x)) )/N =item * RMS deviation from the mean: RMS = sqrt(sum( (x-mean(x))^2 )/N) (also known as the root-mean-square deviation, or the square root of the variance) =back This operator is a projection operator so the calculation will take place over the final dimension. Thus if the input is N-dimensional each returned value will be N-1 dimensional, to calculate the statistics for the entire ndarray either use C directly on the ndarray or call C. =cut ', BadDoc =>' =for bad Bad values are simply ignored in the calculation, effectively reducing the sample size. If all data are bad then the output data are marked bad. =cut ', ); pp_add_exported('','stats'); pp_addpm(<<'EOD'); =head2 stats =for ref Calculates useful statistics on an ndarray =for usage ($mean,$prms,$median,$min,$max,$adev,$rms) = stats($ndarray,[$weights]); This utility calculates all the most useful quantities in one call. It works the same way as L, except that the quantities are calculated considering the entire input PDL as a single sample, rather than as a collection of rows. See L for definitions of the returned quantities. =for bad Bad values are handled; if all input values are bad, then all of the output values are flagged bad. =cut *stats = \&PDL::stats; sub PDL::stats { barf('Usage: ($mean,[$rms]) = stats($data,[$weights])') if $#_>1; my ($data,$weights) = @_; # Ensure that $weights is properly threaded over; this could be # done rather more efficiently... if(defined $weights) { $weights = pdl($weights) unless UNIVERSAL::isa($weights,'PDL'); if( ($weights->ndims != $data->ndims) or (pdl($weights->dims) != pdl($data->dims))->or ) { $weights = $weights + zeroes($data) } $weights = $weights->flat; } return PDL::statsover($data->flat,$weights); } EOD my $histogram_doc = <<'EOD'; =for ref Calculates a histogram for given stepsize and minimum. =for usage $h = histogram($data, $step, $min, $numbins); $hist = zeroes $numbins; # Put histogram in existing ndarray. histogram($data, $hist, $step, $min, $numbins); The histogram will contain C<$numbins> bins starting from C<$min>, each C<$step> wide. The value in each bin is the number of values in C<$data> that lie within the bin limits. Data below the lower limit is put in the first bin, and data above the upper limit is put in the last bin. The output is reset in a different threadloop so that you can take a histogram of C<$a(10,12)> into C<$b(15)> and get the result you want. For a higher-level interface, see L. =for example pdl> p histogram(pdl(1,1,2),1,0,3) [0 2 1] =cut EOD my $whistogram_doc = <<'EOD'; =for ref Calculates a histogram from weighted data for given stepsize and minimum. =for usage $h = whistogram($data, $weights, $step, $min, $numbins); $hist = zeroes $numbins; # Put histogram in existing ndarray. whistogram($data, $weights, $hist, $step, $min, $numbins); The histogram will contain C<$numbins> bins starting from C<$min>, each C<$step> wide. The value in each bin is the sum of the values in C<$weights> that correspond to values in C<$data> that lie within the bin limits. Data below the lower limit is put in the first bin, and data above the upper limit is put in the last bin. The output is reset in a different threadloop so that you can take a histogram of C<$a(10,12)> into C<$b(15)> and get the result you want. =for example pdl> p whistogram(pdl(1,1,2), pdl(0.1,0.1,0.5), 1, 0, 4) [0 0.2 0.5 0] =cut EOD for( {Name => 'histogram', WeightPar => '', HistType => 'int+', HistOp => '++', Doc => $histogram_doc, }, {Name => 'whistogram', WeightPar => 'float+ wt(n);', HistType => 'float+', HistOp => '+= $wt()', Doc => $whistogram_doc, } ) { my $p1 = 'register int j; register int maxj = $SIZE(m)-1; register double min = $COMP(min); register double step = $COMP(step); threadloop %{ loop(m) %{ $hist() = 0; %} %} threadloop %{ loop(n) %{'; my $p2 = ' j = (int) (($in()-min)/step); if (j<0) j=0; if (j > maxj) j = maxj; ($hist(m => j))'.$_->{HistOp}.';'; my $p3 = ' %} %}'; pp_def($_->{Name}, Pars => 'in(n); '.$_->{WeightPar}.$_->{HistType}. '[o] hist(m)', GenericTypes => [ppdefs_all], # set outdim by Par! OtherPars => 'double step; double min; int msize => m', HandleBad => 1, Code => $p1.$p2.$p3, BadCode => $p1.'if ( $ISGOOD(in()) ) {'.$p2.'}'.$p3, Doc=>$_->{Doc}); } my $histogram2d_doc = <<'EOD'; =for ref Calculates a 2d histogram. =for usage $h = histogram2d($datax, $datay, $stepx, $minx, $nbinx, $stepy, $miny, $nbiny); $hist = zeroes $nbinx, $nbiny; # Put histogram in existing ndarray. histogram2d($datax, $datay, $hist, $stepx, $minx, $nbinx, $stepy, $miny, $nbiny); The histogram will contain C<$nbinx> x C<$nbiny> bins, with the lower limits of the first one at C<($minx, $miny)>, and with bin size C<($stepx, $stepy)>. The value in each bin is the number of values in C<$datax> and C<$datay> that lie within the bin limits. Data below the lower limit is put in the first bin, and data above the upper limit is put in the last bin. =for example pdl> p histogram2d(pdl(1,1,1,2,2),pdl(2,1,1,1,1),1,0,3,1,0,3) [ [0 0 0] [0 2 2] [0 1 0] ] =cut EOD my $whistogram2d_doc = <<'EOD'; =for ref Calculates a 2d histogram from weighted data. =for usage $h = whistogram2d($datax, $datay, $weights, $stepx, $minx, $nbinx, $stepy, $miny, $nbiny); $hist = zeroes $nbinx, $nbiny; # Put histogram in existing ndarray. whistogram2d($datax, $datay, $weights, $hist, $stepx, $minx, $nbinx, $stepy, $miny, $nbiny); The histogram will contain C<$nbinx> x C<$nbiny> bins, with the lower limits of the first one at C<($minx, $miny)>, and with bin size C<($stepx, $stepy)>. The value in each bin is the sum of the values in C<$weights> that correspond to values in C<$datax> and C<$datay> that lie within the bin limits. Data below the lower limit is put in the first bin, and data above the upper limit is put in the last bin. =for example pdl> p whistogram2d(pdl(1,1,1,2,2),pdl(2,1,1,1,1),pdl(0.1,0.2,0.3,0.4,0.5),1,0,3,1,0,3) [ [ 0 0 0] [ 0 0.5 0.9] [ 0 0.1 0] ] =cut EOD for( {Name => 'histogram2d', WeightPar => '', HistType => 'int+', HistOp => '++', Doc => $histogram2d_doc, }, {Name => 'whistogram2d', WeightPar => 'float+ wt(n);', HistType => 'float+', HistOp => '+= $wt()', Doc => $whistogram2d_doc, } ) { my $p1 = 'register int ja,jb; register int maxja = $SIZE(ma)-1; register int maxjb = $SIZE(mb)-1; register double mina = $COMP(mina); register double minb = $COMP(minb); register double stepa = $COMP(stepa); register double stepb = $COMP(stepb); threadloop %{ loop(ma,mb) %{ $hist() = 0; %} %} threadloop %{ loop(n) %{'; my $p2 = ' ja = (int) (($ina()-mina)/stepa); jb = (int) (($inb()-minb)/stepb); if (ja<0) ja=0; if (ja > maxja) ja = maxja; if (jb<0) jb=0; if (jb > maxjb) jb = maxjb; ($hist(ma => ja,mb => jb))'.$_->{HistOp}.';'; my $p3 = ' %} %}'; pp_def($_->{Name}, Pars => 'ina(n); inb(n); '.$_->{WeightPar}.$_->{HistType}. '[o] hist(ma,mb)', GenericTypes => [ppdefs_all], # set outdim by Par! OtherPars => 'double stepa; double mina; int masize => ma; double stepb; double minb; int mbsize => mb;', HandleBad => 1, Code => $p1.$p2.$p3, BadCode => $p1.'if ( $ISGOOD(ina()) && $ISGOOD(inb()) ) {'.$p2.'}'.$p3, Doc=> $_->{Doc}); } ########################################################### # a number of constructors: fibonacci, append, axisvalues & # random numbers ########################################################### pp_def('fibonacci', Pars => 'i(n); indx [o]x(n)', Inplace => 1, GenericTypes => [ppdefs_all], Doc=>'Constructor - a vector with Fibonacci\'s sequence', PMFunc=>'', PMCode=><<'EOD', sub fibonacci { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->fibonacci : PDL->fibonacci(@_) } sub PDL::fibonacci{ my $x = &PDL::Core::_construct; my $is_inplace = $x->is_inplace; my ($in, $out) = $x->clump(-1); $out = $is_inplace ? $in->inplace : PDL->null; PDL::_fibonacci_int($in, $out); $out; } EOD Code => ' PDL_Indx i=0; $GENERIC() x1, x2; x1 = 1; x2 = 0; loop(n) %{ $x() = x1 + x2; if (i++>0) { x2 = x1; x1 = $x(); } %} '); pp_def('append', Pars => 'a(n); b(m); [o] c(mn)', GenericTypes => [ppdefs_all], # note that ideally we want to say '$SIZE(mn) = $SIZE(m)+$SIZE(n);' # but that requires placing RedoDimsParsedCode *after* assignment of # childdims to $SIZE(XXX)!!! XXXXXmake that workXXXXX PMCode => pp_line_numbers(__LINE__-1, ' sub PDL::append { my ($i1, $i2, $o) = map PDL->topdl($_), @_; if (grep $_->isempty, $i1, $i2) { if (!defined $o) { return $i2->copy if $i1->isempty; return $i1->isnull ? PDL->zeroes(0) : $i1->copy; } else { $o .= $i2->isnull ? PDL->zeroes(0) : $i2, return $o if $i1->isempty; $o .= $i1->isnull ? PDL->zeroes(0) : $i1, return $o; } } $o //= PDL->null; PDL::_append_int($i1, $i2, $o); $o; } '), RedoDimsCode => ' pdl * dpdla = $PDL(a); pdl * dpdlb = $PDL(b); $SIZE(mn) = (dpdla->ndims > 0 ? dpdla->dims[0] : 1) + (dpdlb->ndims > 0 ? dpdlb->dims[0] : 1); ', Code => 'register PDL_Indx mnp; PDL_Indx ns = $SIZE(n); threadloop %{ loop(n) %{ $c(mn => n) = $a(); %} loop(m) %{ mnp = m+ns; $c(mn => mnp) = $b(); %} %}', Doc => ' =for ref append two ndarrays by concatenating along their first dimensions =for example $x = ones(2,4,7); $y = sequence 5; $c = $x->append($y); # size of $c is now (7,4,7) (a jumbo-ndarray ;) C appends two ndarrays along their first dimensions. The rest of the dimensions must be compatible in the threading sense. The resulting size of the first dimension is the sum of the sizes of the first dimensions of the two argument ndarrays - i.e. C. Similar functions include L (below), which can append more than two ndarrays along an arbitrary dimension, and L, which can append more than two ndarrays that all have the same sized dimensions. ' ); pp_addpm(<<'EOD'); =head2 glue =for usage $c = $x->glue(,$y,...) =for ref Glue two or more PDLs together along an arbitrary dimension (N-D L). Sticks $x, $y, and all following arguments together along the specified dimension. All other dimensions must be compatible in the threading sense. Glue is permissive, in the sense that every PDL is treated as having an infinite number of trivial dimensions of order 1 -- so C<< $x->glue(3,$y) >> works, even if $x and $y are only one dimensional. If one of the PDLs has no elements, it is ignored. Likewise, if one of them is actually the undefined value, it is treated as if it had no elements. If the first parameter is a defined perl scalar rather than a pdl, then it is taken as a dimension along which to glue everything else, so you can say C<$cube = PDL::glue(3,@image_list);> if you like. C is implemented in pdl, using a combination of L and L. It should probably be updated (one day) to a pure PP function. Similar functions include L (above), which appends only two ndarrays along their first dimension, and L, which can append more than two ndarrays that all have the same sized dimensions. =cut sub PDL::glue{ my($x) = shift; my($dim) = shift; if(defined $x && !(ref $x)) { my $y = $dim; $dim = $x; $x = $y; } if(!defined $x || $x->nelem==0) { return $x unless(@_); return shift() if(@_<=1); $x=shift; return PDL::glue($x,$dim,@_); } if($dim - $x->dim(0) > 100) { print STDERR "warning:: PDL::glue allocating >100 dimensions!\n"; } while($dim >= $x->ndims) { $x = $x->dummy(-1,1); } $x = $x->xchg(0,$dim); while(scalar(@_)){ my $y = shift; next unless(defined $y && $y->nelem); while($dim >= $y->ndims) { $y = $y->dummy(-1,1); } $y = $y->xchg(0,$dim); $x = $x->append($y); } $x->xchg(0,$dim); } EOD pp_def( 'axisvalues', Pars => 'i(n); [o]a(n)', Inplace => 1, Code => 'loop(n) %{ $a() = n; %}', GenericTypes => [ppdefs_all], Doc => undef, ); # pp_def: axisvalues pp_addhdr(<<'EOH'); extern int pdl_srand_threads; extern uint64_t *pdl_rand_state; void pdl_srand(uint64_t **s, uint64_t seed, int n); double pdl_drand(uint64_t *s); #define PDL_MAYBE_SRAND \ if (pdl_srand_threads < 0) \ pdl_srand(&pdl_rand_state, PDL->pdl_seed(), PDL->online_cpus()); #define PDL_RAND_SET_OFFSET(v, thr, pdl) \ if (v < 0) { \ if (thr.mag_nthr >= 0) { \ int thr_no = PDL->magic_get_thread(pdl); \ if (thr_no < 0) return PDL->make_error_simple(PDL_EFATAL, "Invalid pdl_magic_get_thread!"); \ v = thr_no == 0 ? thr_no : thr_no % PDL->online_cpus(); \ } else { \ v = 0; \ } \ } EOH pp_def( 'srand', Pars=>'a();', GenericTypes => ['Q'], Code => <<'EOF', pdl_srand(&pdl_rand_state, (uint64_t)$a(), PDL->online_cpus()); EOF NoPthread => 1, HaveThreading => 0, Doc=> <<'EOF', =for ref Seed random-number generator with a 64-bit int. Will generate seed data for a number of threads equal to the return-value of L. =for usage srand(); # uses current time srand(5); # fixed number e.g. for testing EOF PMCode=><<'EOD', *srand = \&PDL::srand; sub PDL::srand { PDL::_srand_int($_[0] // PDL::Core::seed()) } EOD ); pp_def( 'random', Pars=>'a();', GenericTypes => [ppdefs_all], PMFunc => '', Code => <<'EOF', PDL_MAYBE_SRAND int rand_offset = -1; threadloop %{ PDL_RAND_SET_OFFSET(rand_offset, $PRIV(pdlthread), $PDL(a)); $a() = pdl_drand(pdl_rand_state + 4*rand_offset); %} EOF Doc=> <<'EOF', =for ref Constructor which returns ndarray of random numbers =for usage $x = random([type], $nx, $ny, $nz,...); $x = random $y; etc (see L). This is the uniform distribution between 0 and 1 (assumedly excluding 1 itself). The arguments are the same as C (q.v.) - i.e. one can specify dimensions, types or give a template. You can use the PDL function L to seed the random generator. If it has not been called yet, it will be with the current time. EOF PMCode=><<'EOD', sub random { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->random : PDL->random(@_) } sub PDL::random { my $class = shift; my $x = scalar(@_)? $class->new_from_specification(@_) : $class->new_or_inplace; PDL::_random_int($x); return $x; } EOD ); pp_def( 'randsym', Pars=>'a();', GenericTypes => [ppdefs_all], PMFunc => '', Code => <<'EOF', PDL_MAYBE_SRAND int rand_offset = -1; threadloop %{ PDL_RAND_SET_OFFSET(rand_offset, $PRIV(pdlthread), $PDL(a)); double tmp; do tmp = pdl_drand(pdl_rand_state + 4*rand_offset); while (tmp == 0.0); /* 0 < tmp < 1 */ $a() = tmp; %} EOF Doc=> <<'EOF', =for ref Constructor which returns ndarray of random numbers =for usage $x = randsym([type], $nx, $ny, $nz,...); $x = randsym $y; etc (see L). This is the uniform distribution between 0 and 1 (excluding both 0 and 1, cf L). The arguments are the same as C (q.v.) - i.e. one can specify dimensions, types or give a template. You can use the PDL function L to seed the random generator. If it has not been called yet, it will be with the current time. EOF PMCode=><<'EOD', sub randsym { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->randsym : PDL->randsym(@_) } sub PDL::randsym { my $class = shift; my $x = scalar(@_)? $class->new_from_specification(@_) : $class->new_or_inplace; PDL::_randsym_int($x); return $x; } EOD ); pp_addpm(<<'EOD'); =head2 grandom =for ref Constructor which returns ndarray of Gaussian random numbers =for usage $x = grandom([type], $nx, $ny, $nz,...); $x = grandom $y; etc (see L). This is generated using the math library routine C. Mean = 0, Stddev = 1 You can use the PDL function L to seed the random generator. If it has not been called yet, it will be with the current time. =cut sub grandom { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->grandom : PDL->grandom(@_) } sub PDL::grandom { my $class = shift; my $x = scalar(@_)? $class->new_from_specification(@_) : $class->new_or_inplace; use PDL::Math 'ndtri'; $x .= ndtri(randsym($x)); return $x; } EOD pp_add_exported('','grandom'); ############################################################### # binary searches in an ndarray; various forms ############################################################### pp_add_exported('','vsearch'); # generic front end; defaults to vsearch_sample for backwards compatibility pp_addpm(<<'EOD'); =head2 vsearch =for sig Signature: ( vals(); xs(n); [o] indx(); [\%options] ) =for ref Efficiently search for values in a sorted ndarray, returning indices. =for usage $idx = vsearch( $vals, $x, [\%options] ); vsearch( $vals, $x, $idx, [\%options ] ); B performs a binary search in the ordered ndarray C<$x>, for the values from C<$vals> ndarray, returning indices into C<$x>. What is a "match", and the meaning of the returned indices, are determined by the options. The C option indicates which method of searching to use, and may be one of: =over =item C invoke L|/vsearch_sample>, returning indices appropriate for sampling within a distribution. =item C invoke L|/vsearch_insert_leftmost>, returning the left-most possible insertion point which still leaves the ndarray sorted. =item C invoke L|/vsearch_insert_rightmost>, returning the right-most possible insertion point which still leaves the ndarray sorted. =item C invoke L|/vsearch_match>, returning the index of a matching element, else -(insertion point + 1) =item C invoke L|/vsearch_bin_inclusive>, returning an index appropriate for binning on a grid where the left bin edges are I of the bin. See below for further explanation of the bin. =item C invoke L|/vsearch_bin_exclusive>, returning an index appropriate for binning on a grid where the left bin edges are I of the bin. See below for further explanation of the bin. =back The default value of C is C. =for example use PDL; my @modes = qw( sample insert_leftmost insert_rightmost match bin_inclusive bin_exclusive ); # Generate a sequence of 3 zeros, 3 ones, ..., 3 fours. my $x = zeroes(3,5)->yvals->flat; for my $mode ( @modes ) { # if the value is in $x my $contained = 2; my $idx_contained = vsearch( $contained, $x, { mode => $mode } ); my $x_contained = $x->copy; $x_contained->slice( $idx_contained ) .= 9; # if the value is not in $x my $not_contained = 1.5; my $idx_not_contained = vsearch( $not_contained, $x, { mode => $mode } ); my $x_not_contained = $x->copy; $x_not_contained->slice( $idx_not_contained ) .= 9; print sprintf("%-23s%30s\n", '$x', $x); print sprintf("%-23s%30s\n", "$mode ($contained)", $x_contained); print sprintf("%-23s%30s\n\n", "$mode ($not_contained)", $x_not_contained); } # $x [0 0 0 1 1 1 2 2 2 3 3 3 4 4 4] # sample (2) [0 0 0 1 1 1 9 2 2 3 3 3 4 4 4] # sample (1.5) [0 0 0 1 1 1 9 2 2 3 3 3 4 4 4] # # $x [0 0 0 1 1 1 2 2 2 3 3 3 4 4 4] # insert_leftmost (2) [0 0 0 1 1 1 9 2 2 3 3 3 4 4 4] # insert_leftmost (1.5) [0 0 0 1 1 1 9 2 2 3 3 3 4 4 4] # # $x [0 0 0 1 1 1 2 2 2 3 3 3 4 4 4] # insert_rightmost (2) [0 0 0 1 1 1 2 2 2 9 3 3 4 4 4] # insert_rightmost (1.5) [0 0 0 1 1 1 9 2 2 3 3 3 4 4 4] # # $x [0 0 0 1 1 1 2 2 2 3 3 3 4 4 4] # match (2) [0 0 0 1 1 1 2 9 2 3 3 3 4 4 4] # match (1.5) [0 0 0 1 1 1 2 2 9 3 3 3 4 4 4] # # $x [0 0 0 1 1 1 2 2 2 3 3 3 4 4 4] # bin_inclusive (2) [0 0 0 1 1 1 2 2 9 3 3 3 4 4 4] # bin_inclusive (1.5) [0 0 0 1 1 9 2 2 2 3 3 3 4 4 4] # # $x [0 0 0 1 1 1 2 2 2 3 3 3 4 4 4] # bin_exclusive (2) [0 0 0 1 1 9 2 2 2 3 3 3 4 4 4] # bin_exclusive (1.5) [0 0 0 1 1 9 2 2 2 3 3 3 4 4 4] Also see L|/vsearch_sample>, L|/vsearch_insert_leftmost>, L|/vsearch_insert_rightmost>, L|/vsearch_match>, L|/vsearch_bin_inclusive>, and L|/vsearch_bin_exclusive> =cut sub vsearch { my $opt = 'HASH' eq ref $_[-1] ? pop : { mode => 'sample' }; croak( "unknown options to vsearch\n" ) if ( ! defined $opt->{mode} && keys %$opt ) || keys %$opt > 1; my $mode = $opt->{mode}; goto $mode eq 'sample' ? \&vsearch_sample : $mode eq 'insert_leftmost' ? \&vsearch_insert_leftmost : $mode eq 'insert_rightmost' ? \&vsearch_insert_rightmost : $mode eq 'match' ? \&vsearch_match : $mode eq 'bin_inclusive' ? \&vsearch_bin_inclusive : $mode eq 'bin_exclusive' ? \&vsearch_bin_exclusive : croak( "unknown vsearch mode: $mode\n" ); } *PDL::vsearch = \&vsearch; EOD use Text::Tabs qw[ expand ]; sub undent { my $txt = expand( shift ); $txt =~ s/^([ \t]+)-{4}.*$//m; $txt =~ s/^$1//mg if defined $1; $txt; } for my $func ( [ vsearch_sample => { low => -1, high => '$SIZE(n)', up => '($x(n => n1) > $x(n => 0))', code => q[ while ( high - low > 1 ) { mid = %MID%; if ( ( value > $x(n => mid ) ) == up ) low = mid; else high = mid; } $idx() = low >= n1 ? n1 : up ? low + 1 : PDLMAX(low, 0); ---- ], ref => 'Search for values in a sorted array, return index appropriate for sampling from a distribution', doc_pre => q[ B<%FUNC%> returns an index I for each value I of C<$vals> appropriate for sampling C<$vals> ---- ], doc_incr => q[ V <= x[0] : I = 0 x[0] < V <= x[-1] : I s.t. x[I-1] < V <= x[I] x[-1] < V : I = $x->nelem -1 ---- ], doc_decr => q[ V > x[0] : I = 0 x[0] >= V > x[-1] : I s.t. x[I] >= V > x[I+1] x[-1] >= V : I = $x->nelem - 1 ---- ], doc_post => q[ If all elements of C<$x> are equal, I<< I = $x->nelem - 1 >>. If C<$x> contains duplicated elements, I is the index of the leftmost (by position in array) duplicate if I matches. =for example This function is useful e.g. when you have a list of probabilities for events and want to generate indices to events: $x = pdl(.01,.86,.93,1); # Barnsley IFS probabilities cumulatively $y = random 20; $c = %FUNC%($y, $x); # Now, $c will have the appropriate distr. It is possible to use the L function to obtain cumulative probabilities from absolute probabilities. ---- ], }, ], [ # return left-most possible insertion point. # lowest index where x[i] >= value vsearch_insert_leftmost => { low => 0, high => 'n1', code => q[ while (low <= high ) { mid = %MID%; if ( ( $x(n => mid) >= value ) == up ) high = mid - 1; else low = mid + 1; } $idx() = up ? low : high; ], ref => 'Determine the insertion point for values in a sorted array, inserting before duplicates.', doc_pre => q[ B<%FUNC%> returns an index I for each value I of C<$vals> equal to the leftmost position (by index in array) within C<$x> that I may be inserted and still maintain the order in C<$x>. Insertion at index I involves shifting elements I and higher of C<$x> to the right by one and setting the now empty element at index I to I. ---- ], doc_incr => q[ V <= x[0] : I = 0 x[0] < V <= x[-1] : I s.t. x[I-1] < V <= x[I] x[-1] < V : I = $x->nelem ---- ], doc_decr => q[ V > x[0] : I = -1 x[0] >= V >= x[-1] : I s.t. x[I] >= V > x[I+1] x[-1] >= V : I = $x->nelem -1 ---- ], doc_post => q[ If all elements of C<$x> are equal, i = 0 If C<$x> contains duplicated elements, I is the index of the leftmost (by index in array) duplicate if I matches. ---- ], }, ], [ # return right-most possible insertion point. # lowest index where x[i] > value vsearch_insert_rightmost => { low => 0, high => 'n1', code => q[ while (low <= high ) { mid = %MID%; if ( ( $x(n => mid) > value ) == up ) high = mid - 1; else low = mid + 1; } $idx() = up ? low : high; ], ref => 'Determine the insertion point for values in a sorted array, inserting after duplicates.', doc_pre => q[ B<%FUNC%> returns an index I for each value I of C<$vals> equal to the rightmost position (by index in array) within C<$x> that I may be inserted and still maintain the order in C<$x>. Insertion at index I involves shifting elements I and higher of C<$x> to the right by one and setting the now empty element at index I to I. ---- ], doc_incr => q[ V < x[0] : I = 0 x[0] <= V < x[-1] : I s.t. x[I-1] <= V < x[I] x[-1] <= V : I = $x->nelem ---- ], doc_decr => q[ V >= x[0] : I = -1 x[0] > V >= x[-1] : I s.t. x[I] >= V > x[I+1] x[-1] > V : I = $x->nelem -1 ---- ], doc_post => q[ If all elements of C<$x> are equal, i = $x->nelem - 1 If C<$x> contains duplicated elements, I is the index of the leftmost (by index in array) duplicate if I matches. ---- ], }, ], [ # return index of matching element, else -( insertion point + 1 ) # patterned after the Java binarySearch interface; see # http://docs.oracle.com/javase/7/docs/api/java/util/Arrays.html vsearch_match => { low => 0, high => 'n1', code => q[ int done = 0; while (low <= high ) { $GENERIC() mid_value; mid = %MID%; mid_value = $x(n=>mid); if ( up ) { if ( mid_value > value ) { high = mid - 1; } else if ( mid_value < value ) { low = mid + 1; } else { done = 1; break; } } else { if ( mid_value < value ) { high = mid - 1; } else if ( mid_value > value ) { low = mid + 1; } else { done = 1; break; } } } $idx() = done ? mid : up ? - ( low + 1 ) : - ( high + 1 ); ], ref => 'Match values against a sorted array.', doc_pre => q[ B<%FUNC%> returns an index I for each value I of C<$vals>. If I matches an element in C<$x>, I is the index of that element, otherwise it is I<-( insertion_point + 1 )>, where I is an index in C<$x> where I may be inserted while maintaining the order in C<$x>. If C<$x> has duplicated values, I may refer to any of them. ---- ], }, ], [ # x[i] is the INclusive left edge of the bin # return i, s.t. x[i] <= value < x[i+1]. # returns -1 if x[0] > value # returns N-1 if x[-1] <= value vsearch_bin_inclusive => { low => 0, high => 'n1', code => q[ while (low <= high ) { mid = %MID%; if ( ( $x(n => mid) <= value ) == up ) low = mid + 1; else high = mid - 1; } $idx() = up ? high: low; ], ref => 'Determine the index for values in a sorted array of bins, lower bound inclusive.', doc_pre => q[ C<$x> represents the edges of contiguous bins, with the first and last elements representing the outer edges of the outer bins, and the inner elements the shared bin edges. The lower bound of a bin is inclusive to the bin, its outer bound is exclusive to it. B<%FUNC%> returns an index I for each value I of C<$vals> ---- ], doc_incr => q[ V < x[0] : I = -1 x[0] <= V < x[-1] : I s.t. x[I] <= V < x[I+1] x[-1] <= V : I = $x->nelem - 1 ---- ], doc_decr => q[ V >= x[0] : I = 0 x[0] > V >= x[-1] : I s.t. x[I+1] > V >= x[I] x[-1] > V : I = $x->nelem ---- ], doc_post => q[ If all elements of C<$x> are equal, i = $x->nelem - 1 If C<$x> contains duplicated elements, I is the index of the righmost (by index in array) duplicate if I matches. ---- ], }, ], [ # x[i] is the EXclusive left edge of the bin # return i, s.t. x[i] < value <= x[i+1]. # returns -1 if x[0] >= value # returns N-1 if x[-1] < value vsearch_bin_exclusive => { low => 0, high => 'n1', code => q[ while (low <= high ) { mid = %MID%; if ( ( $x(n => mid) < value ) == up ) low = mid + 1; else high = mid - 1; } $idx() = up ? high: low; ], ref => 'Determine the index for values in a sorted array of bins, lower bound exclusive.', doc_pre => q[ C<$x> represents the edges of contiguous bins, with the first and last elements representing the outer edges of the outer bins, and the inner elements the shared bin edges. The lower bound of a bin is exclusive to the bin, its upper bound is inclusive to it. B<%FUNC%> returns an index I for each value I of C<$vals>. ---- ], doc_incr => q[ V <= x[0] : I = -1 x[0] < V <= x[-1] : I s.t. x[I] < V <= x[I+1] x[-1] < V : I = $x->nelem - 1 ---- ], doc_decr => q[ V > x[0] : I = 0 x[0] >= V > x[-1] : I s.t. x[I-1] >= V > x[I] x[-1] >= V : I = $x->nelem ---- ], doc_post => q[ If all elements of C<$x> are equal, i = $x->nelem - 1 If C<$x> contains duplicated elements, I is the index of the righmost (by index in array) duplicate if I matches. ---- ], } ], ) { my ( $func, $algo ) = @$func; my %replace = ( # calculate midpoint of range; ensure we don't overflow # (low+high)>>1 for large values of low + high # see sf.net bug #360 '%MID%' => 'low + (( high - low )>> 1);', # determine which way the data are sorted. vsearch_sample # overrides this. '%UP%' => '$x(n => n1) >= $x(n => 0)', '%FUNC%' => $func, '%PRE%' => undent( q[ %DOC_PRE% ---- ] ), '%BODY%' => undent( q[ I has the following properties: =over =item * if C<$x> is sorted in increasing order %DOC_INCR% =item * if C<$x> is sorted in decreasing order %DOC_DECR% =back ---- ] ), '%POST%' => undent( q[ %DOC_POST% ---- ] ), map { ( "%\U$_%" => undent( $algo->{$_} ) ) } keys %$algo, ); $replace{'%PRE%'} = '' unless defined $replace{'%DOC_PRE%'}; $replace{'%BODY%'} = '' unless defined $replace{'%DOC_INCR%'} || defined $replace{'%DOC_DECR%'}; $replace{'%POST%'} = '' unless defined $replace{'%DOC_POST%'}; my $code = undent q[ PDL_Indx n1 = $SIZE(n)-1; PDL_Indx low = %LOW%; PDL_Indx high = %HIGH%; PDL_Indx mid; $GENERIC() value = $vals(); /* determine sort order of data */ int up = %UP%; %CODE% ---- ]; my $doc = undent q[ =for ref %REF% =for usage $idx = %FUNC%($vals, $x); C<$x> must be sorted, but may be in decreasing or increasing order. %PRE% %BODY% %POST% ---- ]; # redo until nothing changes for my $tref ( \$code, \$doc ) { 1 while $$tref =~ s/(%[\w_]+%)/$replace{$1}/ge; } pp_def( $func, HandleBad => 0, BadDoc => 'needs major (?) work to handles bad values', Pars => 'vals(); x(n); indx [o]idx()', GenericTypes => $F, # too restrictive ? Code => $code, Doc => $doc, ); } ############################################################### # routines somehow related to interpolation ############################################################### pp_def('interpolate', HandleBad => 0, BadDoc => 'needs major (?) work to handles bad values', Pars => 'xi(); x(n); y(n); [o] yi(); int [o] err()', GenericTypes => $F, # too restrictive ? Code => ' $GENERIC() d; PDL_Indx n = $SIZE(n); PDL_Indx n1 = n-1; int up = ($x(n => n1) > $x(n => 0)); PDL_Indx jl, jh, m; int carp; threadloop %{ jl = -1; jh = n; carp = 0; while (jh-jl > 1) /* binary search */ { m = (jh+jl) >> 1; if (($xi() > $x(n => m)) == up) jl = m; else jh = m; } if (jl == -1) { if ($xi() != $x(n => 0)) carp = 1; jl = 0; } else if (jh == n) { if ($xi() != $x(n => n1)) carp = 1; jl = n1-1; } jh = jl+1; if ((d = $x(n => jh)-$x(n => jl)) == 0) $CROAK("identical abscissas"); d = ($x(n => jh)-$xi())/d; $yi() = d*$y(n => jl) + (1-d)*$y(n => jh); $err() = carp; %} ', Doc=><<'EOD'); =for ref routine for 1D linear interpolation =for usage ( $yi, $err ) = interpolate($xi, $x, $y) Given a set of points C<($x,$y)>, use linear interpolation to find the values C<$yi> at a set of points C<$xi>. C uses a binary search to find the suspects, er..., interpolation indices and therefore abscissas (ie C<$x>) have to be I ordered (increasing or decreasing). For interpolation at lots of closely spaced abscissas an approach that uses the last index found as a start for the next search can be faster (compare Numerical Recipes C routine). Feel free to implement that on top of the binary search if you like. For out of bounds values it just does a linear extrapolation and sets the corresponding element of C<$err> to 1, which is otherwise 0. See also L, which uses the same routine, differing only in the handling of extrapolation - an error message is printed rather than returning an error ndarray. =cut EOD pp_add_exported('', 'interpol'); pp_addpm(<<'EOD'); =head2 interpol =for sig Signature: (xi(); x(n); y(n); [o] yi()) =for ref routine for 1D linear interpolation =for usage $yi = interpol($xi, $x, $y) C uses the same search method as L, hence C<$x> must be I ordered (either increasing or decreasing). The difference occurs in the handling of out-of-bounds values; here an error message is printed. =cut # kept in for backwards compatability sub interpol ($$$;$) { my $xi = shift; my $x = shift; my $y = shift; my $yi; if ( $#_ == 0 ) { $yi = $_[0]; } else { $yi = PDL->null; } interpolate( $xi, $x, $y, $yi, my $err = PDL->null ); print "some values had to be extrapolated\n" if any $err; return $yi if $#_ == -1; } # sub: interpol() *PDL::interpol = \&interpol; EOD pp_add_exported('','interpND'); pp_addpm(<<'EOD'); =head2 interpND =for ref Interpolate values from an N-D ndarray, with switchable method =for example $source = 10*xvals(10,10) + yvals(10,10); $index = pdl([[2.2,3.5],[4.1,5.0]],[[6.0,7.4],[8,9]]); print $source->interpND( $index ); InterpND acts like L, collapsing C<$index> by lookup into C<$source>; but it does interpolation rather than direct sampling. The interpolation method and boundary condition are switchable via an options hash. By default, linear or sample interpolation is used, with constant value outside the boundaries of the source pdl. No dataflow occurs, because in general the output is computed rather than indexed. All the interpolation methods treat the pixels as value-centered, so the C method will return C<< $a->(0) >> for coordinate values on the set [-0.5,0.5), and all methods will return C<< $a->(1) >> for a coordinate value of exactly 1. Recognized options: =over 3 =item method Values can be: =over 3 =item * 0, s, sample, Sample (default for integer source types) The nearest value is taken. Pixels are regarded as centered on their respective integer coordinates (no offset from the linear case). =item * 1, l, linear, Linear (default for floating point source types) The values are N-linearly interpolated from an N-dimensional cube of size 2. =item * 3, c, cube, cubic, Cubic The values are interpolated using a local cubic fit to the data. The fit is constrained to match the original data and its derivative at the data points. The second derivative of the fit is not continuous at the data points. Multidimensional datasets are interpolated by the successive-collapse method. (Note that the constraint on the first derivative causes a small amount of ringing around sudden features such as step functions). =item * f, fft, fourier, Fourier The source is Fourier transformed, and the interpolated values are explicitly calculated from the coefficients. The boundary condition option is ignored -- periodic boundaries are imposed. If you pass in the option "fft", and it is a list (ARRAY) ref, then it is a stash for the magnitude and phase of the source FFT. If the list has two elements then they are taken as already computed; otherwise they are calculated and put in the stash. =back =item b, bound, boundary, Boundary This option is passed unmodified into L, which is used as the indexing engine for the interpolation. Some current allowed values are 'extend', 'periodic', 'truncate', and 'mirror' (default is 'truncate'). =item bad contains the fill value used for 'truncate' boundary. (default 0) =item fft An array ref whose associated list is used to stash the FFT of the source data, for the FFT method. =back =cut *interpND = *PDL::interpND; sub PDL::interpND { my $source = shift; my $index = shift; my $options = shift; barf 'Usage: interp_nd($source,$index,[{%options}])\n' if(defined $options and ref $options ne 'HASH'); my($opt) = (defined $options) ? $options : {}; my($method) = $opt->{m} || $opt->{meth} || $opt->{method} || $opt->{Method}; $method //= $source->type->integer ? 'sample' : 'linear'; my($boundary) = $opt->{b} || $opt->{boundary} || $opt->{Boundary} || $opt->{bound} || $opt->{Bound} || 'extend'; my($bad) = $opt->{bad} || $opt->{Bad} || 0.0; if($method =~ m/^s(am(p(le)?)?)?/i) { return $source->range(PDL::Math::floor($index+0.5),0,$boundary); } elsif (($method eq 1) || $method =~ m/^l(in(ear)?)?/i) { ## key: (ith = index thread; cth = cube thread; sth = source thread) my $d = $index->dim(0); my $di = $index->ndims - 1; # Grab a 2-on-a-side n-cube around each desired pixel my $samp = $source->range($index->floor,2,$boundary); # (ith, cth, sth) # Reorder to put the cube dimensions in front and convert to a list $samp = $samp->reorder( $di .. $di+$d-1, 0 .. $di-1, $di+$d .. $samp->ndims-1) # (cth, ith, sth) ->clump($d); # (clst, ith, sth) # Enumerate the corners of an n-cube and convert to a list # (the 'x' is the normal perl repeat operator) my $crnr = PDL::Basic::ndcoords( (2) x $index->dim(0) ) # (index,cth) ->mv(0,-1)->clump($index->dim(0))->mv(-1,0); # (index, clst) # a & b are the weighting coefficients. my($x,$y); my($indexwhere); ($indexwhere = $index->where( 0 * $index )) .= -10; # Change NaN to invalid { my $bb = PDL::Math::floor($index); $x = ($index - $bb) -> dummy(1,$crnr->dim(1)); # index, clst, ith $y = ($bb + 1 - $index) -> dummy(1,$crnr->dim(1)); # index, clst, ith } # Use 1/0 corners to select which multiplier happens, multiply # 'em all together to get sample weights, and sum to get the answer. my $out0 = ( ($x * ($crnr==1) + $y * ($crnr==0)) #index, clst, ith -> prodover #clst, ith ); my $out = ($out0 * $samp)->sumover; # ith, sth # Work around BAD-not-being-contagious bug in PDL <= 2.6 bad handling code --CED 3-April-2013 if ($source->badflag) { my $baddies = $samp->isbad->orover; $out = $out->setbadif($baddies); } return $out; } elsif(($method eq 3) || $method =~ m/^c(u(b(e|ic)?)?)?/i) { my ($d,@di) = $index->dims; my $di = $index->ndims - 1; # Grab a 4-on-a-side n-cube around each desired pixel my $samp = $source->range($index->floor - 1,4,$boundary) #ith, cth, sth ->reorder( $di .. $di+$d-1, 0..$di-1, $di+$d .. $source->ndims-1 ); # (cth, ith, sth) # Make a cube of the subpixel offsets, and expand its dims to # a 4-on-a-side N-1 cube, to match the slices of $samp (used below). my $y = $index - $index->floor; for my $i(1..$d-1) { $y = $y->dummy($i,4); } # Collapse by interpolation, one dimension at a time... for my $i(0..$d-1) { my $a0 = $samp->slice("(1)"); # Just-under-sample my $a1 = $samp->slice("(2)"); # Just-over-sample my $a1a0 = $a1 - $a0; my $gradient = 0.5 * ($samp->slice("2:3")-$samp->slice("0:1")); my $s0 = $gradient->slice("(0)"); # Just-under-gradient my $s1 = $gradient->slice("(1)"); # Just-over-gradient my $bb = $y->slice("($i)"); # Collapse the sample... $samp = ( $a0 + $bb * ( $s0 + $bb * ( (3 * $a1a0 - 2*$s0 - $s1) + $bb * ( $s1 + $s0 - 2*$a1a0 ) ) ) ); # "Collapse" the subpixel offset... $y = $y->slice(":,($i)"); } return $samp; } elsif($method =~ m/^f(ft|ourier)?/i) { eval "use PDL::FFT;"; my $fftref = $opt->{fft}; $fftref = [] unless(ref $fftref eq 'ARRAY'); if(@$fftref != 2) { my $x = $source->copy; my $y = zeroes($source); fftnd($x,$y); $fftref->[0] = sqrt($x*$x+$y*$y) / $x->nelem; $fftref->[1] = - atan2($y,$x); } my $i; my $c = PDL::Basic::ndcoords($source); # (dim, source-dims) for $i(1..$index->ndims-1) { $c = $c->dummy($i,$index->dim($i)) } my $id = $index->ndims-1; my $phase = (($c * $index * 3.14159 * 2 / pdl($source->dims)) ->sumover) # (index-dims, source-dims) ->reorder($id..$id+$source->ndims-1,0..$id-1); # (src, index) my $phref = $fftref->[1]->copy; # (source-dims) my $mag = $fftref->[0]->copy; # (source-dims) for $i(1..$index->ndims-1) { $phref = $phref->dummy(-1,$index->dim($i)); $mag = $mag->dummy(-1,$index->dim($i)); } my $out = cos($phase + $phref ) * $mag; $out = $out->clump($source->ndims)->sumover; return $out; } else { barf("interpND: unknown method '$method'; valid ones are 'linear' and 'sample'.\n"); } } EOD ############################################################## # things related to indexing: one2nd, which, where ############################################################## pp_add_exported("", 'one2nd'); pp_addpm(<<'EOD'); =head2 one2nd =for ref Converts a one dimensional index ndarray to a set of ND coordinates =for usage @coords=one2nd($x, $indices) returns an array of ndarrays containing the ND indexes corresponding to the one dimensional list indices. The indices are assumed to correspond to array C<$x> clumped using C. This routine is used in the old vector form of L, but is useful on its own occasionally. Returned ndarrays have the L datatype. C<$indices> can have values larger than C<< $x->nelem >> but negative values in C<$indices> will not give the answer you expect. =for example pdl> $x=pdl [[[1,2],[-1,1]], [[0,-3],[3,2]]]; $c=$x->clump(-1) pdl> $maxind=maximum_ind($c); p $maxind; 6 pdl> print one2nd($x, maximum_ind($c)) 0 1 1 pdl> p $x->at(0,1,1) 3 =cut *one2nd = \&PDL::one2nd; sub PDL::one2nd { barf "Usage: one2nd \$array \$indices\n" if $#_ != 1; my ($x, $ind)=@_; my @dimension=$x->dims; $ind = indx($ind); my(@index); my $count=0; foreach (@dimension) { $index[$count++]=$ind % $_; $ind /= $_; } return @index; } EOD my $doc_which = <<'EOD'; =for ref Returns indices of non-zero values from a 1-D PDL =for usage $i = which($mask); returns a pdl with indices for all those elements that are nonzero in the mask. Note that the returned indices will be 1D. If you feed in a multidimensional mask, it will be flattened before the indices are calculated. See also L for multidimensional masks. If you want to index into the original mask or a similar ndarray with output from C, remember to flatten it before calling index: $data = random 5, 5; $idx = which $data > 0.5; # $idx is now 1D $bigsum = $data->flat->index($idx)->sum; # flatten before indexing Compare also L for similar functionality. SEE ALSO: L returns separately the indices of both zero and nonzero values in the mask. L returns associated values from a data PDL, rather than indices into the mask PDL. L returns N-D indices into a multidimensional PDL. =for example pdl> $x = sequence(10); p $x [0 1 2 3 4 5 6 7 8 9] pdl> $indx = which($x>6); p $indx [7 8 9] =cut EOD my $doc_which_both = <<'EOD'; =for ref Returns indices of zero and nonzero values in a mask PDL =for usage ($i, $c_i) = which_both($mask); This works just as L, but the complement of C<$i> will be in C<$c_i>. =for example pdl> $x = sequence(10); p $x [0 1 2 3 4 5 6 7 8 9] pdl> ($small, $big) = which_both ($x >= 5); p "$small\n $big" [5 6 7 8 9] [0 1 2 3 4] =cut EOD for ( {Name=>'which', Pars => 'mask(n); indx [o] inds(m);', Variables => 'int dm=0;', Elseclause => "", Autosize => '$SIZE(m) = sum;', Doc => $doc_which, PMCode=><<'EOD', sub which { my ($this,$out) = @_; $this = $this->flat; $out = $this->nullcreate unless defined $out; PDL::_which_int($this,$out); return $out; } *PDL::which = \&which; EOD }, {Name => 'which_both', Pars => 'mask(n); indx [o] inds(m); indx [o]notinds(q)', Variables => 'int dm=0; int dm2=0;', Elseclause => "else { \n \$notinds(q => dm2)=n; \n dm2++;\n }", Autosize => '$SIZE(m) = sum;'."\n".' $SIZE(q) = dpdl->dims[0]-sum;', Doc => $doc_which_both, PMCode=><<'EOD', sub which_both { my ($this,$outi,$outni) = @_; $this = $this->flat; $outi = $this->nullcreate unless defined $outi; $outni = $this->nullcreate unless defined $outni; PDL::_which_both_int($this,$outi,$outni); return wantarray ? ($outi,$outni) : $outi; } *PDL::which_both = \&which_both; EOD } ) { my $p1 = $_->{Variables} .' loop(n) %{ if ( $mask() '; my $p2 = ' ) { $inds(m => dm) = n; dm++; }'.$_->{Elseclause} . "\n". ' %}'; pp_def($_->{Name}, HandleBad => 1, Doc => $_->{Doc}, Pars => $_->{Pars}, GenericTypes => [ppdefs_all], PMCode => $_->{PMCode}, Code => $p1.$p2, BadCode => $p1.' && $ISGOOD($mask())'.$p2, # the next one is currently a dirty hack # this will probably break once dataflow is enabled again # *unless* we have made sure that mask is physical by now!!! RedoDimsCode => ' PDL_Indx sum = 0; /* not sure if this is necessary */ pdl * dpdl = $PDL(mask); $GENERIC() *m_datap = (($GENERIC() *)(PDL_REPRP(dpdl))); PDL_Indx inc = PDL_REPRINC(dpdl,0); PDL_Indx offs = PDL_REPROFFS(dpdl); PDL_Indx i; if (dpdl->ndims != 1) $CROAK("dimflag currently works only with 1D pdls"); if(dpdl->state & PDL_BADVAL) for (i=0; idims[0]; i++) { $GENERIC() foo = *(m_datap+inc*i+offs); if(foo && $ISGOODVAR(foo,mask) )sum++; } else for (i=0; idims[0]; i++) { $GENERIC() foo = *(m_datap+inc*i+offs); if(foo) sum++; } '. $_->{Autosize} . ' /* printf("RedoDimsCode: setting dim m to %ld\n",sum); */' ); } pp_addpm(<<'EOD'); =head2 where =for ref Use a mask to select values from one or more data PDLs C accepts one or more data ndarrays and a mask ndarray. It returns a list of output ndarrays, corresponding to the input data ndarrays. Each output ndarray is a 1-dimensional list of values in its corresponding data ndarray. The values are drawn from locations where the mask is nonzero. The output PDLs are still connected to the original data PDLs, for the purpose of dataflow. C combines the functionality of L and L into a single operation. BUGS: While C works OK for most N-dimensional cases, it does not thread properly over (for example) the (N+1)th dimension in data that is compared to an N-dimensional mask. Use C for that. =for usage $i = $x->where($x+5 > 0); # $i contains those elements of $x # where mask ($x+5 > 0) is 1 $i .= -5; # Set those elements (of $x) to -5. Together, these # commands clamp $x to a maximum of -5. It is also possible to use the same mask for several ndarrays with the same call: ($i,$j,$k) = where($x,$y,$z, $x+5>0); Note: C<$i> is always 1-D, even if C<$x> is E1-D. WARNING: The first argument (the values) and the second argument (the mask) currently have to have the exact same dimensions (or horrible things happen). You *cannot* thread over a smaller mask, for example. =cut sub PDL::where { barf "Usage: where( \$pdl1, ..., \$pdlN, \$mask )\n" if $#_ == 0; if($#_ == 1) { my($data,$mask) = @_; $data = $_[0]->clump(-1) if $_[0]->getndims>1; $mask = $_[1]->clump(-1) if $_[0]->getndims>1; return $data->index($mask->which()); } else { if($_[-1]->getndims > 1) { my $mask = $_[-1]->clump(-1)->which; return map {$_->clump(-1)->index($mask)} @_[0..$#_-1]; } else { my $mask = $_[-1]->which; return map {$_->index($mask)} @_[0..$#_-1]; } } } *where = \&PDL::where; EOD pp_add_exported("", 'where'); pp_addpm(<<'EOD'); =head2 whereND =for ref C with support for ND masks and threading C accepts one or more data ndarrays and a mask ndarray. It returns a list of output ndarrays, corresponding to the input data ndarrays. The values are drawn from locations where the mask is nonzero. C differs from C in that the mask dimensionality is preserved which allows for proper threading of the selection operation over higher dimensions. As with C the output PDLs are still connected to the original data PDLs, for the purpose of dataflow. =for usage $sdata = whereND $data, $mask ($s1, $s2, ..., $sn) = whereND $d1, $d2, ..., $dn, $mask where $data is M dimensional $mask is N < M dimensional dims($data) 1..N == dims($mask) 1..N with threading over N+1 to M dimensions =for example $data = sequence(4,3,2); # example data array $mask4 = (random(4)>0.5); # example 1-D mask array, has $n4 true values $mask43 = (random(4,3)>0.5); # example 2-D mask array, has $n43 true values $sdat4 = whereND $data, $mask4; # $sdat4 is a [$n4,3,2] pdl $sdat43 = whereND $data, $mask43; # $sdat43 is a [$n43,2] pdl Just as with C, you can use the returned value in an assignment. That means that both of these examples are valid: # Used to create a new slice stored in $sdat4: $sdat4 = $data->whereND($mask4); $sdat4 .= 0; # Used in lvalue context: $data->whereND($mask4) .= 0; SEE ALSO: L returns N-D indices into a multidimensional PDL, from a mask. =cut sub PDL::whereND :lvalue { barf "Usage: whereND( \$pdl1, ..., \$pdlN, \$mask )\n" if $#_ == 0; my $mask = pop @_; # $mask has 0==false, 1==true my @to_return; my $n = PDL::sum($mask); foreach my $arr (@_) { my $sub_i = $mask * ones($arr); my $where_sub_i = PDL::where($arr, $sub_i); # count the number of dims in $mask and $arr # $mask = a b c d e f..... my @idims = dims($arr); # ...and pop off the number of dims in $mask foreach ( dims($mask) ) { shift(@idims) }; my $ndim = 0; foreach my $id ($n, @idims[0..($#idims-1)]) { $where_sub_i = $where_sub_i->splitdim($ndim++,$id) if $n>0; } push @to_return, $where_sub_i; } return (@to_return == 1) ? $to_return[0] : @to_return; } *whereND = \&PDL::whereND; EOD pp_add_exported("", 'whereND'); pp_addpm(<<'EOD'); =head2 whichND =for ref Return the coordinates of non-zero values in a mask. =for usage WhichND returns the N-dimensional coordinates of each nonzero value in a mask PDL with any number of dimensions. The returned values arrive as an array-of-vectors suitable for use in L or L. $coords = whichND($mask); returns a PDL containing the coordinates of the elements that are non-zero in C<$mask>, suitable for use in L. The 0th dimension contains the full coordinate listing of each point; the 1st dimension lists all the points. For example, if $mask has rank 4 and 100 matching elements, then $coords has dimension 4x100. If no such elements exist, then whichND returns a structured empty PDL: an Nx0 PDL that contains no values (but matches, threading-wise, with the vectors that would be produced if such elements existed). DEPRECATED BEHAVIOR IN LIST CONTEXT: whichND once delivered different values in list context than in scalar context, for historical reasons. In list context, it returned the coordinates transposed, as a collection of 1-PDLs (one per dimension) in a list. This usage is deprecated in PDL 2.4.10, and will cause a warning to be issued every time it is encountered. To avoid the warning, you can set the global variable "$PDL::whichND" to 's' to get scalar behavior in all contexts, or to 'l' to get list behavior in list context. In later versions of PDL, the deprecated behavior will disappear. Deprecated list context whichND expressions can be replaced with: @list = $x->whichND->mv(0,-1)->dog; SEE ALSO: L finds coordinates of nonzero values in a 1-D mask. L extracts values from a data PDL that are associated with nonzero values in a mask PDL. L can be fed the coordinates to return the values. =for example pdl> $s=sequence(10,10,3,4) pdl> ($x, $y, $z, $w)=whichND($s == 203); p $x, $y, $z, $w [3] [0] [2] [0] pdl> print $s->at(list(cat($x,$y,$z,$w))) 203 =cut *whichND = \&PDL::whichND; sub PDL::whichND { my $mask = PDL->topdl(shift); # List context: generate a perl list by dimension if(wantarray) { if(!defined($PDL::whichND)) { printf STDERR "whichND: WARNING - list context deprecated. Set \$PDL::whichND. Details in pod."; } elsif($PDL::whichND =~ m/l/i) { # old list context enabled by setting $PDL::whichND to 'l' my $ind=($mask->clump(-1))->which; return $mask->one2nd($ind); } # if $PDL::whichND does not contain 'l' or 'L', fall through to scalar context } # Scalar context: generate an N-D index ndarray return PDL->new_from_specification(indx,$mask->ndims,0) if !$mask->nelem; return $mask ? pdl(indx,0) : PDL->new_from_specification(indx,0) if !$mask->getndims; my $ind = $mask->flat->which->dummy(0,$mask->getndims)->make_physical; # In the empty case, explicitly return the correct type of structured empty return PDL->new_from_specification(indx,$mask->ndims, 0) if !$ind->nelem; my $mult = ones(indx, $mask->getndims); my @mdims = $mask->dims; for my $i (0..$#mdims-1) { # use $tmp for 5.005_03 compatibility (my $tmp = $mult->index($i+1)) .= $mult->index($i)*$mdims[$i]; } for my $i (0..$#mdims) { my($s) = $ind->index($i); $s /= $mult->index($i); $s %= $mdims[$i]; } return $ind; } EOD pp_add_exported("", 'whichND'); # # Set operations suited for manipulation of the operations above. # pp_addpm(<<'EOD'); =head2 setops =for ref Implements simple set operations like union and intersection =for usage Usage: $set = setops($x, , $y); The operator can be C, C or C. This is then applied to C<$x> viewed as a set and C<$y> viewed as a set. Set theory says that a set may not have two or more identical elements, but setops takes care of this for you, so C<$x=pdl(1,1,2)> is OK. The functioning is as follows: =over =item C The resulting vector will contain the elements that are either in C<$x> I in C<$y> or both. This is the union in set operation terms =item C The resulting vector will contain the elements that are either in C<$x> or C<$y>, but not in both. This is Union($x, $y) - Intersection($x, $y) in set operation terms. =item C The resulting vector will contain the intersection of C<$x> and C<$y>, so the elements that are in both C<$x> and C<$y>. Note that for convenience this operation is also aliased to L. =back It should be emphasized that these routines are used when one or both of the sets C<$x>, C<$y> are hard to calculate or that you get from a separate subroutine. Finally IDL users might be familiar with Craig Markwardt's C routine which has inspired this routine although it was written independently However the present routine has a few less options (but see the examples) =for example You will very often use these functions on an index vector, so that is what we will show here. We will in fact something slightly silly. First we will find all squares that are also cubes below 10000. Create a sequence vector: pdl> $x = sequence(10000) Find all odd and even elements: pdl> ($even, $odd) = which_both( ($x % 2) == 0) Find all squares pdl> $squares= which(ceil(sqrt($x)) == floor(sqrt($x))) Find all cubes (being careful with roundoff error!) pdl> $cubes= which(ceil($x**(1.0/3.0)) == floor($x**(1.0/3.0)+1e-6)) Then find all squares that are cubes: pdl> $both = setops($squares, 'AND', $cubes) And print these (assumes that C is loaded!) pdl> p $x($both) [0 1 64 729 4096] Then find all numbers that are either cubes or squares, but not both: pdl> $cube_xor_square = setops($squares, 'XOR', $cubes) pdl> p $cube_xor_square->nelem() 112 So there are a total of 112 of these! Finally find all odd squares: pdl> $odd_squares = setops($squares, 'AND', $odd) Another common occurrence is to want to get all objects that are in C<$x> and in the complement of C<$y>. But it is almost always best to create the complement explicitly since the universe that both are taken from is not known. Thus use L if possible to keep track of complements. If this is impossible the best approach is to make a temporary: This creates an index vector the size of the universe of the sets and set all elements in C<$y> to 0 pdl> $tmp = ones($n_universe); $tmp($y) .= 0; This then finds the complement of C<$y> pdl> $C_b = which($tmp == 1); and this does the final selection: pdl> $set = setops($x, 'AND', $C_b) =cut *setops = \&PDL::setops; sub PDL::setops { my ($x, $op, $y)=@_; # Check that $x and $y are 1D. if ($x->ndims() > 1 || $y->ndims() > 1) { warn 'setops: $x and $y must be 1D - flattening them!'."\n"; $x = $x->flat; $y = $y->flat; } #Make sure there are no duplicate elements. $x=$x->uniq; $y=$y->uniq; my $result; if ($op eq 'OR') { # Easy... $result = uniq(append($x, $y)); } elsif ($op eq 'XOR') { # Make ordered list of set union. my $union = append($x, $y)->qsort; # Index lists. my $s1=zeroes(byte, $union->nelem()); my $s2=zeroes(byte, $union->nelem()); # Find indices which are duplicated - these are to be excluded # # We do this by comparing x with x shifted each way. my $i1 = which($union != rotate($union, 1)); my $i2 = which($union != rotate($union, -1)); # # We then mark/mask these in the s1 and s2 arrays to indicate which ones # are not equal to their neighbours. # my $ts; ($ts = $s1->index($i1)) .= 1 if $i1->nelem() > 0; ($ts = $s2->index($i2)) .= 1 if $i2->nelem() > 0; my $inds=which($s1 == $s2); if ($inds->nelem() > 0) { return $union->index($inds); } else { return $inds; } } elsif ($op eq 'AND') { # The intersection of the arrays. # Make ordered list of set union. my $union = append($x, $y)->qsort; return $union->where($union == rotate($union, -1)); } else { print "The operation $op is not known!"; return -1; } } EOD pp_add_exported("", 'setops'); pp_addpm(<<'EOD'); =head2 intersect =for ref Calculate the intersection of two ndarrays =for usage Usage: $set = intersect($x, $y); This routine is merely a simple interface to L. See that for more information =for example Find all numbers less that 100 that are of the form 2*y and 3*x pdl> $x=sequence(100) pdl> $factor2 = which( ($x % 2) == 0) pdl> $factor3 = which( ($x % 3) == 0) pdl> $ii=intersect($factor2, $factor3) pdl> p $x($ii) [0 6 12 18 24 30 36 42 48 54 60 66 72 78 84 90 96] =cut *intersect = \&PDL::intersect; sub PDL::intersect { return setops($_[0], 'AND', $_[1]); } EOD pp_add_exported("", 'intersect'); pp_addpm({At=>'Bot'},<<'EOD'); =head1 AUTHOR Copyright (C) Tuomas J. Lukka 1997 (lukka@husc.harvard.edu). Contributions by Christian Soeller (c.soeller@auckland.ac.nz), Karl Glazebrook (kgb@aaoepp.aao.gov.au), Craig DeForest (deforest@boulder.swri.edu) and Jarle Brinchmann (jarle@astro.up.pt) 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. Updated for CPAN viewing compatibility by David Mertens. =cut EOD pp_done(); PDL-2.074/Basic/Primitive/xoshiro256plus.c0000644000175000017500000001037214160714722020073 0ustar osboxesosboxes#include #include /* https://prng.di.unimi.it/xoshiro256plus.c, made re-entrant for PDL */ /* Written in 2018 by David Blackman and Sebastiano Vigna (vigna@acm.org) To the extent possible under law, the author has dedicated all copyright and related and neighboring rights to this software to the public domain worldwide. This software is distributed without any warranty. See . */ /* This is xoshiro256+ 1.0, our best and fastest generator for floating-point numbers. We suggest to use its upper bits for floating-point generation, as it is slightly faster than xoshiro256++/xoshiro256**. It passes all tests we are aware of except for the lowest three bits, which might fail linearity tests (and just those), so if low linear complexity is not considered an issue (as it is usually the case) it can be used to generate 64-bit outputs, too. We suggest to use a sign test to extract a random Boolean value, and right shifts to extract subsets of bits. The state must be seeded so that it is not everywhere zero. If you have a 64-bit seed, we suggest to seed a splitmix64 generator and use its output to fill s. */ static inline uint64_t rotl(const uint64_t x, int k) { return (x << k) | (x >> (64 - k)); } /* needs to point at a suitably-initialised 4-long array */ uint64_t xoshiro256plus_next(uint64_t *s) { const uint64_t result = s[0] + s[3]; const uint64_t t = s[1] << 17; s[2] ^= s[0]; s[3] ^= s[1]; s[1] ^= s[2]; s[0] ^= s[3]; s[2] ^= t; s[3] = rotl(s[3], 45); return result; } /* This is the jump function for the generator. It is equivalent to 2^128 calls to next(); it can be used to generate 2^128 non-overlapping subsequences for parallel computations. */ void xoshiro256plus_jump(uint64_t *s) { static const uint64_t JUMP[] = { 0x180ec6d33cfd0aba, 0xd5a61266f0c9392c, 0xa9582618e03fc9aa, 0x39abdc4529b1661c }; uint64_t s0 = 0; uint64_t s1 = 0; uint64_t s2 = 0; uint64_t s3 = 0; int i, b; for(i = 0; i < sizeof JUMP / sizeof *JUMP; i++) for(b = 0; b < 64; b++) { if (JUMP[i] & UINT64_C(1) << b) { s0 ^= s[0]; s1 ^= s[1]; s2 ^= s[2]; s3 ^= s[3]; } xoshiro256plus_next(s); } s[0] = s0; s[1] = s1; s[2] = s2; s[3] = s3; } /* This is the long-jump function for the generator. It is equivalent to 2^192 calls to next(); it can be used to generate 2^64 starting points, from each of which jump() will generate 2^64 non-overlapping subsequences for parallel distributed computations. */ void xoshiro256plus_long_jump(uint64_t *s) { static const uint64_t LONG_JUMP[] = { 0x76e15d3efefdcbbf, 0xc5004e441c522fb3, 0x77710069854ee241, 0x39109bb02acbe635 }; uint64_t s0 = 0; uint64_t s1 = 0; uint64_t s2 = 0; uint64_t s3 = 0; int i, b; for(i = 0; i < sizeof LONG_JUMP / sizeof *LONG_JUMP; i++) for(b = 0; b < 64; b++) { if (LONG_JUMP[i] & UINT64_C(1) << b) { s0 ^= s[0]; s1 ^= s[1]; s2 ^= s[2]; s3 ^= s[3]; } xoshiro256plus_next(s); } s[0] = s0; s[1] = s1; s[2] = s2; s[3] = s3; } /* https://prng.di.unimi.it/splitmix64.c, deleted licence same as above */ /* Written in 2015 by Sebastiano Vigna (vigna@acm.org) */ /* This is a fixed-increment version of Java 8's SplittableRandom generator See http://dx.doi.org/10.1145/2714064.2660195 and http://docs.oracle.com/javase/8/docs/api/java/util/SplittableRandom.html It is a very fast generator passing BigCrush, and it can be useful if for some reason you absolutely want 64 bits of state. */ uint64_t splitmix64_next(uint64_t *x) { uint64_t z = (*x += 0x9e3779b97f4a7c15); z = (z ^ (z >> 30)) * 0xbf58476d1ce4e5b9; z = (z ^ (z >> 27)) * 0x94d049bb133111eb; return z ^ (z >> 31); } int pdl_srand_threads = -1; /* how many threads initialised for */ uint64_t *pdl_rand_state; /* suitably-initialises n 4-long arrays */ void pdl_srand(uint64_t **sptr, uint64_t seed, int n) { uint64_t x = seed, *s = *sptr; if (pdl_srand_threads < n) { if (*sptr) free(*sptr); *sptr = s = malloc(n * 4 * sizeof(*s)); pdl_srand_threads = n; } n *= 4; int i; for (i = 0; i < n; i++) s[i] = splitmix64_next(&x); } double pdl_drand(uint64_t *s) { /* code from https://prng.di.unimi.it/ */ return (xoshiro256plus_next(s) >> 11) * 0x1.0p-53; } PDL-2.074/Basic/Primitive/Makefile.PL0000644000175000017500000000057214160015533017040 0ustar osboxesosboxesuse strict; use warnings; use ExtUtils::MakeMaker; use ExtUtils::MakeMaker::Config; my @pack = (["primitive.pd", qw(Primitive PDL::Primitive)]); my %hash = pdlpp_stdargs_int(@pack); $hash{LIBS}->[0] .= ' -lm'; $hash{OBJECT} .= ' xoshiro256plus$(OBJ_EXT)'; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.074/Basic/LiteF.pm0000644000175000017500000000156014146003631014455 0ustar osboxesosboxespackage PDL::LiteF; use strict; use warnings; =head1 NAME PDL::LiteF - minimum PDL module function loader =head1 DESCRIPTION Loads the smallest possible set of modules for PDL to work, making the functions available in the current namespace. If you want something even smaller see the L module. =head1 SYNOPSIS use PDL::LiteF; # Is equivalent to the following: use PDL::Core; use PDL::Ops; use PDL::Primitive; use PDL::Ufunc; use PDL::Basic; use PDL::Slices; use PDL::Bad; use PDL::Lvalue; =cut require PDL; # get the version our $VERSION = $PDL::VERSION; # Load the fundamental PDL packages, with imports sub import { my $pkg = (caller())[0]; eval <ReadLine() =~ /::Perl$/ ) { if ( defined $readline::rl_MaxHistorySize ) { $readline::rl_MaxHistorySize = $PERLDL::HISTFILESIZE if defined $PERLDL::HISTFILESIZE; } } use PDL::Doc::Perldl; # online docs module 1; PDL-2.074/Basic/Reduce.pm0000644000175000017500000001207514165667771014712 0ustar osboxesosboxes=head1 NAME PDL::Reduce -- a C function for PDL =head1 DESCRIPTION Many languages have a C function used to reduce the rank of an N-D array by one. It works by applying a selected operation along a specified dimension. This module implements such a function for PDL by providing a simplified interface to the existing projection functions (e.g. C, C, C, etc). =head1 SYNOPSIS use PDL::Reduce; $x = sequence 5,5; # reduce by adding all # elements along 2nd dimension $y = $x->reduce('add',1); @ops = $x->canreduce; # return a list of all allowed operations =head1 FUNCTIONS =cut # in a very similar vein we want the following methods # (1) accumulate # (2) outer # what's reduceat ?? # TODO # - aliases (e.g. plus -> add) # - other binary ops? # - allow general subs? package PDL::Reduce; use strict; use warnings; use PDL::Core ''; # barf use PDL::Exporter; our @ISA = qw/PDL::Exporter/; our @EXPORT_OK = qw/reduce canreduce/; our %EXPORT_TAGS = (Func=>[@PDL::Reduce::EXPORT_OK]); # maps operations onto underlying PDL primitives my %reduce = ( add => 'sumover', '+' => 'sumover', plus => 'sumover', mult => 'prodover', '*' => 'prodover', dadd => 'dsumover', dmult => 'dprodover', avg => 'average', davg => 'daverage', and => 'andover', band => 'bandover', bor => 'borover', or => 'orover', median => 'medover', integral => 'intover', max => 'maximum', min => 'minimum', oddmedian => 'oddmedover', iszero => 'zcover', ); =head2 reduce =for ref reduce dimension of ndarray by one by applying an operation along the specified dimension =for example $x = sequence 5,5; # reduce by adding all # elements along 2nd dimension $y = $x->reduce('add',1); $y = $x->reduce('plus',1); $y = $x->reduce('+',1); # three ways to do the same thing [ As an aside: if you are familiar with threading you will see that this is actually the same as $y = $x->mv(1,0)->sumover ] NOTE: You should quote the name of the operation (1st arg) that you want C to perform. This is important since some of the names are identical to the names of the actual PDL functions which might be imported into your namespace. And you definitely want a string as argument, not a function invocation! For example, this will probably fail: $y = $x->reduce(avg,1); # gives an error from invocation of 'avg' Rather use $y = $x->reduce('avg',1); C provides a simple and unified interface to the I functions and makes people coming from other data/array languages hopefully feel more at home. =for usage $result = $pdl->reduce($operation [,@dims]); C applies the named operation along the specified dimension(s) reducing the input ndarray dimension by as many dimensions as supplied as arguments. If the dimension(s) argument is omitted the operation is applied along the first dimension. To get a list of valid operations see L. NOTE - new power user feature: you can now supply a code reference as operation to reduce with. =for example # reduce by summing over dims 0 and 2 $result = $pdl->reduce(\&sumover, 0, 2); It is your responsibility to ensure that this is indeed a PDL projection operation that turns vectors into scalars! You have been warned. =cut *reduce = \&PDL::reduce; sub PDL::reduce ($$;$) { my ($pdl, $op, @dims) = @_; barf "trying to reduce using unknown operation" unless exists $reduce{$op} || ref $op eq 'CODE'; my $dim; if (@dims > 1) { my $n = $pdl->getndims; @dims = map { $_ < 0 ? $_ + $n : $_ } @dims; my $min = $n; my $max = 0; for (@dims) { $min = $_ if $_ < $min; $max = $_ if $_ > $max } barf "dimension out of bounds (one of @dims >= $n)" if $min >= $n || $max >= $n; $dim = $min; # this will be the resulting dim of the clumped ndarray $pdl = $pdl->clump(@dims); } else { $dim = @dims > 0 ? $dims[0] : 0; } if (defined $dim && $dim != 0) { # move the target dim to the front my $n = $pdl->getndims; $dim += $n if $dim < 0; barf "dimension out of bounds" if $dim <0 || $dim >= $n; $pdl = $pdl->mv($dim,0); } my $method = ref $op eq 'CODE' ? $op : $reduce{$op}; return $pdl->$method(); } =head2 canreduce =for ref return list of valid named C operations Some common operations can be accessed using a number of names, e.g. C<'+'>, C and C all sum the elements along the chosen dimension. =for example @ops = PDL->canreduce; This list is useful if you want to make sure which operations can be used with C. =cut *canreduce = \&PDL::canreduce; sub PDL::canreduce { sort keys %reduce; } =head1 AUTHOR Copyright (C) 2000 Christian Soeller (c.soeller@auckland.ac.nz). 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 1; PDL-2.074/Basic/Core/0000755000175000017500000000000014200406301013772 5ustar osboxesosboxesPDL-2.074/Basic/Core/Core.pm0000644000175000017500000031317614176373422015256 0ustar osboxesosboxespackage PDL::Core; # Core routines for PDL module use strict; use warnings; use PDL::Exporter; require PDL; # for $VERSION use DynaLoader; our @ISA = qw( PDL::Exporter DynaLoader ); our $VERSION = '2.028'; # PAUSE insists - below is the real one $VERSION = $PDL::VERSION; bootstrap PDL::Core $VERSION; use PDL::Types ':All'; use Config; use List::Util qw(max); use Scalar::Util 'blessed'; # If quad (q/Q) is available for pack(). our $CAN_PACK_QUAD = !! eval { my $packed = pack "Q", 0; 1 }; # If "D" is available for pack(). our $CAN_PACK_D = !! eval { my $packed = pack "D", 0; 1 }; our @EXPORT = qw( piddle pdl null barf ); # Only stuff always exported! my @convertfuncs = map $_->convertfunc, PDL::Types::types(); my @exports_internal = qw(howbig threadids topdl); my @exports_normal = (@EXPORT, @convertfuncs, qw(nelem dims shape null convert inplace zeroes zeros ones nan inf i list listindices unpdl set at flows thread_define over reshape dog cat barf type dummy mslice approx flat sclr squeeze get_autopthread_targ set_autopthread_targ get_autopthread_actual get_autopthread_dim get_autopthread_size set_autopthread_size) ); our @EXPORT_OK = (@exports_internal, @exports_normal); our %EXPORT_TAGS = ( Func => [@exports_normal], Internal => [@exports_internal] ); our ($level, @dims, $sep, $sep2, $match); # Important variables (place in PDL namespace) # (twice to eat "used only once" warning) $PDL::debug = # Debugging info $PDL::debug = 0; $PDL::verbose = # Functions provide chatty information $PDL::verbose = 0; $PDL::use_commas = 0; # Whether to insert commas when printing arrays $PDL::floatformat = "%7g"; # Default print format for long numbers $PDL::doubleformat = "%10.8g"; $PDL::indxformat = "%12d"; # Default print format for PDL_Indx values $PDL::undefval = 0; # Value to use instead of undef when creating PDLs $PDL::toolongtoprint = 10000; # maximum pdl size to stringify for printing ################ Exportable functions of the Core ###################### *at_c = *at_bad_c; # back-compat alias *howbig = \&PDL::howbig; *unpdl = \&PDL::unpdl; *nelem = \&PDL::nelem; *inplace = \&PDL::inplace; *dims = \&PDL::dims; *list = \&PDL::list; *threadids = \&PDL::threadids; *listindices = \&PDL::listindices; *null = \&PDL::null; *set = \&PDL::set; *at = \&PDL::at; *flows = \&PDL::flows; *sclr = \&PDL::sclr; *shape = \&PDL::shape; for my $t (PDL::Types::types()) { my $conv = $t->convertfunc; no strict 'refs'; *$conv = *{"PDL::$conv"} = sub { return $t unless @_; alltopdl('PDL', (@_>1 ? [@_] : shift), $t); }; } BEGIN { *thread_define = \&PDL::thread_define; *convert = \&PDL::convert; *over = \&PDL::over; *dog = \&PDL::dog; *cat = \&PDL::cat; *type = \&PDL::type; *approx = \&PDL::approx; *dummy = \&PDL::dummy; *mslice = \&PDL::mslice; *isempty = \&PDL::isempty; *string = \&PDL::string; } =head1 NAME PDL::Core - fundamental PDL functionality and vectorization/threading =head1 DESCRIPTION Methods and functions for type conversions, PDL creation, type conversion, threading etc. =head1 SYNOPSIS use PDL::Core; # Normal routines use PDL::Core ':Internal'; # Hairy routines =head1 VECTORIZATION/THREADING: METHOD AND NOMENCLATURE PDL provides vectorized operations via a built-in engine. Vectorization is called "threading" for historical reasons. The threading engine implements simple rules for each operation. Each PDL object has a "shape" that is a generalized N-dimensional rectangle defined by a "dim list" of sizes in an arbitrary set of dimensions. A PDL with shape 2x3 has 6 elements and is said to be two-dimensional, or may be referred to as a 2x3-PDL. The dimensions are indexed numerically starting at 0, so a 2x3-PDL has a dimension 0 (or "dim 0") with size 2 and a 1 dimension (or "dim 1") with size 3. PDL generalizes *all* mathematical operations with the notion of "active dims": each operator has zero or more active dims that are used in carrying out the operation. Simple scalar operations like scalar multiplication ('*') have 0 active dims. More complicated operators can have more active dims. For example, matrix multiplication ('x') has 2 active dims. Additional dims are automatically vectorized across -- e.g. multiplying a 2x5-PDL with a 2x5-PDL requires 10 simple multiplication operations, and yields a 2x5-PDL result. =head2 Threading rules In any PDL expression, the active dims appropriate for each operator are used starting at the 0 dim and working forward through the dim list of each object. All additional dims after the active dims are "thread dims". The thread dims do not have to agree exactly: they are coerced to agree according to simple rules: =over 3 =item * Null PDLs match any dim list (see below). =item * Dims with sizes other than 1 must all agree in size. =item * Dims of size 1 are silently repeated as necessary except for C<[phys]> PDLs. =item * Missing dims are expanded appropriately. =back A size-1 dim for C<[phys]> PDLs causes an exception if the dim is used in another parameter and has a size greater than 1. The "size 1" rule implements "generalized scalar" operation, by analogy to scalar multiplication. The "missing dims" rule acknowledges the ambiguity between a missing dim and a dim of size 1. =head2 Null PDLs PDLs on the left-hand side of assignment can have the special value "Null". A null PDL has no dim list and no set size; its shape is determined by the computed shape of the expression being assigned to it. Null PDLs contain no values and can only be assigned to. When assigned to (e.g. via the C<.=> operator), they cease to be null PDLs. To create a null PDL, use Cnull()>. =head2 Empty PDLs PDLs can represent the empty set using "structured Empty" variables. An empty PDL is not a null PDL. Any dim of a PDL can be set explicitly to size 0. If so, the PDL contains zero values (because the total number of values is the product of all the sizes in the PDL's shape or dimlist). Scalar PDLs are zero-dimensional and have no entries in the dim list, so they cannot be empty. 1-D and higher PDLs can be empty. Empty PDLs are useful for set operations, and are most commonly encountered in the output from selection operators such as L and L. Not all empty PDLs have the same threading properties -- e.g. a 2x0-PDL represents a collection of 2-vectors that happens to contain no elements, while a simple 0-PDL represents a collection of scalar values (that also happens to contain no elements). Note that 0 dims are not adjustable via the threading rules -- a dim with size 0 can only match a corresponding dim of size 0 or 1. =head2 Thread rules and assignments Versions of PDL through 2.4.10 have some irregularity with threading and assignments. Currently the threading engine performs a full expansion of both sides of the computed assignment operator C<.=> (which assigns values to a pre-existing PDL). This leads to counter-intuitive behavior in some cases: =over 3 =item * Generalized scalars and computed assignment If the PDL on the left-hand side of C<.=> has a dim of size 1, it can be treated as a generalized scalar, as in: $x = sequence(2,3); $y = zeroes(1,3); $y .= $x; In this case, C<$y> is automatically treated as a 2x3-PDL during the threading operation, but half of the values from C<$x> silently disappear. The output is, as Kernighan and Ritchie would say, "undefined". Further, if the value on the right of C<.=> is empty, then C<.=> becomes a silent no-op: $x = zeroes(0); $y = zeroes(1); $y .= $x+1; print $y; will print C<[0]>. In this case, "$x+1" is empty, and "$y" is a generalized scalar that is adjusted to be empty, so the assignment is carried out for zero elements (a no-op). Both of these behaviors are considered harmful and should not be relied upon: they may be patched away in a future version of PDL. =item * Empty PDLs and generalized scalars Generalized scalars (PDLs with a dim of size 1) can match any size in the corresponding dim, including 0. Thus, $x = ones(2,0); $y = sequence(2,1); $c = $x * $y; print $c; prints C. This behavior is counterintuitive but desirable, and will be preserved in future versions of PDL. =back =head1 VARIABLES These are important variables of B scope and are placed in the PDL namespace. =head3 C<$PDL::debug> =over 4 When true, PDL debugging information is printed. =back =head3 C<$PDL::verbose> =over 4 When true, PDL functions provide chatty information. =back =head3 C<$PDL::use_commas> =over 4 Whether to insert commas when printing pdls =back =head3 C<$PDL::floatformat>, C<$PDL::doubleformat>, C<$PDL::indxformat> =over 4 The default print format for floats, doubles, and indx values, respectively. The default default values are: $PDL::floatformat = "%7g"; $PDL::doubleformat = "%10.8g"; $PDL::indxformat = "%12d"; =back =head3 C<$PDL::undefval> =over 4 The value to use instead of C when creating pdls. If is C, 0 will be used. =back =head3 C<$PDL::toolongtoprint> =over 4 The maximal size pdls to print (defaults to 10000 elements) =back =head1 FUNCTIONS =head2 barf =for ref Standard error reporting routine for PDL. C is the routine PDL modules should call to report errors. This is because C will report the error as coming from the correct line in the module user's script rather than in the PDL module. For now, barf just calls Carp::confess() Remember C is your friend. *Use* it! =for example At the perl level: barf("User has too low an IQ!"); In C or XS code: barf("You have made %d errors", count); Note: this is one of the few functions ALWAYS exported by PDL::Core =cut use Carp; sub barf { goto &Carp::confess } sub cluck { goto &Carp::cluck } *PDL::barf = \&barf; *PDL::cluck = \&cluck; ########## Set Auto-PThread Based On Environment Vars ############ $ENV{PDL_AUTOPTHREAD_TARG} //= online_cpus(); PDL::set_autopthread_targ( $ENV{PDL_AUTOPTHREAD_TARG} ) if $ENV{PDL_AUTOPTHREAD_TARG} > 1; PDL::set_autopthread_size( $ENV{PDL_AUTOPTHREAD_SIZE} ) if( defined ( $ENV{PDL_AUTOPTHREAD_SIZE} ) ); ################################################################## =head2 pdl =for ref PDL constructor - creates new ndarray from perl scalars/arrays, ndarrays, and strings =for usage $double_pdl = pdl(SCALAR|ARRAY REFERENCE|ARRAY|STRING); # default type $type_pdl = pdl(PDL::Type,SCALAR|ARRAY REFERENCE|ARRAY|STRING); =for example $x = pdl [1..10]; # 1D array of doubles $x = pdl ([1..10]); # 1D array $x = pdl (1,2,3,4); # Ditto $y = pdl [[1,2,3],[4,5,6]]; # 2D 3x2 array $y = pdl "[[1,2,3],[4,5,6]]"; # Ditto (slower) $y = pdl "[1 2 3; 4 5 6]"; # Ditto $y = pdl q[1 2 3; 4 5 6]; # Ditto, using the q quote operator $y = pdl "1 2 3; 4 5 6"; # Ditto, less obvious, but still works $y = pdl 42 # 0-dimensional scalar $c = pdl $x; # Make a new copy $u = pdl ushort(), 42 # 0-dimensional ushort scalar $y = pdl(byte(),[[1,2,3],[4,5,6]]); # 2D byte ndarray $n = pdl indx(), [1..5]; # 1D array of indx values $n = pdl indx, [1..5]; # ... can leave off parens $n = indx( [1..5] ); # ... still the same! $n = pdl cdouble, 2, 3; # native complex numbers, zero imaginary use Math::Complex qw(cplx); $n = pdl cdouble, 2, cplx(2, 1)); # explicit type $n = pdl 2, cplx(2, 1); # default cdouble if Math::Complex obj $x = pdl([[1,2,3],[4,5,6]]); # 2D $x = pdl([1,2,3],[4,5,6]); # 2D Note the last two are equivalent - a list is automatically converted to a list reference for syntactic convenience. i.e. you can omit the outer C<[]> You can mix and match arrays, array refs, and PDLs in your argument list, and C will sort them out. You get back a PDL whose last (slowest running) dim runs across the top level of the list you hand in, and whose first (fastest running) dim runs across the deepest level that you supply. At the moment, you cannot mix and match those arguments with string arguments, though we can't imagine a situation in which you would really want to do that. The string version of pdl also allows you to use the strings C, C, and C, and it will insert the values that you mean (and set the bad flag if you use C). You can mix and match case, though you shouldn't. Here are some examples: $bad = pdl q[1 2 3 bad 5 6]; # Set fourth element to the bad value $bad = pdl q[1 2 3 BAD 5 6]; # ditto $bad = pdl q[1 2 inf bad 5]; # now third element is IEEE infinite value $bad = pdl q[nan 2 inf -inf]; # first value is IEEE nan value The default constructor uses IEEE double-precision floating point numbers. You can use other types, but you will get a warning if you try to use C with integer types (it will be replaced with the C value) and you will get a fatal error if you try to use C. Throwing a PDL into the mix has the same effect as throwing in a list ref: pdl(pdl(1,2),[3,4]) is the same as pdl([1,2],[3,4]). All of the dimensions in the list are "padded-out" with undefval to meet the widest dim in the list, so (e.g.) $x = pdl([[1,2,3],[2]]) gives you the same answer as $x = pdl([[1,2,3],[2,undef,undef]]); If your PDL module has bad values compiled into it (see L), you can pass BAD values into the constructor within pre-existing PDLs. The BAD values are automatically kept BAD and propagated correctly. C is a functional synonym for the 'new' constructor, e.g.: $x = new PDL [1..10]; In order to control how undefs are handled in converting from perl lists to PDLs, one can set the variable C<$PDL::undefval>. For example: $foo = [[1,2,undef],[undef,3,4]]; $PDL::undefval = -999; $f = pdl $foo; print $f [ [ 1 2 -999] [-999 3 4] ] C<$PDL::undefval> defaults to zero. As a final note, if you include an Empty PDL in the list of objects to construct into a PDL, it is kept as a placeholder pane -- so if you feed in (say) 7 objects, you get a size of 7 in the 0th dim of the output PDL. The placeholder panes are completely padded out. But if you feed in only a single Empty PDL, you get back the Empty PDL (no padding). =cut =head2 null =for ref Returns a 'null' ndarray. It is an error to pass one of these as an input to a function. =for usage $x = null; C has a special meaning to L. It is used to flag a special kind of empty ndarray, which can grow to appropriate dimensions to store a result (as opposed to storing a result in an existing ndarray). =for example pdl> sumover sequence(10,10), $ans=null;p $ans [45 145 245 345 445 545 645 745 845 945] =cut sub PDL::null{ my $class = scalar(@_) ? shift : undef; # if this sub called with no # class ( i.e. like 'null()', instead # of '$obj->null' or 'CLASS->null', setup if( defined($class) ){ $class = ref($class) || $class; # get the class name } else{ $class = 'PDL'; # set class to the current package name if null called # with no arguments } return $class->initialize(); } =head2 nullcreate =for ref Returns a 'null' ndarray. =for usage $x = PDL->nullcreate($arg) This is an routine used by many of the threading primitives (i.e. L, L, etc.) to generate a null ndarray for the function's output that will behave properly for derived (or subclassed) PDL objects. For the above usage: If C<$arg> is a PDL, or a derived PDL, then C<$arg-Enull> is returned. If C<$arg> is a scalar (i.e. a zero-dimensional PDL) then Cnull> is returned. =for example PDL::Derived->nullcreate(10) returns PDL::Derived->null. PDL->nullcreate($pdlderived) returns $pdlderived->null. =cut sub PDL::nullcreate{ my ($type,$arg) = @_; return ref($arg) ? $arg->null : $type->null ; } =head2 nelem =for ref Return the number of elements in an ndarray =for usage $n = nelem($ndarray); $n = $ndarray->nelem; =for example $mean = sum($data)/nelem($data); =head2 dims =for ref Return ndarray dimensions as a perl list =for usage @dims = $ndarray->dims; @dims = dims($ndarray); =for example pdl> p @tmp = dims zeroes 10,3,22 10 3 22 See also L which returns an ndarray instead. =head2 shape =for ref Return ndarray dimensions as an ndarray =for usage $shape = $ndarray->shape; $shape = shape($ndarray); =for example pdl> p $shape = shape zeroes 10,3,22 [10 3 22] See also L which returns a perl list. =head2 ndims =for ref Returns the number of dimensions in an ndarray. Alias for L. =head2 getndims =for ref Returns the number of dimensions in an ndarray =for usage $ndims = $ndarray->getndims; =for example pdl> p zeroes(10,3,22)->getndims 3 =head2 dim =for ref Returns the size of the given dimension of an ndarray. Alias for L. =head2 getdim =for ref Returns the size of the given dimension. =for usage $dim0 = $ndarray->getdim(0); =for example pdl> p zeroes(10,3,22)->getdim(1) 3 Negative indices count from the end of the dims array. Indices beyond the end will return a size of 1. This reflects the idea that any pdl is equivalent to an infinitely dimensional array in which only a finite number of dimensions have a size different from one. For example, in that sense a 3D ndarray of shape [3,5,2] is equivalent to a [3,5,2,1,1,1,1,1,....] ndarray. Accordingly, print $x->getdim(10000); will print 1 for most practically encountered ndarrays. =head2 topdl =for ref alternate ndarray constructor - ensures arg is an ndarray =for usage $x = topdl(SCALAR|ARRAY REFERENCE|ARRAY); The difference between L and C is that the latter will just 'fall through' if the argument is already an ndarray. It will return a reference and I a new copy. This is particularly useful if you are writing a function which is doing some fiddling with internals and assumes an ndarray argument (e.g. for method calls). Using C will ensure nothing breaks if passed with '2'. Note that C is not exported by default (see example below for usage). =for example use PDL::Core ':Internal'; # use the internal routines of # the Core module $x = topdl 43; # $x is ndarray with value '43' $y = topdl $ndarray; # fall through $x = topdl (1,2,3,4); # Convert 1D array =head2 get_datatype =for ref Internal: Return the numeric value identifying the ndarray datatype =for usage $x = $ndarray->get_datatype; Mainly used for internal routines. NOTE: get_datatype returns 'just a number' not any special type object, unlike L. =head2 howbig =for ref Returns the sizeof an ndarray datatype in bytes. Note that C is not exported by default (see example below for usage). =for usage use PDL::Core ':Internal'; # use the internal routines of # the Core module $size = howbig($ndarray->get_datatype); Mainly used for internal routines. NOTE: NOT a method! This is because get_datatype returns 'just a number' not any special object. =for example pdl> p howbig(ushort([1..10])->get_datatype) 2 =head2 get_dataref =for ref Return the internal data for an ndarray, as a perl SCALAR ref. Most ndarrays hold their internal data in a packed perl string, to take advantage of perl's memory management. This gives you direct access to the string, which is handy when you need to manipulate the binary data directly (e.g. for file I/O). If you modify the string, you'll need to call L afterward, to make sure that the ndarray points to the new location of the underlying perl variable. Calling C automatically physicalizes your ndarray (see L). You definitely don't want to do anything to the SV to truncate or deallocate the string, unless you correspondingly call L to make the PDL match its new data dimension. You definitely don't want to use get_dataref unless you know what you are doing (or are trying to find out): you can end up scrozzling memory if you shrink or eliminate the string representation of the variable. Here be dragons. =head2 upd_data =for ref Update the data pointer in an ndarray to match its perl SV. This is useful if you've been monkeying with the packed string representation of the PDL, which you probably shouldn't be doing anyway. (see L.) =cut sub topdl {PDL->topdl(@_)} ####################### Overloaded operators ####################### { package PDL; use overload '""' => \&PDL::Core::string; } ##################### Data type/conversion stuff ######################## sub PDL::dims { # Return dimensions as @list PDL->topdl(shift)->dims_c; } sub PDL::shape { # Return dimensions as a pdl indx([PDL->topdl(shift)->dims]); } sub PDL::howbig { my $t = shift; if("PDL::Type" eq ref $t) {$t = $t->[0]} PDL::howbig_c($t); } =head2 threadids =for ref Returns the ndarray thread IDs as a perl list Note that C is not exported by default (see example below for usage). =for usage use PDL::Core ':Internal'; # use the internal routines of # the Core module @ids = threadids $ndarray; =cut sub PDL::threadids { # Return dimensions as @list PDL->topdl(shift)->threadids_c; } ################# Creation/copying functions ####################### sub piddle {PDL->pdl(@_)} sub pdl {PDL->pdl(@_)} sub PDL::pdl { my $x = shift; return $x->new(@_) } =head2 doflow =for ref Turn on dataflow, forward only. This means any transformations (a.k.a. PDL operations) applied to this ndarray afterwards will have forward dataflow: $x = sequence 3; $x->doflow; $y = $x + 1; $x += 3; print "$y\n"; # [4 5 6] As of 2.064, the core API does I automatically sever transformations that have forward dataflow into them: # following from the above $y->set(1, 9); # value now [4 9 6] $x += 11; print "$y\n"; # [15 16 17] - previously would have been [4 9 6] If you want to sever such transformations, call L on the child ndarray (above, C<$y>). =for usage $x->doflow; doflow($x); =cut sub PDL::doflow { my $this = shift; $this->set_dataflow_f(1); } =head2 flows =for ref Whether or not an ndarray is indulging in dataflow =for usage something if $x->flows; $hmm = flows($x); =cut sub PDL::flows { my $this = shift; return ($this->fflows || $this->bflows); } =head2 new =for ref new ndarray constructor method =for usage $x = PDL->new(SCALAR|ARRAY|ARRAY REF|STRING); =for example $x = PDL->new(42); # new from a Perl scalar $x = new PDL 42; # ditto $y = PDL->new(@list_of_vals); # new from Perl list $y = new PDL @list_of_vals; # ditto $z = PDL->new(\@list_of_vals); # new from Perl list reference $w = PDL->new("[1 2 3]"); # new from Perl string, using # Matlab constructor syntax Constructs ndarray from perl numbers and lists and strings with Matlab/Octave style constructor syntax. The string input is fairly versatile though not performance optimized. The goal is to make it easy to copy and paste code from PDL output and to offer a familiar Matlab syntax for ndarray construction. As of May, 2010, it is a new feature, so feel free to report bugs or suggest new features. See documentation for L for more examples of usage. =cut use Scalar::Util; # for looks_like_number test use Carp 'carp'; # for carping (warnings in caller's context) # This is the code that handles string arguments. It has now gotten quite large, # so here's the basic explanation. I want to allow expressions like 2, 1e3, +4, # bad, nan, inf, and more. Checking this can get tricky. This croaks when it # finds: # 1) strings of e or E that are longer than 1 character long (like eeee) # 2) non-supported characters or strings # 3) expressions that are syntactically erroneous, like '1 2 3 ]', which has an # extra bracket # 4) use of inf when the data type does not support inf (i.e. the integers) my @types = PDL::Types::types; sub PDL::Core::new_pdl_from_string { my ($new, $original_value, $this, $type) = @_; my $value = $original_value; # Check for input that would generate empty ndarrays as output: return zeroes($types[$type], 1)->where(zeroes(1) < 0) if ($value eq '' or $value eq '[]'); # I check for invalid characters later, but arbitrary strings of e will # pass that check, so I'll check for that here, first. croak("PDL::Core::new_pdl_from_string: found 'e' as part of a larger word in $original_value") if $value =~ /e\p{IsAlpha}|\p{IsAlpha}e/; # Only a few characters are allowed in the expression, but we want to allow # expressions like 'inf' and 'bad'. As such, convert those values to internal # representations that will pass the invalid-character check. We'll replace # them with Perl-evalute-able strings in a little bit. Here, I represent # bad => EE # nan => ee # inf => Ee # pi => eE # i => EeE # --( Bad )-- croak("PDL::Core::new_pdl_from_string: found 'bad' as part of a larger word in $original_value") if $value =~ /bad\B|\Bbad/; my ($has_bad) = ($value =~ s/\bbad\b/EE/gi); # --( nan )-- my $has_nan = 0; croak("PDL::Core::new_pdl_from_string: found 'nan' as part of a larger word in $original_value") if $value =~ /\Bnan|nan\B/; $has_nan++ if ($value =~ s/\bnan\b/ee/gi); # Strawberry Perl compatibility: croak("PDL::Core::new_pdl_from_string: found '1.#IND' as part of a larger word in $original_value") if $value =~ /IND\B/i; $has_nan++ if ($value =~ s/1\.\#IND/ee/gi); # --( inf )-- my $has_inf = 0; # Strawberry Perl compatibility: croak("PDL::Core::new_pdl_from_string: found '1.#INF' as part of a larger word in $original_value") if $value =~ /INF\B/i; $has_inf++ if ($value =~ s/1\.\#INF/Ee/gi); # Other platforms: croak("PDL::Core::new_pdl_from_string: found 'inf' as part of a larger word in $original_value") if $value =~ /inf\B|\Binf/; $has_inf++ if ($value =~ s/\binf\b/Ee/gi); # --( pi )-- croak("PDL::Core::new_pdl_from_string: found 'pi' as part of a larger word in $original_value") if $value =~ /pi\B|\Bpi/; $value =~ s/\bpi\b/eE/gi; # --( i )-- my $has_i = 0; croak("PDL::Core::new_pdl_from_string: found 'i' as part of a larger word ($1) in $original_value") if $value =~ /(i\B|[^\-+\d\s.\[]i)/; $has_i++ if ($value =~ s/([\-+\d]*)i\b/${1}EeE/gi); $type = $types[$type]->complexversion->enum if $has_i; # Some data types do not support nan and inf, so check for and warn or croak, # as appropriate: if ($has_nan and not $types[$type]->usenan) { carp("PDL::Core::new_pdl_from_string: no nan for type $types[$type]; converting to bad value"); $value =~ s/ee/EE/g; $has_bad += $has_nan; $has_nan = 0; } croak("PDL::Core::new_pdl_from_string: type $types[$type] does not support inf") if ($has_inf and not $types[$type]->usenan); # Make the white-space uniform and see if any not-allowed characters are # present: $value =~ s/\s+/ /g; if (my ($disallowed) = ($value =~ /([^\[\]\+\-0-9;,.eE ]+)/)) { croak("PDL::Core::new_pdl_from_string: found disallowed character(s) '$disallowed' in '$original_value', value now: '$value'"); } # Wrap the string in brackets [], so that the following works: # $x = new PDL q[1 2 3]; # We'll have to check for dimensions of size one after we've parsed # the string and built a PDL from the resulting array. $value = '[' . $value . ']'; # Make sure that each closing bracket followed by an opening bracket # has a comma in between them: $value =~ s/\]\s*\[/],[/g; # Semicolons indicate 'start a new row' and require special handling: if ($value =~ /;/) { $value =~ s/(\[[^\]]+;[^\]]+\])/[$1]/g; $value =~ s/;/],[/g; } # Remove ending decimal points and insert zeroes in front of starting # decimal points. This makes the white-space-to-comma replacement # in the next few lines much simpler. $value =~ s/(\d\.)(z|[^\d])/${1}0$2/g; $value =~ s/(\A|[^\d])\./${1}0./g; # Remove whitespace between signs and the numbers that follow them: $value =~ s/([+\-])\s+/$1/g; # Replace whitespace separators with commas: $value =~ s/([.\de])\s+(?=[+\-e\d])/$1,/gi; # Remove all other white space: $value =~ s/\s+//g; # Croak on operations with bad values. It might be nice to simply replace # these with bad values, but that is more difficult that I like, so I'm just # going to disallow that here: croak("PDL::Core::new_pdl_from_string: Operations with bad values are not supported") if($value =~ /EE[+\-]|[+\-]EE/); # Check for things that will evaluate as functions and croak if found if (my ($disallowed) = ($value =~ /((\D+|\A)[eE]\d+)/)) { croak("PDL::Core::new_pdl_from_string: syntax error, looks like an improper exponentiation: $disallowed\n" . "You originally gave me $original_value\n"); } # Replace the place-holder strings with strings that will evaluate to their # correct numerical values my $bad = $types[$type]->badvalue; $value =~ s/\bEE\b/bad/g; my $nan = PDL::_nan(); $value =~ s/\bee\b/nan/g; my $i = PDL::_ci(); $value =~ s/([-+]*)(\d*)EeE\b/$1 . (length($2) ? $2 : '1') . 'i'/ge if $has_i; my $inf = PDL::_inf(); $value =~ s/\bEe\b/inf/g; my $pi = 4 * atan2(1, 1); $value =~ s/\beE\b/pi/g; my $e = exp(1); my $val = eval { # Install the warnings handler: my $old_warn_handler = $SIG{__WARN__}; local $SIG{__WARN__} = sub { if ($_[0] =~ /(Argument ".*" isn't numeric)/) { # Send the error through die. This *always* gets caught, so keep # it simple. die "Incorrectly formatted input: $1\n"; } elsif ($old_warn_handler) { $old_warn_handler->(@_); } else { warn @_; } }; # Let's see if we can parse it as an array-of-arrays: local $_ = $value; PDL::Core::parse_basic_string($inf, $nan, $bad, $e, $pi, $i, $has_i); }; if (ref $val ne 'ARRAY') { my @message = ("PDL::Core::new_pdl_from_string: string input='$original_value', string output='$value'" ); push @message, $@ || "Internal error: unexpected output type ->$val<- is not ARRAY ref"; croak join("\n ", @message); } my $to_return = PDL::Core::pdl_avref($val,$this,$type); if( $to_return->dim(-1) == 1 ) { if( $to_return->dims > 1 ) { # remove potentially spurious last dimension $to_return = $to_return->mv(-1,1)->clump(2)->sever; } elsif( $to_return->dims == 1 ) { # fix scalar values $to_return->setdims([]); } } # Mark bad if appropriate $to_return->badflag($has_bad > 0); return $to_return; } my $NUM_RE = qr/(\d+(?:\.\d+)?(?:e[-+]?\d+)?)/i; sub PDL::Core::parse_basic_string { # Assumes $_ holds the string of interest, and modifies that value # in-place. use warnings; # Takes a string with proper bracketing, etc, and returns an array-of-arrays # filled with numbers, suitable for use with pdl_avref. It uses recursive # descent to handle the nested nature of the data. The string should have # no whitespace and should be something that would evaluate into a Perl # array-of-arrays (except that strings like 'inf', etc, are allowed). my ($inf, $nan, $bad, $e, $pi, $i, $has_i) = @_; # First character should be a bracket: die "Internal error: input string -->$_<-- did not start with an opening bracket\n" unless s/^\[//; my @to_return; # Loop until we run into our closing bracket: my $sign = 1; my $expects_number = 0; SYMBOL: until (s/^\]//) { # If we have a bracket, then go recursive: if (/^\[/) { die "Expected a number but found a bracket at ... ", substr ($_, 0, 10), "...\n" if $expects_number; push @to_return, PDL::Core::parse_basic_string(@_); next SYMBOL; } elsif (s/^\+//) { die "Expected number but found a plus sign at ... ", substr ($_, 0, 10), "...\n" if $expects_number; $expects_number = 1; redo SYMBOL; } elsif (s/^\-//) { die "Expected number but found a minus sign at ... ", substr ($_, 0, 10), "...\n" if $expects_number; $sign = -1; $expects_number = 1; redo SYMBOL; } elsif (s/^bad//i) { push @to_return, $bad; } elsif (s/^inf//i or s/1\.\#INF//i) { push @to_return, $sign * $inf; } elsif (s/^nan//i or s/^1\.\#IND//i) { push @to_return, $sign * $nan; } elsif (s/^pi//i) { push @to_return, $sign * $pi; } elsif (s/^e//i) { push @to_return, $sign * $e; } elsif ($has_i and s/^${NUM_RE}i//i) { my $val = $sign * $1 * $i; push @to_return, $val; } elsif ($has_i and s/^$NUM_RE([-+])${NUM_RE}i//i) { my $val = $sign * $1; my $imag = $3 * ($2 eq '-' ? -1 : 1) * $i; push @to_return, $val + $imag; } elsif (s/^$NUM_RE([^e])/$2/i) { # Note that improper numbers are handled by the warning signal # handler push @to_return, $sign * ($1 + 0x0); } else { die "Incorrectly formatted input at:\n ", substr($_, 0, 10), "...\n"; } } # Strip off any commas continue { $sign = 1; $expects_number = 0; s/^,//; } return \@to_return; } my $MAX_TYPE = $types[-1]->enum; # use lexical @types from above sub _establish_type { my ($item, $sofar) = @_; barf("Error: $sofar > max type value($MAX_TYPE)") if $sofar > $MAX_TYPE; return $sofar if $sofar == $MAX_TYPE; return $PDL_CD if UNIVERSAL::isa($item, 'Math::Complex'); return max($item->type->enum, $sofar) if UNIVERSAL::isa($item, 'PDL'); return $PDL_D if ref($item) ne 'ARRAY'; # only need to check first item for an array of complex vals return $MAX_TYPE if _establish_type($item->[0], $sofar) == $MAX_TYPE; # only need to recurse for items that are refs # as $sofar will be $PDL_D at a minimum max ($sofar, map _establish_type($_, $sofar), grep ref, @$item); } sub PDL::new { # print "in PDL::new\n"; my $this = shift; return $this->copy if ref($this); my $type = ref($_[0]) eq 'PDL::Type' ? shift->enum : undef; my $value = (@_ >1 ? [@_] : shift); # ref thyself unless(defined $value) { if($PDL::debug) { print STDERR "Warning: PDL::new converted undef to \$PDL::undefval ($PDL::undefval)\n"; } $value = ($PDL::undefval//0)+0 } $type //= ref($value) ? _establish_type($value, $PDL_D) : $PDL_D; return pdl_avref($value,$this,$type) if ref($value) eq "ARRAY"; my $new = $this->initialize(); $new->set_datatype($type); if (ref(\$value) eq "SCALAR") { # The string processing is extremely slow. Benchmarks indicated that it # takes 10x longer to process a scalar number compared with normal Perl # conversion of a string to a number. So, only use the string processing # if the input looks like a real string, i.e. it doesn't look like a plain # number. Note that for our purposes, looks_like_number incorrectly # handles the strings 'inf' and 'nan' on Windows machines. We want to send # those to the string processing, so this checks for them in a way that # short-circuits the looks_like_number check. if (PDL::Core::is_scalar_SvPOK($value) and ($value =~ /inf/i or $value =~ /nan/i or !Scalar::Util::looks_like_number($value))) { # new was passed a string argument that doesn't look like a number # so we can process as a Matlab-style data entry format. return PDL::Core::new_pdl_from_string($new,$value,$this,$type); } elsif (! $CAN_PACK_QUAD && $pack[$new->get_datatype] =~ /^q\*$/i ) { # special case when running on a perl without 64bit int support # we have to avoid pack("q", ...) in this case # because it dies with error: "Invalid type 'q' in pack" $new->setdims([]); set_c($new, [0], $value); } elsif (! $CAN_PACK_D && $pack[$new->get_datatype] =~ /^(\QD*\E|\Q(DD)*\E)$/ ) { # if "D" is not available for pack(), # it dies with error: "Invalid type 'D' in pack". $new->setdims([]); set_c($new, [0], $value); } else { $new->setdims([]); ${$new->get_dataref} = pack( $pack[$new->get_datatype], $value ); $new->upd_data; } } elsif (blessed($value)) { # Object $new = $value->copy; } else { barf("Can not interpret argument $value of type ".ref($value) ); } return $new; } =head2 copy =for ref Make a physical copy of an ndarray =for usage $new = $old->copy; Since C<$new = $old> just makes a new reference, the C method is provided to allow real independent copies to be made. =cut sub PDL::copy { my $value = shift; barf("Argument is an ".ref($value)." not an object") unless blessed($value); # threadI(-1,[]) is just an identity vafftrans with threadId copying ;) $value->threadI(-1,[])->sever; } =head2 hdr_copy =for ref Return an explicit copy of the header of a PDL. hdr_copy is just a wrapper for the internal routine _hdr_copy, which takes the hash ref itself. That is the routine which is used to make copies of the header during normal operations if the hdrcpy() flag of a PDL is set. General-purpose deep copies are expensive in perl, so some simple optimization happens: If the header is a tied array or a blessed hash ref with an associated method called C, then that ->copy method is called. Otherwise, all elements of the hash are explicitly copied. References are recursively deep copied. This routine seems to leak memory. =cut sub PDL::hdr_copy { my $pdl = shift; my $hdr = $pdl->gethdr; return PDL::_hdr_copy($hdr); } # Same as hdr_copy but takes a hash ref instead of a PDL. sub PDL::_hdr_copy { my $hdr = shift; my $tobj; print "called _hdr_copy\n" if($PDL::debug); unless( (ref $hdr)=~m/HASH/ ) { print"returning undef\n" if($PDL::debug); return undef ; } if($tobj = tied %$hdr) { # print "tied..."if($PDL::debug); if(UNIVERSAL::can($tobj,"copy")) { my %rhdr; tie(%rhdr, ref $tobj, $tobj->copy); print "returning\n" if($PDL::debug); return \%rhdr; } # Astro::FITS::Header is special for now -- no copy method yet # but it is recognized. Once it gets a copy method this will become # vestigial: if(UNIVERSAL::isa($tobj,"Astro::FITS::Header")) { print "Astro::FITS::Header..." if($PDL::debug); my @cards = $tobj->cards; my %rhdr; tie(%rhdr,"Astro::FITS::Header", new Astro::FITS::Header(Cards=>\@cards)); print "returning\n" if($PDL::debug); return \%rhdr; } } elsif(UNIVERSAL::can($hdr,"copy")) { print "found a copy method\n" if($PDL::debug); return $hdr->copy; } # We got here if it's an unrecognized tie or if it's a vanilla hash. print "Making a hash copy..." if($PDL::debug); return PDL::_deep_hdr_copy($hdr); } # # Sleazy deep-copier that gets most cases # --CED 14-April-2003 # sub PDL::_deep_hdr_copy { my $val = shift; if(ref $val eq 'HASH') { my %a; @a{keys %$val} = map ref($_) ? PDL::_deep_hdr_copy($_) : $_, values %$val; return \%a; } return [map ref($_) ? PDL::_deep_hdr_copy($_) : $_, @$val] if ref $val eq 'ARRAY'; if(ref $val eq 'SCALAR') { my $x = $$val; return \$x; } if(ref $val eq 'REF') { my $x = PDL::_deep_hdr_copy($$val); return \$x; } # Special case for PDLs avoids potential nasty header recursion... if(UNIVERSAL::isa($val,'PDL')) { my $h; $val->hdrcpy(0) if($h = $val->hdrcpy); # assignment my $out = $val->copy; $val->hdrcpy($h) if($h); return $out; } if(UNIVERSAL::can($val,'copy')) { return $val->copy; } $val; } =head2 unwind =for ref Return an ndarray which is the same as the argument except that all threadids have been removed. =for usage $y = $x->unwind; =head2 make_physical =for ref Make sure the data portion of an ndarray can be accessed from XS code. =for example $x->make_physical; $x->call_my_xs_method; Ensures that an ndarray gets its own allocated copy of data. This obviously implies that there are certain ndarrays which do not have their own data. These are so called I ndarrays that make use of the I optimisation (see L). They do not have their own copy of data but instead store only access information to some (or all) of another ndarray's data. Note: this function should not be used unless absolutely necessary since otherwise memory requirements might be severely increased. Instead of writing your own XS code with the need to call C you might want to consider using the PDL preprocessor (see L) which can be used to transparently access virtual ndarrays without the need to physicalise them (though there are exceptions). =cut sub PDL::unwind { my $value = shift; my $foo = $value->null(); $foo .= $value->unthread(); return $foo; } =head2 dummy =for ref Insert a 'dummy dimension' of given length (defaults to 1) No relation to the 'Dungeon Dimensions' in Discworld! Negative positions specify relative to last dimension, i.e. C appends one dimension at end, C inserts a dummy dimension in front of the last dim, etc. If you specify a dimension position larger than the existing dimension list of your PDL, the PDL gets automagically padded with extra dummy dimensions so that you get the dim you asked for, in the slot you asked for. This could cause you trouble if, for example, you ask for $x->dummy(5000,1) because $x will get 5,000 dimensions, each of rank 1. Because padding at the beginning of the dimension list moves existing dimensions from slot to slot, it's considered unsafe, so automagic padding doesn't work for large negative indices -- only for large positive indices. =for usage $y = $x->dummy($position[,$dimsize]); =for example pdl> p sequence(3)->dummy(0,3) [ [0 0 0] [1 1 1] [2 2 2] ] pdl> p sequence(3)->dummy(3,2) [ [ [0 1 2] ] [ [0 1 2] ] ] pdl> p sequence(3)->dummy(-3,2) Runtime error: PDL: For safety, < -(dims+1) forbidden in dummy. min=-2, pos=-3 =cut sub PDL::dummy($$;$) { my ($pdl,$dim,$size) = @_; barf("Missing position argument to dummy()") unless defined $dim; # required argument $dim = $pdl->getndims+1+$dim if $dim < 0; $size = defined($size) ? (1 * $size) : 1; # make $size a number (sf feature # 3479009) barf("For safety, < -(dims+1) forbidden in dummy. min=" . -($pdl->getndims+1).", pos=". ($dim-1-$pdl->getndims) ) if($dim<0); # Avoid negative repeat count warning that came with 5.21 and later. my $dim_diff = $dim - $pdl->getndims; my($s) = ',' x ( $dim_diff > 0 ? $pdl->getndims : $dim ); $s .= '*1,' x ( $dim_diff > 0 ? $dim_diff : 0 ); $s .= "*$size"; $pdl->slice($s); } =head2 clump =for ref "clumps" several dimensions into one large dimension If called with one argument C<$n> clumps the first C<$n> dimensions into one. For example, if C<$x> has dimensions C<(5,3,4)> then after =for example $y = $x->clump(2); # Clump 2 first dimensions the variable C<$y> will have dimensions C<(15,4)> and the element C<$y-Eat(7,3)> refers to the element C<$x-Eat(1,2,3)>. Use C to flatten an ndarray. The method L is provided as a convenient alias. Clumping with a negative dimension in general leaves that many dimensions behind -- e.g. clump(-2) clumps all of the first few dimensions into a single one, leaving a 2-D ndarray. If C is called with an index list with more than one element it is treated as a list of dimensions that should be clumped together into one. The resulting clumped dim is placed at the position of the lowest index in the list. This convention ensures that C does the expected thing in the usual cases. The following example demonstrates typical usage: $x = sequence 2,3,3,3,5; # 5D ndarray $c = $x->clump(1..3); # clump all the dims 1 to 3 into one print $c->info; # resulting 3D ndarray has clumped dim at pos 1 PDL: Double D [2,27,5] =cut sub PDL::clump { goto &PDL::_clump_int if @_ < 3; my ($this,@dims) = @_; my $ndims = $this->getndims; my $targd = $ndims-1; my @dimmark = (0..$ndims-1); barf "too many dimensions" if @dims > $ndims; for my $dim (@dims) { barf "dimension index $dim larger than greatest dimension" if $dim > $ndims-1 ; $targd = $dim if $targd > $dim; barf "duplicate dimension $dim" if $dimmark[$dim]++ > $dim; } my $clumped = $this->thread(@dims)->unthread(0)->clump(scalar @dims); $clumped = $clumped->mv(0,$targd) if $targd > 0; return $clumped; } =head2 thread_define =for ref define functions that support threading at the perl level =for example thread_define 'tline(a(n);b(n))', over { line $_[0], $_[1]; # make line compliant with threading }; C provides some support for threading (see L) at the perl level. It allows you to do things for which you normally would have resorted to PDL::PP (see L); however, it is most useful to wrap existing perl functions so that the new routine supports PDL threading. C is used to define new I functions. Its first argument is a symbolic repesentation of the new function to be defined. The string is composed of the name of the new function followed by its signature (see L and L) in parentheses. The second argument is a subroutine that will be called with the slices of the actual runtime arguments as specified by its signature. Correct dimension sizes and minimal number of dimensions for all arguments will be checked (assuming the rules of PDL threading, see L). The actual work is done by the C class which parses the signature string, does runtime dimension checks and the routine C that generates the loop over all appropriate slices of pdl arguments and creates pdls as needed. Similar to C and its C option it is possible to define the new function so that it accepts normal perl args as well as ndarrays. You do this by using the C parameter in the signature. The number of C specified will be passed unaltered into the subroutine given as the second argument of C. Let's illustrate this with an example: PDL::thread_define 'triangles(inda();indb();indc()), NOtherPars => 2', PDL::over { ${$_[3]} .= $_[4].join(',',map {$_->at} @_[0..2]).",-1,\n"; }; This defines a function C that takes 3 ndarrays as input plus 2 arguments which are passed into the routine unaltered. This routine is used to collect lists of indices into a perl scalar that is passed by reference. Each line is preceded by a prefix passed as C<$_[4]>. Here is typical usage: $txt = ''; triangles(pdl(1,2,3),pdl(1),pdl(0),\$txt," "x10); print $txt; resulting in the following output 1,1,0,-1, 2,1,0,-1, 3,1,0,-1, which is used in L to generate VRML output. Currently, this is probably not much more than a POP (proof of principle) but is hoped to be useful enough for some real life work. Check L for the format of the signature. Currently, the C<[t]> qualifier and all type qualifiers are ignored. =cut sub PDL::over (&) { $_[0] } sub PDL::thread_define ($$) { require PDL::PP::Signature; my ($str,$sub) = @_; my $others = 0; if ($str =~ s/[,]*\s*NOtherPars\s*=>\s*([0-9]+)\s*[,]*//) {$others = $1} barf "invalid string $str" unless $str =~ /\s*([^(]+)\((.+)\)\s*$/x; my ($name,$sigstr) = ($1,$2); print "defining '$name' with signature '$sigstr' and $others extra args\n" if $PDL::debug; my $sig = PDL::PP::Signature->new($sigstr); my $args = @{$sig->names}; # number of ndarray arguments barf "no ndarray args" if $args == 0; $args--; # TODO: $sig->dimcheck(@_) + proper creating generation my $package = caller; print "defining... $name\n" if $PDL::debug; no strict 'refs'; *{"$package\::$name"} = sub { @_[0..$args] = map PDL::Core::topdl($_), @_[0..$args]; $sig->checkdims(@_); PDL::threadover($others,@_,$sig->realdims,$sig->creating,$sub); }; } =head2 thread =for ref Use explicit threading over specified dimensions (see also L) =for usage $y = $x->thread($dim,[$dim1,...]) =for example $x = zeroes 3,4,5; $y = $x->thread(2,0); Same as L, i.e. uses thread id 1. =cut sub PDL::thread { my $var = shift; $var->threadI(1,\@_); } =head2 thread1 =for ref Explicit threading over specified dims using thread id 1. =for usage $xx = $x->thread1(3,1) =for example Wibble Convenience function interfacing to L. =cut sub PDL::thread1 { my $var = shift; $var->threadI(1,\@_); } =head2 thread2 =for ref Explicit threading over specified dims using thread id 2. =for usage $xx = $x->thread2(3,1) =for example Wibble Convenience function interfacing to L. =cut sub PDL::thread2 { my $var = shift; $var->threadI(2,\@_); } =head2 thread3 =for ref Explicit threading over specified dims using thread id 3. =for usage $xx = $x->thread3(3,1) =for example Wibble Convenience function interfacing to L. =cut sub PDL::thread3 { my $var = shift; $var->threadI(3,\@_); } my %info = ( D => { Name => 'Dimension', Sub => \&PDL::Core::dimstr, }, T => { Name => 'Type', Sub => sub { return $_[0]->type->shortctype; }, }, S => { Name => 'State', Sub => sub { my $state = ''; $state .= 'P' if $_[0]->allocated; $state .= 'V' if $_[0]->vaffine && !$_[0]->allocated; # apparently can be both? $state .= '-' if $state eq ''; # lazy eval $state .= 'C' if $_[0]->anychgd; $state .= 'B' if $_[0]->badflag; $state; }, }, F => { Name => 'Flow', Sub => sub { my $flows = ''; $flows = ($_[0]->bflows ? 'b':'') . '~' . ($_[0]->fflows ? 'f':'') if ($_[0]->flows); $flows; }, }, M => { Name => 'Mem', Sub => sub { my ($size,$unit) = ($_[0]->allocated ? $_[0]->nelem* PDL::howbig($_[0]->get_datatype)/1024 : 0, 'KB'); if ($size > 0.01*1024) { $size /= 1024; $unit = 'MB' }; return sprintf "%6.2f%s",$size,$unit; }, }, C => { Name => 'Class', Sub => sub { ref $_[0] } }, A => { Name => 'Address', Sub => sub { use Config; my $ivdformat = $Config{ivdformat}; $ivdformat =~ s/"//g; sprintf "%$ivdformat", $_[0]->address } }, ); # print the dimension information about a pdl in some appropriate form sub dimstr { my $this = shift; my @dims = $this->dims; my @ids = $this->threadids; my ($nids,$i) = ($#ids - 1,0); my $dstr = 'D ['. join(',',@dims[0..($ids[0]-1)]) .']'; if ($nids > 0) { for $i (1..$nids) { $dstr .= " T$i [". join(',',@dims[$ids[$i]..$ids[$i+1]-1]) .']'; } } return $dstr; } =head2 sever =for ref sever any links of this ndarray to parent ndarrays In PDL it is possible for an ndarray to be just another view into another ndarray's data. In that case we call this ndarray a I and the original ndarray owning the data its parent. In other languages these alternate views sometimes run by names such as I or I. Typical functions that return such ndarrays are C, C, C, etc. Sometimes, however, you would like to separate the I from its parent's data and just give it a life of its own (so that manipulation of its data doesn't change the parent). This is simply achieved by using C. For example, =for example $x = $pdl->index(pdl(0,3,7))->sever; $x++; # important: $pdl is not modified! In many (but not all) circumstances it acts therefore similar to L. However, in general performance is better with C and secondly, C doesn't lead to futile copying when used on ndarrays that already have their own data. On the other hand, if you really want to make sure to work on a copy of an ndarray use L. $x = zeroes(20); $x->sever; # NOOP since $x is already its own boss! Again note: C I the same as L! For example, $x = zeroes(1); # $x does not have a parent, i.e. it is not a slice etc $y = $x->sever; # $y is now pointing to the same ndarray as $x $y++; print $x; [1] but $x = zeroes(1); $y = $x->copy; # $y is now pointing to a new ndarray $y++; print $x; [0] =head2 info =for ref Return formatted information about an ndarray. =for usage $x->info($format_string); =for example print $x->info("Type: %T Dim: %-15D State: %S"); Returns a string with info about an ndarray. Takes an optional argument to specify the format of information a la sprintf. Format specifiers are in the form C<%EwidthEEletterE> where the width is optional and the letter is one of =over 7 =item T Type =item D Formatted Dimensions =item F Dataflow status =item S Some internal flags (P=physical,V=Vaffine,C=changed,B=may contain bad data) =item C Class of this ndarray, i.e. C =item A Address of the ndarray struct as a unique identifier =item M Calculated memory consumption of this ndarray's data area =back =cut sub PDL::info { my ($this,$str) = @_; $str = "%C: %T %D" unless defined $str; return ref($this)."->null" if $this->isnull; my @hash = split /(%[-,0-9]*[.]?[0-9]*\w)/, $str; my @args = (); my $nstr = ''; for my $form (@hash) { if ($form =~ s/^%([-,0-9]*[.]?[0-9]*)(\w)$/%$1s/) { barf "unknown format specifier $2" unless defined $info{$2}; push @args, &{$info{$2}->{Sub}}($this); } $nstr .= $form; } return sprintf $nstr, @args; } =head2 approx =for ref test for approximately equal values (relaxed C<==>) =for example # ok if all corresponding values in # ndarrays are within 1e-8 of each other print "ok\n" if all approx $x, $y, 1e-8; C is a relaxed form of the C<==> operator and often more appropriate for floating point types (C and C). Usage: =for usage $res = approx $x, $y [, $eps] The optional parameter C<$eps> is remembered across invocations and initially set to 1e-6, e.g. approx $x, $y; # last $eps used (1e-6 initially) approx $x, $y, 1e-10; # 1e-10 approx $x, $y; # also 1e-10 =cut my $approx = 1e-6; # a reasonable init value sub PDL::approx { my ($x,$y,$eps) = @_; $eps = $approx unless defined $eps; # the default eps $approx = $eps; # remember last eps # NOTE: ($x-$y)->abs breaks for non-ndarray inputs return abs($x-$y) < $eps; } =head2 mslice =for ref Alias to L. =cut *PDL::mslice = \&PDL::Slices::slice; =head2 nslice_if_pdl =for ref If C<$self> is a PDL, then calls C with all but the last argument, otherwise $self->($_[-1]) is called where $_[-1} is the original argument string found during PDL::NiceSlice filtering. DEVELOPER'S NOTE: this routine is found in Core.pm.PL but would be better placed in Slices/slices.pd. It is likely to be moved there and/or changed to "slice_if_pdl" for PDL 3.0. =for usage $w = $x->nslice_if_pdl(...,'(args)'); =cut sub PDL::nslice_if_pdl { my ($pdl) = shift; my ($orig_args) = pop; # warn "PDL::nslice_if_pdl called with (@_) args, originally ($orig_args)\n"; if (ref($pdl) eq 'CODE') { # barf('PDL::nslice_if_pdl tried to process a sub ref, please use &$subref() syntax') @_ = eval $orig_args; goto &$pdl; } unshift @_, $pdl; goto &PDL::slice; } # Convert numbers to PDL if not already sub PDL::topdl { return $_[0]->new(@_[1..$#_]) if($#_ > 1); # PDLify an ARRAY return $_[1] if blessed($_[1]); # Fall through return $_[0]->new($_[1]) if ref(\$_[1]) eq 'SCALAR' or ref($_[1]) eq 'ARRAY'; barf("Can not convert a ".ref($_[1])." to a ".$_[0]); 0;} # Convert everything to PDL if not blessed sub alltopdl { if (ref $_[2] eq 'PDL::Type') { return convert($_[1], $_[2]) if blessed($_[1]); return $_[0]->new($_[2], $_[1]) if $_[0] eq 'PDL'; } return $_[1] if blessed($_[1]); # Fall through return $_[0]->new($_[1]); 0;} =head2 inplace =for ref Flag an ndarray so that the next operation is done 'in place' =for usage somefunc($x->inplace); somefunc(inplace $x); In most cases one likes to use the syntax C<$y = f($x)>, however in many case the operation C can be done correctly 'in place', i.e. without making a new copy of the data for output. To make it easy to use this, we write C in such a way that it operates in-place, and use C to hint that a new copy should be disabled. This also makes for clear syntax. Obviously this will not work for all functions, and if in doubt see the function's documentation. However one can assume this is true for all elemental functions (i.e. those which just operate array element by array element like C). =for example pdl> $x = xvals zeroes 10; pdl> log10(inplace $x) pdl> p $x [-inf 0 0.30103 0.47712125 0.60205999 0.69897 0.77815125 0.84509804 0.90308999 0.95424251] =cut # Flag pdl for in-place operations sub PDL::inplace { my $pdl = PDL->topdl(shift); $pdl->set_inplace(1); return $pdl; } # Copy if not inplace =head2 is_inplace =for ref Test the in-place flag on an ndarray =for usage $out = ($in->is_inplace) ? $in : zeroes($in); $in->set_inplace(0) Provides access to the L hint flag, within the perl milieu. That way functions you write can be inplace aware... If given an argument the inplace flag will be set or unset depending on the value at the same time. Can be used for shortcut tests that delete the inplace flag while testing: $out = ($in->is_inplace(0)) ? $in : zeroes($in); # test & unset! =head2 set_inplace =for ref Set the in-place flag on an ndarray =for usage $out = ($in->is_inplace) ? $in : zeroes($in); $in->set_inplace(0); Provides access to the L hint flag, within the perl milieu. Useful mainly for turning it OFF, as L turns it ON more conveniently. =head2 new_or_inplace =for usage $w = new_or_inplace(shift()); $w = new_or_inplace(shift(),$preferred_type); =for ref Return back either the argument pdl or a copy of it depending on whether it be flagged in-place or no. Handy for building inplace-aware functions. If you specify a preferred type (must be one of the usual PDL type strings, a list ref containing several of them, or a comma-separated string containing several of them), then the copy is coerced into the first preferred type listed if it is not already one of the preferred types. Note that if the inplace flag is set, no coercion happens even if you specify a preferred type. =cut sub new_or_inplace { my $pdl = shift; if(blessed($pdl) && $pdl->is_inplace) { $pdl->set_inplace(0); return $pdl; } my $preferred = shift; return blessed($pdl) ? $pdl->copy : null() if !defined $preferred; $preferred = [split ",",$preferred] if ref $preferred ne 'ARRAY'; my $s = "".$pdl->type; return $pdl->copy if grep $_ eq $s, @$preferred; # the PDL is one of the preferred types. # No match - promote it to the first in the list. return $pdl->convert(PDL::Type->new($preferred->[0])); } *PDL::new_or_inplace = \&new_or_inplace; # Allow specifications like zeroes(10,10) or zeroes($x) # or zeroes(inplace $x) or zeroes(float,4,3) =head2 new_from_specification =for ref Internal method: create ndarray by specification This is the argument processing method called by L and some other functions which constructs ndarrays from argument lists of the form: [type], $nx, $ny, $nz,... For C<$nx>, C<$ny>, etc. 0 and 1D ndarrays are allowed. Giving those has the same effect as if saying C<$arg-Elist>, e.g. 1, pdl(5,2), 4 is equivalent to 1, 5, 2, 4 Note, however, that in all functions using C calling C will probably not do what you want. So to play safe use (e.g. with zeroes) $pdl = zeroes $dimpdl->list; Calling $pdl = zeroes $dimpdl; will rather be equivalent to $pdl = zeroes $dimpdl->dims; However, $pdl = zeroes ushort, $dimpdl; will again do what you intended since it is interpreted as if you had said $pdl = zeroes ushort, $dimpdl->list; This is unfortunate and confusing but no good solution seems obvious that would not break existing scripts. =cut sub PDL::new_from_specification{ my $class = shift; my $type = ref($_[0]) eq 'PDL::Type' ? ${shift @_}[0] : $PDL_D; my @dims = &_dims_from_args; my $pdl = $class->initialize(); $pdl->set_datatype($type); $pdl->setdims(\@dims); print "Dims: ",(join ',',@dims)," DLen: ",length(${$pdl->get_dataref}),"\n" if $PDL::debug; return $pdl; } sub _dims_from_args { barf "Dimensions must be non-negative" if grep !ref && ($_||0)<0, @_; barf "Trying to use non-ndarray as dimensions?" if grep ref && !$_->isa('PDL'), @_; barf "Trying to use multi-dim ndarray as dimensions?" if grep ref && $_->getndims > 1, @_; warn "creating > 10 dim ndarray (ndarray arg)!" if grep ref && $_->nelem > 10, @_; map ref($_) ? $_->list : $_ || 0, @_; } =head2 isnull =for ref Test whether an ndarray is null =for usage croak("Input ndarray mustn't be null!") if $input_ndarray->isnull; This function returns 1 if the ndarray is null, zero if it is not. The purpose of null ndarrays is to "tell" any PDL::PP methods to allocate new memory for an output ndarray, but only when that PDL::PP method is called in full-arg form. Of course, there's no reason you couldn't commandeer the special value for your own purposes, for which this test function would prove most helpful. But in general, you shouldn't need to test for an ndarray's nullness. See L for more information. =head2 isempty =for ref Test whether an ndarray is empty =for usage print "The ndarray has zero dimension\n" if $pdl->isempty; This function returns 1 if the ndarray has zero elements. This is useful in particular when using the indexing function which. In the case of no match to a specified criterion, the returned ndarray has zero dimension. pdl> $w=sequence(10) pdl> $i=which($w < -1) pdl> print "I found no matches!\n" if ($i->isempty); I found no matches! Note that having zero elements is rather different from the concept of being a null ndarray, see the L and L manpages for discussions of this. =cut sub PDL::isempty { my $pdl=shift; return ($pdl->nelem == 0); } =head2 zeroes =for ref construct a zero filled ndarray from dimension list or template ndarray. If called with no arguments, returns a zero-dimension ndarray (a scalar). Various forms of usage, (i) by specification or (ii) by template ndarray: =for usage # usage type (i): $w = zeroes([type], $nx, $ny, $nz,...); $w = PDL->zeroes([type], $nx, $ny, $nz,...); $w = $pdl->zeroes([type], $nx, $ny, $nz,...); # all info about $pdl ignored # usage type (ii): $w = zeroes $y; $w = $y->zeroes zeroes inplace $w; # Equivalent to $w .= 0; $w->inplace->zeroes; # "" =for example pdl> $z = zeroes 4,3 pdl> p $z [ [0 0 0 0] [0 0 0 0] [0 0 0 0] ] pdl> $z = zeroes ushort, 3,2 # Create ushort array [ushort() etc. with no arg returns a PDL::Types token] See also L for details on using ndarrays in the dimensions list. =cut sub zeroes { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? PDL::zeroes($_[0]) : PDL->zeroes(@_) } sub PDL::zeroes { my $class = shift; my $ispdl = ref $class && UNIVERSAL::isa($class, 'PDL'); if ($ispdl and $class->is_inplace) { $class .= 0; # resets the "inplace" return $class; } my $type = ref($_[0]) eq 'PDL::Type' ? ${shift @_}[0] : $ispdl ? $class->get_datatype : $PDL_D; my @dims = _dims_from_args($ispdl && !@_ ? $class->dims : @_); my $pdl = $class->initialize(); $pdl->set_datatype($type); $pdl->setdims(\@dims); $pdl->make_physical; return $pdl; } # Create convenience aliases for zeroes =head2 zeros =for ref construct a zero filled ndarray (see zeroes for usage) =cut *zeros = \&zeroes; *PDL::zeros = \&PDL::zeroes; =head2 ones =for ref construct a one filled ndarray. If called with no arguments, returns a zero-dimension ndarray (a scalar). =for usage $w = ones([type], $nx, $ny, $nz,...); etc. (see 'zeroes') =for example see zeroes() and add one See also L for details on using ndarrays in the dimensions list. =cut sub _construct { @_>1 ? $_[0]->new_from_specification(@_[1..$#_]) : $_[0]->new_or_inplace; } sub ones { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? PDL::ones($_[0]) : PDL->ones(@_) } sub PDL::ones { my $pdl = &_construct; $pdl.=1; return $pdl; } =head2 nan =for ref construct a C filled ndarray. If called with no arguments, returns a zero-dimension ndarray (a scalar). =for usage $w = nan([type], $nx, $ny, $nz,...); etc. (see 'zeroes') =for example see zeroes() and add NaN See also L for details on using ndarrays in the dimensions list. =cut sub nan { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? PDL::nan($_[0]) : PDL->nan(@_) } sub PDL::nan { my $pdl = &_construct; $pdl .= PDL::_nan(); return $pdl; } =head2 inf =for ref construct an C filled ndarray. If called with no arguments, returns a zero-dimension ndarray (a scalar). =for usage $w = inf([type], $nx, $ny, $nz,...); etc. (see 'zeroes') =for example see zeroes() and add Inf See also L for details on using ndarrays in the dimensions list. =cut sub inf { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? PDL::inf($_[0]) : PDL->inf(@_) } sub PDL::inf { my $pdl = &_construct; $pdl .= PDL::_inf(); return $pdl; } =head2 i =for ref construct an ndarray filled with a native complex value equal to the imaginary number "i", the square root of -1. If called with no arguments, returns a zero-dimension ndarray (a scalar). =for usage $w = i([type], $nx, $ny, $nz,...); etc. (see 'zeroes') =for example see zeroes() and add "i" See also L for details on using ndarrays in the dimensions list. =cut sub i { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? PDL::i($_[0]) : PDL->i(@_) } sub PDL::i { my $class = shift; my @args = @_; if (@args) { if (ref($args[0]) eq 'PDL::Type' and $args[0]->real) { $args[0] = cdouble(); } else { unshift @args, cdouble(); } } else { $class = convert $class, cdouble() if ref $class and $class->type->real; } my $pdl = scalar(@args)? $class->new_from_specification(@args) : $class->new_or_inplace; $pdl .= PDL::_ci(); return $pdl; } =head2 reshape =for ref Change the shape (i.e. dimensions) of an ndarray, preserving contents. =for usage $x->reshape(NEWDIMS); reshape($x, NEWDIMS); The data elements are preserved, obviously they will wrap differently and get truncated if the new array is shorter. If the new array is longer it will be zero-padded. ***Potential incompatibility with earlier versions of PDL**** If the list of C is empty C will just drop all dimensions of size 1 (preserving the number of elements): $w = sequence(3,4,5); $y = $w(1,3); $y->reshape(); print $y->info; PDL: Double D [5] Dimensions of size 1 will also be dropped if C is invoked with the argument -1: $y = $w->reshape(-1); As opposed to C without arguments, C preserves dataflow: $w = ones(2,1,2); $y = $w(0)->reshape(-1); $y++; print $w; [ [ [2 1] ] [ [2 1] ] ] Important: ndarrays are changed inplace! Note: If C<$x> is connected to any other PDL (e.g. if it is a slice) then the connection is first severed. =for example pdl> $x = sequence(10) pdl> reshape $x,3,4; p $x [ [0 1 2] [3 4 5] [6 7 8] [9 0 0] ] pdl> reshape $x,5; p $x [0 1 2 3 4] =cut *reshape = \&PDL::reshape; sub PDL::reshape{ my $pdl = topdl($_[0]); if (@_ == 2 && $_[1] == -1) { # a slicing reshape that drops 1-dims return $pdl->slice( map $_==1 ? [0,0,0] : [], $pdl->dims); } $pdl->sever; my $nelem = $pdl->nelem; my @dims = grep defined, @_[1..$#_]; for my $dim(@dims) { barf "reshape: invalid dim size '$dim'" if $dim < 0 } @dims = grep($_ != 1, $pdl->dims) if @dims == 0; # get rid of dims of size 1 $pdl->setdims(\@dims); $pdl->make_physical; if ($pdl->nelem > $nelem) { my $tmp=$pdl->clump(-1)->slice("$nelem:-1"); $tmp .= 0; } $_[0] = $pdl; return $pdl; } =head2 squeeze =for ref eliminate all singleton dimensions (dims of size 1) =for example $y = $w(0,0)->squeeze; Alias for C. Removes all singleton dimensions and preserves dataflow. A more concise interface is provided by L via modifiers: use PDL::NiceSlice; $y = $w(0,0;-); # same as $w(0,0)->squeeze =cut *squeeze = \&PDL::squeeze; sub PDL::squeeze { return $_[0]->reshape(-1) } =head2 flat =for ref flatten an ndarray (alias for C<< $pdl->clump(-1) >>) =for example $srt = $pdl->flat->qsort; Useful method to make a 1D ndarray from an arbitrarily sized input ndarray. Data flows back and forth as usual with slicing routines. Falls through if argument already E= 1D. =cut *flat = \&PDL::flat; sub PDL::flat { # fall through if < 2D return my $dummy = $_[0]->getndims != 1 ? $_[0]->clump(-1) : $_[0]; } =head2 convert =for ref Generic datatype conversion function =for usage $y = convert($x, $newtype); C<$newtype> is a type number or L object, for convenience they are returned by C etc when called without arguments. =for example $y = convert $x, long; $y = convert $x, ushort; =cut sub PDL::convert { # we don't allow inplace conversion at the moment # (not sure what needs to be changed) barf 'Usage: $y = convert($x, $newtype)'."\n" if @_ != 2; my ($pdl,$type)= @_; $pdl = topdl($pdl); # Allow normal numbers $type = $type->enum if ref($type) eq 'PDL::Type'; barf 'Usage: $y = convert($x, $newtype)'."\n" unless Scalar::Util::looks_like_number($type); return $pdl if $pdl->get_datatype == $type; $pdl->_convert_int($type)->sever; } =head2 Datatype_conversions =for ref sbyte|byte|short|ushort|long|ulong|indx|longlong|ulonglong|float|double|ldouble|cfloat|cdouble|cldouble (shorthands to convert datatypes) =for usage $y = double $x; $y = ushort [1..10]; # all of the above listed shorthands behave similarly When called with an ndarray argument, they convert to the specific datatype. When called with a numeric, list, listref, or string argument they construct a new ndarray. This is a convenience to avoid having to be long-winded and say C<$x = long(pdl(42))> Thus one can say: $w = float(1,2,3,4); # 1D $w = float q[1 2 3; 4 5 6]; # 2D $w = float([1,2,3],[4,5,6]); # 2D $w = float([[1,2,3],[4,5,6]]); # 2D Note the last three give identical results, and the last two are exactly equivalent - a list is automatically converted to a list reference for syntactic convenience. i.e. you can omit the outer C<[]> When called with no arguments, these functions return a special type token. This allows syntactical sugar like: $x = ones byte, 1000,1000; This example creates a large ndarray directly as byte datatype in order to save memory. In order to control how undefs are handled in converting from perl lists to PDLs, one can set the variable C<$PDL::undefval>; see the function L for more details. =for example pdl> p $x=sqrt float [1..10] [1 1.41421 1.73205 2 2.23607 2.44949 2.64575 2.82843 3 3.16228] pdl> p byte $x [1 1 1 2 2 2 2 2 3 3] =head2 byte Convert to byte datatype =head2 short Convert to short datatype =head2 ushort Convert to ushort datatype =head2 long Convert to long datatype =head2 indx Convert to indx datatype =head2 longlong Convert to longlong datatype =head2 float Convert to float datatype =head2 double Convert to double datatype =head2 cfloat Convert to complex float datatype =head2 cdouble Convert to complex double datatype =head2 type =for ref return the type of an ndarray as a blessed type object A convenience function for use with the ndarray constructors, e.g. =for example $y = PDL->zeroes($x->type,$x->dims,3); die "must be float" unless $x->type == float; See also the discussion of the C class in L. Note that the C objects have overloaded comparison and stringify operators so that you can compare and print types: $x = $x->float if $x->type < float; $t = $x->type; print "Type is $t\n"; =cut sub PDL::type { return PDL::Type->new($_[0]->get_datatype); } ##################### Printing #################### # New string routine $PDL::_STRINGIZING = 0; sub PDL::string { my($self,$format)=@_; my $to_return = eval { if($PDL::_STRINGIZING) { return "ALREADY_STRINGIZING_NO_LOOPS"; } local $PDL::_STRINGIZING = 1; my $ndims = $self->getndims; if($self->nelem > $PDL::toolongtoprint) { return "TOO LONG TO PRINT"; } if ($ndims==0) { if ( $self->badflag() and $self->isbad() ) { return "BAD"; } else { my @x = $self->at(); return ($format ? sprintf($format, $x[0]) : "$x[0]"); } } return "Null" if $self->isnull; return "Empty[".join("x",$self->dims)."]" if $self->isempty; # Empty ndarray local $sep = $PDL::use_commas ? "," : " "; local $sep2 = $PDL::use_commas ? "," : ""; if ($ndims==1) { return str1D($self,$format); } else{ return strND($self,$format,0); } }; if ($@) { # Remove reference to this line: $@ =~ s/\s*at .* line \d+\s*\.\n*/./; PDL::Core::barf("Stringizing problem: $@"); } return $to_return; } ############## Section/subsection functions ################### =head2 list =for ref Convert ndarray to perl list =for usage @tmp = list $x; Obviously this is grossly inefficient for the large datasets PDL is designed to handle. This was provided as a get out while PDL matured. It should now be mostly superseded by superior constructs, such as PP/threading. However it is still occasionally useful and is provided for backwards compatibility. =for example for (list $x) { # Do something on each value... } =for bad list converts any bad values into the string 'BAD'. =cut # No threading, just the ordinary dims. sub PDL::list{ # pdl -> @list barf 'Usage: list($pdl)' if $#_!=0; my $pdl = PDL->topdl(shift); return () if nelem($pdl)==0; @{listref_c($pdl)}; } =head2 unpdl =for ref Convert ndarray to nested Perl array references =for usage $arrayref = unpdl $x; This function returns a reference to a Perl list-of-lists structure equivalent to the input ndarray (within the limitation that while values of elements should be preserved, the detailed datatypes will not as perl itself basically has "number" data rather than byte, short, int... E.g., C<< sum($x - pdl( $x->unpdl )) >> should equal 0. Obviously this is grossly inefficient in memory and processing for the large datasets PDL is designed to handle. Sometimes, however, you really want to move your data back to Perl, and with proper dimensionality, unlike C. If you want to round-trip data including the use of C, C does not support this. However, it is suggested you would generate an index-set with C<< $pdl->whereND($pdl == $PDL::undefval) >>, then loop over the Perl data, setting those locations to C. =for example use JSON; my $json = encode_json unpdl $pdl; =for bad unpdl converts any bad values into the string 'BAD'. =cut sub PDL::unpdl { barf 'Usage: unpdl($pdl)' if $#_ != 0; my $pdl = PDL->topdl(shift); return [] if $pdl->nelem == 0; return _unpdl_int($pdl); } sub _unpdl_int { my $pdl = shift; if ($pdl->ndims > 1) { return [ map { _unpdl_int($_) } dog $pdl ]; } else { return listref_c($pdl); } } =head2 listindices =for ref Convert ndarray indices to perl list =for usage @tmp = listindices $x; C<@tmp> now contains the values C<0..nelem($x)>. Obviously this is grossly inefficient for the large datasets PDL is designed to handle. This was provided as a get out while PDL matured. It should now be mostly superseded by superior constructs, such as PP/threading. However it is still occasionally useful and is provied for backwards compatibility. =for example for $i (listindices $x) { # Do something on each value... } =cut sub PDL::listindices{ # Return list of index values for 1D pdl barf 'Usage: list($pdl)' if $#_!=0; my $pdl = shift; return () if nelem($pdl)==0; barf 'Not 1D' if scalar(dims($pdl)) != 1; return (0..nelem($pdl)-1); } =head2 set =for ref Set a single value inside an ndarray =for usage set $ndarray, @position, $value C<@position> is a coordinate list, of size equal to the number of dimensions in the ndarray. Occasionally useful, mainly provided for backwards compatibility as superseded by use of L and assignment operator C<.=>. =for example pdl> $x = sequence 3,4 pdl> set $x, 2,1,99 pdl> p $x [ [ 0 1 2] [ 3 4 99] [ 6 7 8] [ 9 10 11] ] =cut sub PDL::set{ # Sets a particular single value barf 'Usage: set($pdl, $x, $y,.., $value)' if $#_<2; my $self = shift; my $value = pop @_; set_c ($self, [@_], $value); return $self; } =head2 at =for ref Returns a single value inside an ndarray as perl scalar. If the ndarray is a native complex value (cdouble, cfloat), it will be a L object. =for usage $z = at($ndarray, @position); $z=$ndarray->at(@position); C<@position> is a coordinate list, of size equal to the number of dimensions in the ndarray. Occasionally useful in a general context, quite useful too inside PDL internals. =for example pdl> $x = sequence 3,4 pdl> p $x->at(1,2) 7 =for bad at converts any bad values into the string 'BAD'. =cut sub PDL::at { # Return value at ($x,$y,$z...) barf 'Usage: at($pdl, $x, $y, ...)' if $#_<0; my $self = shift; at_bad_c ($self, [@_]); } =head2 sclr =for ref return a single value from an ndarray as a scalar, ignoring whether it is bad. =for example $val = $x(10)->sclr; $val = sclr inner($x,$y); The C method is useful to turn a single-element ndarray into a normal Perl scalar. Its main advantage over using C for this purpose is the fact that you do not need to worry if the ndarray is 0D, 1D or higher dimensional. Using C you have to supply the correct number of zeroes, e.g. $x = sequence(10); $y = $x->slice('4'); print $y->sclr; # no problem print $y->at(); # error: needs at least one zero C is generally used when a Perl scalar is required instead of a one-element ndarray. As of 2.064, if the input is a multielement ndarray it will throw an exception. =cut sub PDL::sclr { my $this = shift; confess "multielement ndarray in 'sclr' call" if $this->nelem > 1; return sclr_c($this); } =head2 cat =for ref concatenate ndarrays to N+1 dimensional ndarray Takes a list of N ndarrays of same shape as argument, returns a single ndarray of dimension N+1. =for example pdl> $x = cat ones(3,3),zeroes(3,3),rvals(3,3); p $x [ [ [1 1 1] [1 1 1] [1 1 1] ] [ [0 0 0] [0 0 0] [0 0 0] ] [ [1 1 1] [1 0 1] [1 1 1] ] ] =for bad The output ndarray is set bad if any input ndarrays have their bad flag set. Similar functions include L, which appends only two ndarrays along their first dimension, and L, which can append more than two ndarrays along an arbitrary dimension. Also consider the generic constructor L, which can handle ndarrays of different sizes (with zero-padding), and will return a ndarray of type 'double' by default, but may be considerably faster (up to 10x) than cat. =cut sub PDL::cat { my $res; my $old_err = $@; $@ = ''; eval { $res = $_[0]->initialize; $res->set_datatype((sort {$b<=>$a} map{$_->get_datatype} @_)[0] ); my @resdims = $_[0]->dims; for my $i(0..$#_){ my @d = $_[$i]->dims; for my $j(0..$#d) { $resdims[$j] = $d[$j] if( !defined($resdims[$j]) or $resdims[$j]==1 ); die "mismatched dims\n" if($d[$j] != 1 and $resdims[$j] != $d[$j]); } } $res->setdims( [@resdims,scalar(@_) ]); my ($i,$t); my $s = ":,"x@resdims; for (@_) { $t = $res->slice($s."(".$i++.")"); $t .= $_} # propagate any bad flags for (@_) { if ( $_->badflag() ) { $res->badflag(1); last; } } }; if ($@ eq '') { # Restore the old error and return $@ = $old_err; return $res; } # If we've gotten here, then there's been an error, so check things # and barf out a meaningful message. if ($@ =~ /PDL::Ops::assgn|mismatched/ or $@ =~ /"badflag"/ or $@ =~ /"initialize"/) { my (@mismatched_dims, @not_a_ndarray); my $i = 0; # non-ndarrays and/or dimension mismatch. The first argument is # ok unless we have the "initialize" error: if ($@ =~ /"initialize"/) { # Handle the special case that there are *no* args passed: barf("Called PDL::cat without any arguments") unless @_; while ($i < @_ and not eval{ $_[$i]->isa('PDL')}) { push (@not_a_ndarray, $i); $i++; } } # Get the dimensions of the first actual ndarray in the argument # list: my $first_ndarray_argument = $i; my @dims = $_[$i]->dims if ref($_[$i]) =~ /PDL/; # Figure out all the ways that the caller screwed up: while ($i < @_) { my $arg = $_[$i]; # Check if not an ndarray if (not eval{$arg->isa('PDL')}) { push @not_a_ndarray, $i; } # Check if different number of dimensions elsif (@dims != $arg->ndims) { push @mismatched_dims, $i; } # Check if size of dimensions agree else { DIMENSION: for (my $j = 0; $j < @dims; $j++) { if ($dims[$j] != $arg->dim($j)) { push @mismatched_dims, $i; last DIMENSION; } } } $i++; } # Construct a message detailing the results my $message = "bad arguments passed to function PDL::cat\n"; if (@mismatched_dims > 1) { # Many dimension mismatches $message .= "The dimensions of arguments " . join(', ', @mismatched_dims[0 .. $#mismatched_dims-1]) . " and $mismatched_dims[-1] do not match the\n" . " dimensions of the first ndarray argument (argument $first_ndarray_argument).\n"; } elsif (@mismatched_dims) { # One dimension mismatch $message .= "The dimensions of argument $mismatched_dims[0] do not match the\n" . " dimensions of the first ndarray argument (argument $first_ndarray_argument).\n"; } if (@not_a_ndarray > 1) { # many non-ndarrays $message .= "Arguments " . join(', ', @not_a_ndarray[0 .. $#not_a_ndarray-1]) . " and $not_a_ndarray[-1] are not ndarrays.\n"; } elsif (@not_a_ndarray) { # one non-ndarray $message .= "Argument $not_a_ndarray[0] is not an ndarray.\n"; } # Handle the edge case that something else happened: if (@not_a_ndarray == 0 and @mismatched_dims == 0) { barf("cat: unknown error from the internals:\n$@"); } $message .= "(Argument counting starts from zero.)"; croak($message); } else { croak("cat: unknown error from the internals:\n$@"); } } =head2 dog =for ref Opposite of 'cat' :). Split N dim ndarray to list of N-1 dim ndarrays Takes a single N-dimensional ndarray and splits it into a list of N-1 dimensional ndarrays. The breakup is done along the last dimension. Note the dataflowed connection is still preserved by default, e.g.: =for example pdl> $p = ones 3,3,3 pdl> ($x,$y,$c) = dog $p pdl> $y++; p $p [ [ [1 1 1] [1 1 1] [1 1 1] ] [ [2 2 2] [2 2 2] [2 2 2] ] [ [1 1 1] [1 1 1] [1 1 1] ] ] =for options Break => 1 Break dataflow connection (new copy) =for bad The output ndarrays are set bad if the original ndarray has its bad flag set. =cut sub PDL::dog { my $opt = ref($_[-1]) eq 'HASH' ? pop @_ : {}; my $p = shift; my $s = ":,"x($p->getndims-1); my @res = map $p->slice($s."(".$_.")"), 0..$p->dim(-1)-1; $$opt{Break} ? map $_->copy, @res : @res } ###################### Misc internal routines #################### # Recursively pack an N-D array ref in format [[1,1,2],[2,2,3],[2,2,2]] etc # package vars $level and @dims must be initialised first. sub rpack { my ($ptype,$x) = @_; my ($ret,$type); $ret = ""; if (ref($x) eq "ARRAY") { if (defined($dims[$level])) { barf 'Array is not rectangular' unless $dims[$level] == scalar(@$x); }else{ $dims[$level] = scalar(@$x); } $type = ref($$x[0]); if ($type) { $level++; for(@$x) { barf 'Array is not rectangular' unless $type eq ref($_); # Equal types $ret .= rpack($ptype,$_); } $level--; } else { # These are leaf nodes $ret = pack $ptype, map {defined($_) ? $_ : $PDL::undefval} @$x; } } elsif (ref($x) eq "PDL") { barf 'Cannot make a new ndarray from two or more ndarrays, try "cat"'; } else { barf "Don't know how to make a PDL object from passed argument"; } return $ret; } sub rcopyitem { # Return a deep copy of an item - recursively my $x = shift; my ($y, $key, $value); if (ref(\$x) eq "SCALAR") { return $x; }elsif (ref($x) eq "SCALAR") { $y = $$x; return \$y; }elsif (ref($x) eq "ARRAY") { $y = []; for (@$x) { push @$y, rcopyitem($_); } return $y; }elsif (ref($x) eq "HASH") { $y={}; while (($key,$value) = each %$x) { $$y{$key} = rcopyitem($value); } return $y; }elsif (blessed($x)) { return $x->copy; }else{ barf ('Deep copy of object failed - unknown component with type '.ref($x)); } 0;} # N-D array stringifier sub strND { my($self,$format,$level)=@_; # $self->make_physical(); my @dims = $self->dims; # print "STRND, $#dims\n"; if ($#dims==1) { # Return 2D string return str2D($self,$format,$level); } else { # Return list of (N-1)D strings my $secbas = join '',map {":,"} @dims[0..$#dims-1]; my $ret="\n"." "x$level ."["; my $j; for ($j=0; $j<$dims[$#dims]; $j++) { my $sec = $secbas . "($j)"; # print "SLICE: $sec\n"; $ret .= strND($self->slice($sec),$format, $level+1); chop $ret; $ret .= $sep2; } chop $ret if $PDL::use_commas; $ret .= "\n" ." "x$level ."]\n"; return $ret; } } # String 1D array in nice format sub str1D { my($self,$format)=@_; barf "Not 1D" if $self->getndims()!=1; my $x = listref_c($self); my ($ret,$dformat,$t); $ret = "["; my $dtype = $self->get_datatype(); $dformat = $PDL::floatformat if $dtype == $PDL_F; $dformat = $PDL::doubleformat if $dtype == $PDL_D; $dformat = $PDL::indxformat if $dtype == $PDL_IND; my $badflag = $self->badflag(); for $t (@$x) { if ( $badflag and $t eq "BAD" ) { # do nothing } elsif ($format) { $t = sprintf $format,$t; } else{ # Default if ($dformat && length($t)>7) { # Try smaller $t = sprintf $dformat,$t; } } $ret .= $t.$sep; } chop $ret; $ret.="]"; return $ret; } # String 2D array in nice uniform format sub str2D{ my($self,$format,$level)=@_; # print "STR2D:\n"; $self->printdims(); my @dims = $self->dims(); barf "Not 2D" if scalar(@dims)!=2; my $x = listref_c($self); my ($i, $f, $t, $len, $ret); my $dtype = $self->get_datatype(); my $badflag = $self->badflag(); my $findmax = 1; if (!defined $format || $format eq "") { # Format not given? - find max length of default $len=0; if ( $badflag ) { for (@$x) { if ( $_ eq "BAD" ) { $i = 3; } else { $i = length($_); } $len = $i>$len ? $i : $len; } } else { for (@$x) {$i = length($_); $len = $i>$len ? $i : $len }; } $format = "%".$len."s"; if ($len>7) { # Too long? - perhaps try smaller format if ($dtype == $PDL_F) { $format = $PDL::floatformat; } elsif ($dtype == $PDL_D) { $format = $PDL::doubleformat; } elsif ($dtype == $PDL_IND) { $format = $PDL::indxformat; } else { # Stick with default $findmax = 0; } } else { # Default ok $findmax = 0; } } if($findmax) { # Find max length of strings in final format $len=0; if ( $badflag ) { for (@$x) { if ( $_ eq "BAD" ) { $i = 3; } else { $i = length(sprintf $format,$_); } $len = $i>$len ? $i : $len; } } else { for (@$x) { $i = length(sprintf $format,$_); $len = $i>$len ? $i : $len; } } } # if: $findmax $ret = "\n" . " "x$level . "[\n"; { my $level = $level+1; $ret .= " "x$level ."["; for ($i=0; $i<=$#$x; $i++) { if ( $badflag and $$x[$i] eq "BAD" ) { $f = "BAD"; } else { $f = sprintf $format,$$x[$i]; } $t = $len-length($f); $f = " "x$t .$f if $t>0; $ret .= $f; if (($i+1)%$dims[0]) { $ret.=$sep; } else{ # End of output line $ret.="]"; if ($i==$#$x) { # very last number $ret.="\n"; } else{ $ret.= $sep2."\n" . " "x$level ."["; } } } } $ret .= " "x$level."]\n"; return $ret; } # # Sleazy hcpy saves me time typing # sub PDL::hcpy { $_[0]->hdrcpy($_[1]); $_[0]; } ########## Docs for functions in Core.xs ################## # Pod docs for functions that are imported from Core.xs and are # not documented elsewhere. Currently this is not a complete # list. There are others. =head2 gethdr =for ref Retrieve header information from an ndarray =for example $pdl=rfits('file.fits'); $h=$pdl->gethdr; print "Number of pixels in the X-direction=$$h{NAXIS1}\n"; The C function retrieves whatever header information is contained within an ndarray. The header can be set with L and is always a hash reference or undef. C returns undef if the ndarray has not yet had a header defined; compare with C and C, which are guaranteed to return a defined value. Note that gethdr() works by B: you can modify the header in-place once it has been retrieved: $x = rfits($filename); $xh = $x->gethdr(); $xh->{FILENAME} = $filename; It is also important to realise that in most cases the header is not automatically copied when you copy the ndarray. See L to enable automatic header copying. Here's another example: a wrapper around rcols that allows your ndarray to remember the file it was read from and the columns could be easily written (here assuming that no regexp is needed, extensions are left as an exercise for the reader) sub ext_rcols { my ($file, @columns)=@_; my $header={}; $$header{File}=$file; $$header{Columns}=\@columns; @ndarrays=rcols $file, @columns; foreach (@ndarrays) { $_->sethdr($header); } return @ndarrays; } =head2 hdr =for ref Retrieve or set header information from an ndarray =for example $pdl->hdr->{CDELT1} = 1; The C function allows convenient access to the header of a ndarray. Unlike C it is guaranteed to return a defined value, so you can use it in a hash dereference as in the example. If the header does not yet exist, it gets autogenerated as an empty hash. Note that this is usually -- but not always -- What You Want. If you want to use a tied L hash, for example, you should either construct it yourself and use C to put it into the ndarray, or use L instead. (Note that you should be able to write out the FITS file successfully regardless of whether your PDL has a tied FITS header object or a vanilla hash). =head2 fhdr =for ref Retrieve or set FITS header information from an ndarray =for example $pdl->fhdr->{CDELT1} = 1; The C function allows convenient access to the header of a ndarray. Unlike C it is guaranteed to return a defined value, so you can use it in a hash dereference as in the example. If the header does not yet exist, it gets autogenerated as a tied L hash. Astro::FITS::Header tied hashes are better at matching the behavior of FITS headers than are regular hashes. In particular, the hash keys are CAsE INsEnSItiVE, unlike normal hash keys. See L for details. If you do not have Astro::FITS::Header installed, you get back a normal hash instead of a tied object. =head2 sethdr =for ref Set header information of an ndarray =for example $pdl = zeroes(100,100); $h = {NAXIS=>2, NAXIS1=>100, NAXIS=>100, COMMENT=>"Sample FITS-style header"}; # add a FILENAME field to the header $$h{FILENAME} = 'file.fits'; $pdl->sethdr( $h ); The C function sets the header information for an ndarray. You must feed in a hash ref or undef, and the header field of the PDL is set to be a new ref to the same hash (or undefined). The hash ref requirement is a speed bump put in place since the normal use of headers is to store fits header information and the like. Of course, if you want you can hang whatever ugly old data structure you want off of the header, but that makes life more complex. Remember that the hash is not copied -- the header is made into a ref that points to the same underlying data. To get a real copy without making any assumptions about the underlying data structure, you can use one of the following: use PDL::IO::Dumper; $pdl->sethdr( deep_copy($h) ); (which is slow but general), or $pdl->sethdr( PDL::_hdr_copy($h) ) (which uses the built-in sleazy deep copier), or (if you know that all the elements happen to be scalars): { my %a = %$h; $pdl->sethdr(\%a); } which is considerably faster but just copies the top level. The C function must be given a hash reference or undef. For further information on the header, see L, L, L and L. =head2 hdrcpy =for ref switch on/off/examine automatic header copying =for example print "hdrs will be copied" if $x->hdrcpy; $x->hdrcpy(1); # switch on automatic header copying $y = $x->sumover; # and $y will inherit $x's hdr $x->hdrcpy(0); # and now make $x non-infectious again C without an argument just returns the current setting of the flag. See also "hcpy" which returns its PDL argument (and so is useful in method-call pipelines). Normally, the optional header of an ndarray is not copied automatically in pdl operations. Switching on the hdrcpy flag using the C method will enable automatic hdr copying. Note that an actual deep copy gets made, which is rather processor-inefficient -- so avoid using header copying in tight loops! Most PDLs have the C flag cleared by default; however, some routines (notably L) set it by default where that makes more sense. The C flag is viral: if you set it for a PDL, then derived PDLs will get copies of the header and will also have their C flags set. For example: $x = xvals(50,50); $x->hdrcpy(1); $x->hdr->{FOO} = "bar"; $y = $x++; $c = $y++; print $y->hdr->{FOO}, " - ", $c->hdr->{FOO}, "\n"; $y->hdr->{FOO} = "baz"; print $x->hdr->{FOO}, " - ", $y->hdr->{FOO}, " - ", $c->hdr->{FOO}, "\n"; will print: bar - bar bar - baz - bar Performing an operation in which more than one PDL has its hdrcpy flag causes the resulting PDL to take the header of the first PDL: ($x,$y) = sequence(5,2)->dog; $x->hdrcpy(1); $y->hdrcpy(1); $x->hdr->{foo} = 'a'; $y->hdr->{foo} = 'b'; print (($x+$y)->hdr->{foo} , ($y+$x)->hdr->{foo}); will print: a b =head2 hcpy =for ref Switch on/off automatic header copying, with PDL pass-through =for example $x = rfits('foo.fits')->hcpy(0); $x = rfits('foo.fits')->hcpy(1); C sets or clears the hdrcpy flag of a PDL, and returns the PDL itself. That makes it convenient for inline use in expressions. =head2 online_cpus =for ref Returns the number of available processors cores. Used to set the number of threads with L if C<$ENV{PDL_AUTOPTHREAD_TARG}> is not set. =head2 set_autopthread_targ =for ref Set the target number of processor threads (pthreads) for multi-threaded processing. =for usage set_autopthread_targ($num_pthreads); C<$num_pthreads> is the target number of pthreads the auto-pthread process will try to achieve. See L for an overview of the auto-pthread process. =for example # Example turning on auto-pthreading for a target of 2 pthreads and for functions involving # PDLs with greater than 1M elements set_autopthread_targ(2); set_autopthread_size(1); # Execute a pdl function, processing will split into two pthreads as long as # one of the pdl-threaded dimensions is divisible by 2. $x = minimum($y); # Get the actual number of pthreads that were run. $actual_pthread = get_autopthread_actual(); =cut *set_autopthread_targ = \&PDL::set_autopthread_targ; =head2 get_autopthread_targ =for ref Get the current target number of processor threads (pthreads) for multi-threaded processing. =for usage $num_pthreads = get_autopthread_targ(); C<$num_pthreads> is the target number of pthreads the auto-pthread process will try to achieve. See L for an overview of the auto-pthread process. =cut *get_autopthread_targ = \&PDL::get_autopthread_targ; =head2 get_autopthread_actual =for ref Get the actual number of pthreads executed for the last pdl processing function. =for usage $autopthread_actual = get_autopthread_actual(); C<$autopthread_actual> is the actual number of pthreads executed for the last pdl processing function. See L for an overview of the auto-pthread process. =cut *get_autopthread_actual = \&PDL::get_autopthread_actual; =head2 get_autopthread_dim =for ref Get the actual dimension on which pthreads were used for the last pdl processing function. =for usage $autopthread_dim = get_autopthread_dim(); C<$autopthread_dim> is the actual dimension on which pthreads were used for the last pdl processing function. See L for an overview of the auto-pthread process. =cut *get_autopthread_dim = \&PDL::get_autopthread_dim; =head2 set_autopthread_size =for ref Set the minimum size (in M-elements or 2^20 elements) of the largest PDL involved in a function where auto-pthreading will be performed. For small PDLs, it probably isn't worth starting multiple pthreads, so this function is used to define a minimum threshold where auto-pthreading won't be attempted. =for usage set_autopthread_size($size); C<$size> is the mimumum size, in M-elements or 2^20 elements (approx 1e6 elements) for the largest PDL involved in a function. See L for an overview of the auto-pthread process. =for example # Example turning on auto-pthreading for a target of 2 pthreads and for functions involving # PDLs with greater than 1M elements set_autopthread_targ(2); set_autopthread_size(1); # Execute a pdl function, processing will split into two pthreads as long as # one of the pdl-threaded dimensions is at least 2. $x = minimum($y); # Get the actual number of pthreads that were run. $actual_pthread = get_autopthread_actual(); =cut *set_autopthread_size = \&PDL::set_autopthread_size; =head2 get_autopthread_size =for ref Get the current autopthread_size setting. =for usage $autopthread_size = get_autopthread_size(); C<$autopthread_size> is the mimumum size limit for auto_pthreading to occur, in M-elements or 2^20 elements (approx 1e6 elements) for the largest PDL involved in a function See L for an overview of the auto-pthread process. =cut *get_autopthread_size = \&PDL::get_autopthread_size; =head1 AUTHOR Copyright (C) Karl Glazebrook (kgb@aaoepp.aao.gov.au), Tuomas J. Lukka, (lukka@husc.harvard.edu) and Christian Soeller (c.soeller@auckland.ac.nz) 1997. Modified, Craig DeForest (deforest@boulder.swri.edu) 2002. 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 # # Easier to implement in perl than in XS... # -- CED # sub PDL::fhdr { my $pdl = shift; return $pdl->hdr if( (defined $pdl->gethdr) || !defined $Astro::FITS::Header::VERSION ); # Avoid bug in 1.15 and earlier Astro::FITS::Header my @hdr = ("SIMPLE = T"); my $hdr = new Astro::FITS::Header(Cards=>\@hdr); tie my %hdr, "Astro::FITS::Header", $hdr; $pdl->sethdr(\%hdr); return \%hdr; } sub PDL::set_data_by_file_map { require Fcntl; require File::Map; my ($pdl,$name,$len,$shared,$writable,$creat,$mode,$trunc) = @_; my $pdl_dataref = $pdl->get_dataref(); sysopen(my $fh, $name, ($writable && $shared ? Fcntl::O_RDWR() : Fcntl::O_RDONLY()) | ($creat ? Fcntl::O_CREAT() : 0), $mode) or die "Error opening file '$name'\n"; binmode $fh; if ($trunc) { truncate($fh,0) or die "set_data_by_file_map: truncate('$name',0) failed, $!"; truncate($fh,$len) or die "set_data_by_file_map: truncate('$name',$len) failed, $!"; } if ($len) { if ($PDL::debug) { printf STDERR "set_data_by_file_map: calling sys_map(%s,%d,%d,%d,%s,%d)\n", $pdl_dataref, $len, File::Map::PROT_READ() | ($writable ? File::Map::PROT_WRITE() : 0), ($shared ? File::Map::MAP_SHARED() : File::Map::MAP_PRIVATE()), $fh, 0; } File::Map::sys_map( ${$pdl_dataref}, $len, File::Map::PROT_READ() | ($writable ? File::Map::PROT_WRITE() : 0), ($shared ? File::Map::MAP_SHARED() : File::Map::MAP_PRIVATE()), $fh, 0 ); $pdl->upd_data; if ($PDL::debug) { printf STDERR "set_data_by_file_map: length \${\$pdl_dataref} is %d.\n", length ${$pdl_dataref}; } $pdl->set_donttouchdata($len); } else { # Special case: zero-length file $_[0] = undef; } # PDLDEBUG_f(printf("PDL::MMap: mapped to %p\n",$pdl->data)); close $fh ; } 1; PDL-2.074/Basic/Core/pdlcore.h0000644000175000017500000001673414200101477015614 0ustar osboxesosboxes#ifndef __PDLCORE_H #define __PDLCORE_H /* version 20: memory-management changes */ /* on 21, unify pdl_thread per_pdl_flags, par_flags */ #define PDL_CORE_VERSION 20 #include "EXTERN.h" /* std perl include */ #include "perl.h" /* std perl include */ #include "XSUB.h" /* for the win32 perlCAPI crap */ #include "ppport.h" /* include this AFTER XSUB.h */ #include #if defined(CONTEXT) && defined(__osf__) #undef CONTEXT #endif #ifdef PDL_IN_CORE #define PDL_CORE_(func) pdl_##func #else #define PDL_CORE_(func) PDL->func #endif #include "pdl.h" /* the next one causes trouble in c++ compiles - exclude for now */ #ifndef __cplusplus #include "pdlmagic.h" #endif #define BIGGESTOF(a,b) ( a->nvals>b->nvals ? a->nvals : b->nvals ) #define SVavref(x) (SvROK(x) && SvTYPE(SvRV(x))==SVt_PVAV) /* Use our own barf and our own warn. * We defer barf (and warn) handling until after multi-threaded (i.e pthreading) * processing is finished. * This is needed because segfaults happen when perl's croak is called * during one of the spawned pthreads for PDL processing. */ #define barf PDL_CORE_(pdl_barf) #undef warn #define warn PDL_CORE_(pdl_warn) pdl_error pdl_makescratchhash(pdl *ret, PDL_Anyval data); PDL_Indx av_ndcheck(AV* av, AV* dims, int level, int *datalevel); pdl* pdl_from_array(AV* av, AV* dims, int type, pdl* p); PDL_Anyval pdl_at( void* x, int datatype, PDL_Indx* pos, PDL_Indx* dims, /* Value at x,y,z,... */ PDL_Indx *incs, PDL_Indx offset, PDL_Indx ndims); pdl_error pdl_writebackdata_vaffine(pdl *it); pdl_error pdl_readdata_vaffine(pdl *it); /* pdlutil.c */ typedef enum { PDL_FLAGS_TRANS, PDL_FLAGS_PDL, PDL_FLAGS_VTABLE } pdl_flags; pdl_error pdl_croak_param(pdl_transvtable *transvtable, int paramIndex, char *pat, ...); void pdl_print_iarr(PDL_Indx *iarr, int n); void pdl_dump_thread(pdl_thread *thread); void pdl_dump_threading_info( int npdls, PDL_Indx* creating, int target_pthread, PDL_Indx *nthreadedDims, PDL_Indx **threadedDims, PDL_Indx **threadedDimSizes, int maxPthreadPDL, int maxPthreadDim, int maxPthread ); void pdl_thread_mismatch_msg( char *s, pdl **pdls, pdl_thread *thread, PDL_Indx i, PDL_Indx j, PDL_Indx nimpl, PDL_Indx *realdims,PDL_Indx *creating ); void pdl_dump_flags_fixspace(int flags, int nspac, pdl_flags type); void pdl_dump_trans_fixspace(pdl_trans *it, int nspac); void pdl_dump_anyval(PDL_Anyval v); #define PDL_CORE_LIST(X) \ X(SvPDLV, pdl*, ( SV* )) \ X(SetSV_PDL, void, ( SV *sv, pdl *it )) \ X(pdlnew, pdl*, ()) \ X(destroy, pdl_error, (pdl *it)) \ X(null, pdl*, ()) \ X(scalar, pdl*, (PDL_Anyval anyval)) \ X(hard_copy, pdl*, ( pdl* )) \ X(converttype, pdl_error, ( pdl*, int )) \ X(smalloc, void*, ( STRLEN )) \ X(howbig, size_t, ( int )) \ X(packdims, PDL_Indx*, ( SV* sv, PDL_Indx *ndims )) \ X(setdims, pdl_error, ( pdl* it, PDL_Indx* dims, PDL_Indx ndims )) \ X(at0, PDL_Anyval, ( pdl* x )) \ X(reallocdims, pdl_error, ( pdl *it,PDL_Indx ndims )) \ X(reallocthreadids, pdl_error, ( pdl *it,PDL_Indx ndims )) \ X(resize_defaultincs, void, ( pdl *it )) /* Make incs out of dims */ \ X(clearthreadstruct, void, (pdl_thread *it)) \ X(initthreadstruct, pdl_error, (int nobl,pdl **pdls,PDL_Indx *realdims, \ PDL_Indx *creating,PDL_Indx npdls,pdl_transvtable *transvtable, \ pdl_thread *thread,PDL_Indx *ind_sizes,PDL_Indx *inc_sizes, \ char *flags, int noPthreadFlag)) \ X(redodims_default, pdl_error, (pdl_trans *)) \ X(startthreadloop, int, (pdl_thread *thread,pdl_error (*func)(pdl_trans *), \ pdl_trans *, pdl_error *)) \ X(get_threadoffsp, PDL_Indx*, (pdl_thread *thread)) /* For pthreading */ \ X(get_threaddims, PDL_Indx*, (pdl_thread *thread)) /* For pthreading */ \ X(iterthreadloop, int, (pdl_thread *thread, PDL_Indx which)) \ X(freethreadstruct, void, (pdl_thread *thread)) \ X(thread_create_parameter, pdl_error, (pdl_thread *thread,PDL_Indx j, \ PDL_Indx *dims, int temp)) \ X(add_deletedata_magic, pdl_error, (pdl *it,void (*func)(pdl *, Size_t param), \ Size_t param)) /* Automagic destructor */ \ X(setdims_careful, pdl_error, (pdl *pdl)) \ X(get_offs, PDL_Anyval, (pdl *pdl,PDL_Indx offs)) \ X(set, pdl_error, ( void* x, int datatype, PDL_Indx* pos, PDL_Indx* dims, \ PDL_Indx *incs, PDL_Indx offs, PDL_Indx ndims, PDL_Anyval value)) \ X(create_trans, pdl_trans *, (pdl_transvtable *vtable)) \ X(type_coerce, pdl_error, (pdl_trans *trans)) \ X(trans_badflag_from_inputs, char, (pdl_trans *trans)) \ X(get_convertedpdl, pdl *, (pdl *pdl,int type)) \ X(make_trans_mutual, pdl_error, (pdl_trans *trans)) \ X(make_physical, pdl_error, (pdl *it)) \ X(make_physdims, pdl_error, (pdl *it)) \ X(pdl_barf, void, (const char* pat,...)) \ X(pdl_warn, void, (const char* pat,...)) \ X(make_physvaffine, pdl_error, (pdl *it)) \ X(allocdata, pdl_error, (pdl *it)) \ X(safe_indterm, PDL_Indx, (PDL_Indx dsz, PDL_Indx at, char *file, int lineno)) \ X(propagate_badflag, void, (pdl *it, int newval)) \ X(propagate_badvalue, void, (pdl *it)) \ X(changed, pdl_error, (pdl *it, int what, int recursing)) \ X(get_pdl_badvalue, PDL_Anyval, (pdl *it)) \ X(get_badvalue, PDL_Anyval, (int datatype)) \ X(set_datatype, pdl_error, (pdl *a, int datatype)) \ X(hdr_copy, SV *, (SV *hdrp)) \ X(hdr_childcopy, void, (pdl_trans *trans)) \ X(readdata_affine, pdl_error, (pdl_trans *trans)) \ X(writebackdata_affine, pdl_error, (pdl_trans *trans)) \ X(affine_new, pdl_error, (pdl *par,pdl *child,PDL_Indx offs,PDL_Indx *dims,PDL_Indx ndims,PDL_Indx *incs,PDL_Indx nincs)) \ X(converttypei_new, pdl_error, (pdl *par,pdl *child,int type)) \ X(dump, void, (pdl *it)) \ X(sever, pdl_error, (pdl *a)) \ X(slice_args_parse_sv, pdl_slice_args*, ( SV* )) \ X(online_cpus, int, ()) \ X(magic_get_thread, int, (pdl *)) \ X(pdl_seed, uint64_t, ()) \ X(trans_check_pdls, pdl_error, (pdl_trans *trans)) \ X(make_error, pdl_error, (pdl_error_type e, const char *fmt, ...)) \ X(make_error_simple, pdl_error, (pdl_error_type e, const char *msg)) \ X(barf_if_error, void, (pdl_error err)) \ X(error_accumulate, pdl_error, (pdl_error err_current, pdl_error err_new)) /*************** Function prototypes *********************/ #define X(sym, rettype, args) \ rettype pdl_ ## sym args; PDL_CORE_LIST(X) #undef X #define X(symbol, ctype, ppsym, ...) \ PDL_Indx pdl_setav_ ## ppsym(ctype * pdata, AV* av, \ PDL_Indx* pdims, PDL_Long ndims, int level, ctype undefval, pdl *p); PDL_TYPELIST_ALL(X) #undef X /* Structure to hold pointers core PDL routines so as to be used by many modules */ #if defined(PDL_clean_namespace) || defined(PDL_OLD_API) #error PDL_clean_namespace and PDL_OLD_API defines have been removed. Use PDL->pdlnew() instead of PDL->new(). #endif struct Core { I32 Version; badvals bvals; /* store the default bad values */ #define X(sym, rettype, args) \ rettype (*sym) args; PDL_CORE_LIST(X) #undef X }; typedef struct Core Core; #define PDL_DECLARE_PARAMETER(type, flag, name, pdlname) \ type *name ## _datap = ((type *)(PDL_REPRP_TRANS(pdlname, flag))); \ type *name ## _physdatap = ((type *)(pdlname->data)); \ (void)name ## _datap; \ (void)name ## _physdatap; #define PDL_DECLARE_PARAMETER_BADVAL(type, flag, name, pdlname) \ PDL_DECLARE_PARAMETER(type, flag, name, pdlname) \ type name ## _badval = 0; \ PDL_Anyval name ## _anyval_badval = PDL_CORE_(get_pdl_badvalue)(pdlname); \ (void)name ## _badval; \ (void)name ## _anyval_badval; \ ANYVAL_TO_CTYPE(name ## _badval, type, name ## _anyval_badval); /* __PDLCORE_H */ #endif PDL-2.074/Basic/Core/pdl.h.PL0000644000175000017500000006161514200046177015260 0ustar osboxesosboxesuse strict; use warnings; require './Types.pm'; require './Config.pm'; die "No PDL::Config found" unless %PDL::Config; my $mymalloc = $PDL::Config{MALLOCDBG}->{define} // ''; my $file = shift @ARGV; print "Extracting $file\n"; open OUT,">$file" or die "Can't create $file: $!"; chmod 0644, $file; print OUT sprintf qq{#line %d "%s"\n}, __LINE__ + 2, __FILE__; print OUT <<'EOF'; /* * THIS FILE IS GENERATED FROM pdl.h.PL! Do NOT edit! */ #ifndef __PDL_H #define __PDL_H #include #include #include #include #define IND_FLAG "td" #define PDL_DEBUGGING 1 #ifdef PDL_DEBUGGING extern int pdl_debugging; #define PDLDEBUG_f(a) if(pdl_debugging) { a; fflush(stdout); } #else #define PDLDEBUG_f(a) #endif typedef struct pdl pdl; EOF my @methods = qw(symbol ctype ppsym shortctype defbval realctype); sub makeg { map { my $t = $_; [map $t->$_, @methods] } grep $_[0]->($_), PDL::Types::types() } sub makelister { my ($name, $is2, $underscore, @list) = @_; my $suff = $is2 ? '2' : ''; my $arg1 = $is2 ? 'X, X2' : 'X'; my $arg2 = $is2 ? 'X2, ' : ''; $underscore = $underscore ? '_' : ''; ("#define PDL_TYPELIST${suff}_$name$underscore($arg1) \\\n", (map " X($arg2".join(',', @$_).")\\\n", @list), "\n\n"); } my @generics = makeg(sub {1}); my @generics_real = makeg(sub {$_[0]->real}); my @generics_complex = makeg(sub {!$_[0]->real}); print OUT makelister('ALL', 0, 0, @generics); print OUT makelister('ALL', 1, 0, @generics); # extra as macro gets expanded twice, gets painted blue print OUT makelister('ALL', 1, 1, @generics); print OUT makelister('REAL', 0, 0, @generics_real); print OUT makelister('REAL', 1, 0, @generics_real); print OUT makelister('COMPLEX', 0, 0, @generics_real); print OUT makelister('COMPLEX', 1, 0, @generics_real); print OUT sprintf qq{#line %d "%s"\n}, __LINE__ + 2, __FILE__; print OUT <<'EOF'; #define X(sym, ...) \ , sym typedef enum { PDL_INVALID=-1 PDL_TYPELIST_ALL(X) } pdl_datatypes; #undef X #define X(sym, ctype, ppsym, shortctype, defbval, realctype, ...) \ typedef realctype ctype; PDL_TYPELIST_ALL(X) #undef X typedef union { #define X(sym, ctype, ppsym, shortctype, defbval, realctype, ...) \ ctype ppsym; PDL_TYPELIST_ALL(X) #undef X } PDL_Value; typedef struct { pdl_datatypes type; PDL_Value value; } PDL_Anyval; #include "pdlthread.h" /* Auto-PThreading (i.e. multi-threading) settings for PDL functions */ /* Target number of pthreads: Actual will be this number or less. A 0 here means no pthreading */ extern int pdl_autopthread_targ; /* Actual number of pthreads: This is the number of pthreads created for the last operation where pthreading was used A 0 here means no pthreading */ extern int pdl_autopthread_actual; /* Minimum size of the target PDL involved in pdl function to attempt pthreading (in MBytes ) For small PDLs, it probably isn't worth starting multiple pthreads, so this variable is used to define that threshold (in M-elements, or 2^20 elements ) */ extern int pdl_autopthread_size; extern PDL_Indx pdl_autopthread_dim; EOF print OUT "$mymalloc\n"; print OUT <<'EOF'; #define PDL_GENERICSWITCH_CASE(X, symbol, ...) \ case symbol: { X(symbol, __VA_ARGS__) } break; #define PDL_GENERICSWITCH(LISTER2, typevar, X2, dflt) \ switch (typevar) { \ LISTER2(PDL_GENERICSWITCH_CASE, X2) \ default: dflt; \ } /* extra as first one gets painted blue */ #define PDL_GENERICSWITCH_CASE2(X, symbol, ...) \ case symbol: { X(symbol, __VA_ARGS__) } break; /* for use in inner loops avoiding extreme lambda-calculus stuff */ #define PDL_GENERICSWITCH2(LISTER2, typevar, X2, dflt) \ switch (typevar) { \ LISTER2(PDL_GENERICSWITCH_CASE2, X2) \ default: dflt; \ } EOF for my $type (PDL::Types::types()) { my ($ppsym) = map $type->$_, qw(ppsym); my $expr = !$type->usenan ? 0 : $type->isnan('x') . '?1:0'; # isnan can return any non-0 print OUT "#define PDL_ISNAN_$ppsym(x) ($expr)\n"; my $expr2 = !$type->usenan ? 1 : $type->isfinite('x') . '?1:0'; print OUT "#define PDL_ISFINITE_$ppsym(x) ($expr2)\n"; } print OUT sprintf qq{#line %d "%s"\n}, __LINE__ + 2, __FILE__; print OUT <<'EOF'; #define ANYVAL_FROM_CTYPE(outany,avtype,inval) do { switch (avtype) { \ EOF print OUT "case @{[$_->sym]}: outany.type = avtype; outany.value.@{[$_->ppsym]} = (@{[$_->ctype]})(inval); break; \\\n" for PDL::Types::types(); print OUT <<'EOF'; default: outany.type = -1; outany.value.B = 0; \ } \ } while (0) EOF print OUT sprintf qq{#line %d "%s"\n}, __LINE__ + 2, __FILE__; print OUT <<'EOF'; #define ANYVAL_TO_CTYPE(outval,ctype,inany) do { switch (inany.type) { \ EOF print OUT "case @{[$_->sym]}: outval = (ctype)(inany.value.@{[$_->ppsym]}); break; \\\n" for PDL::Types::types(); print OUT <<'EOF'; default: outval = 0; \ } \ } while (0) EOF print OUT <<'EOF'; #define ANYVAL_FROM_CTYPE_OFFSET(outany,avtype,indata,ioff) do { switch (avtype) { \ EOF print OUT "case @{[$_->sym]}: outany.type = avtype; outany.value.@{[$_->ppsym]} = (@{[$_->ctype]})((@{[$_->ctype]} *)indata)[ioff]; break; \\\n" for PDL::Types::types(); print OUT <<'EOF'; default: outany.type = -1; outany.value.B = 0; \ } \ } while (0) EOF print OUT sprintf qq{#line %d "%s"\n}, __LINE__ + 2, __FILE__; print OUT <<'!NO!SUBS!'; /* input vars have to be called exactly these as not expanded */ #define ANYVAL_TO_CTYPE_OFFSET_X(datatype, ctype, ...) \ ANYVAL_TO_CTYPE(((ctype *)x)[ioff], ctype, value); #define ANYVAL_TO_CTYPE_OFFSET(x,ioff,datatype,value) \ PDL_GENERICSWITCH(PDL_TYPELIST2_ALL, datatype, ANYVAL_TO_CTYPE_OFFSET_X, return pdl_make_error(PDL_EUSERERROR, "Not a known data type code=%d", datatype)) #define ANYVAL_ISNAN(x) _anyval_isnan(x) static inline int _anyval_isnan(PDL_Anyval x) { #define X(datatype, ctype, ppsym, ...) \ return PDL_ISNAN_ ## ppsym(x.value.ppsym); PDL_GENERICSWITCH(PDL_TYPELIST2_ALL, x.type, X, return -1) #undef X } #define ANYVAL_EQ_ANYVAL(x,y) (_anyval_eq_anyval(x,y)) static inline int _anyval_eq_anyval(PDL_Anyval x, PDL_Anyval y) { #define X_OUTER(datatype_x, ctype_x, ppsym_x, ...) \ ctype_x cvalue_x = x.value.ppsym_x; \ PDL_GENERICSWITCH2(PDL_TYPELIST2_ALL_, y.type, X_INNER, return -1) #define X_INNER(datatype_y, ctype_y, ppsym_y, ...) \ return (cvalue_x == y.value.ppsym_y) ? 1 : 0; PDL_GENERICSWITCH(PDL_TYPELIST2_ALL, x.type, X_OUTER, return -1) #undef X_INNER #undef X_OUTER } #define ANYVAL_ISBAD(inany,badval) _anyval_isbad(inany,badval) static inline int _anyval_isbad(PDL_Anyval inany, PDL_Anyval badval) { int isnan_badval = ANYVAL_ISNAN(badval); if (isnan_badval == -1) return -1; return isnan_badval ? ANYVAL_ISNAN(inany) : ANYVAL_EQ_ANYVAL(inany, badval); } #define PDL_ISBAD(inval,badval,ppsym) \ (PDL_ISNAN_ ## ppsym(badval) ? PDL_ISNAN_ ## ppsym(inval) : inval == badval) typedef struct badvals { #define X(symbol, ctype, ppsym, shortctype, ...) ctype shortctype; PDL_TYPELIST_ALL(X) #undef X } badvals; /* * Define the pdl C data structure which maps onto the original PDL * perl data structure. * * Note: pdl.sv is defined as a void pointer to avoid having to * include perl.h in C code which just needs the pdl data. * * We start with the meanings of the pdl.flags bitmapped flagset, * continue with a prerequisite "trans" structure that represents * transformations between linked PDLs, and finish withthe PD * structure itself. */ #define PDL_NDIMS 6 /* Number of dims[] to preallocate */ #define PDL_NCHILDREN 8 /* Number of trans_children ptrs to preallocate */ #define PDL_NTHREADIDS 4 /* Number of different threadids/pdl to preallocate */ /* Constants for pdl.state - not all combinations make sense */ /* data allocated for this pdl. this implies that the data */ /* is up to date if !PDL_PARENTCHANGED */ #define PDL_ALLOCATED 0x0001 /* Parent data has been altered without changing this pdl */ #define PDL_PARENTDATACHANGED 0x0002 /* Parent dims or incs has been altered without changing this pdl. */ #define PDL_PARENTDIMSCHANGED 0x0004 /* Physical data representation of the parent has changed (e.g. */ /* physical transposition), so incs etc. need to be recalculated. */ #define PDL_ANYCHANGED (PDL_PARENTDATACHANGED|PDL_PARENTDIMSCHANGED) /* Dataflow tracking flags -- F/B for forward/back. These get set */ /* by transformations when they are set up. */ #define PDL_DATAFLOW_F 0x0010 #define PDL_DATAFLOW_B 0x0020 #define PDL_DATAFLOW_ANY (PDL_DATAFLOW_F|PDL_DATAFLOW_B) /* Was this PDL null originally? */ #define PDL_NOMYDIMS 0x0040 /* Dims should be received via trans. */ #define PDL_MYDIMS_TRANS 0x0080 /* OK to attach a vaffine transformation (i.e. a slice) */ #define PDL_OPT_VAFFTRANSOK 0x0100 #define PDL_OPT_ANY_OK (PDL_OPT_VAFFTRANSOK) /* This is the hdrcpy flag */ #define PDL_HDRCPY 0x0200 /* This is a badval flag for this PDL (hmmm -- there is also a flag */ /* in the struct itself -- must be clearer about what this is for. --CED) */ #define PDL_BADVAL 0x0400 /* Debugging flag */ #define PDL_TRACEDEBUG 0x0800 /* inplace flag */ #define PDL_INPLACE 0x1000 /* Flag indicating destruction in progress */ #define PDL_DESTROYING 0x2000 /* If this flag is set, you must not alter the data pointer nor */ /* free this ndarray nor use datasv (which should be null). */ /* This means e.g. that the ndarray is mmapped from a file */ #define PDL_DONTTOUCHDATA 0x4000 /* whether the given pdl is getting its dims from the given trans */ #define PDL_DIMS_FROM_TRANS(wtrans,pdl) (((pdl)->state & PDL_MYDIMS_TRANS) \ && (pdl)->trans_parent == (pdl_trans *)(wtrans)) #define PDL_LIST_FLAGS_PDLSTATE(X) \ X(PDL_ALLOCATED) \ X(PDL_PARENTDATACHANGED) \ X(PDL_PARENTDIMSCHANGED) \ X(PDL_DATAFLOW_F) \ X(PDL_DATAFLOW_B) \ X(PDL_NOMYDIMS) \ X(PDL_MYDIMS_TRANS) \ X(PDL_OPT_VAFFTRANSOK) \ X(PDL_HDRCPY) \ X(PDL_BADVAL) \ X(PDL_TRACEDEBUG) \ X(PDL_INPLACE) \ X(PDL_DESTROYING) \ X(PDL_DONTTOUCHDATA) /************************************************** * * Transformation structure * * The structure is general enough to deal with functional transforms * (which were originally intended) but only slices and retype transforms * were implemented. * */ /* Transformation flags */ #define PDL_TRANS_DO_THREAD 0x0001 #define PDL_TRANS_BADPROCESS 0x0002 #define PDL_TRANS_BADIGNORE 0x0004 #define PDL_TRANS_NO_PARALLEL 0x0008 #define PDL_LIST_FLAGS_PDLVTABLE(X) \ X(PDL_TRANS_DO_THREAD) \ X(PDL_TRANS_BADPROCESS) \ X(PDL_TRANS_BADIGNORE) \ X(PDL_TRANS_NO_PARALLEL) /* Transpdl flags */ #define PDL_TPDL_VAFFINE_OK 0x01 typedef struct pdl_trans pdl_trans; typedef enum { PDL_ENONE = 0, /* usable as boolean */ PDL_EUSERERROR, /* user error, no need to destroy */ PDL_EFATAL } pdl_error_type; typedef struct { pdl_error_type error; const char *message; /* if error but this NULL, parsing/alloc error */ char needs_free; } pdl_error; typedef struct pdl_transvtable { int flags; int iflags; /* flags that are starting point for pdl_trans.flags */ pdl_datatypes *gentypes; /* ordered list of types handled, ending -1 */ PDL_Indx nparents; PDL_Indx npdls; char *per_pdl_flags; PDL_Indx *par_realdims; /* quantity of dimensions each par has */ char **par_names; short *par_flags; pdl_datatypes *par_types; PDL_Indx *par_realdim_ind_start; /* each par, where do its inds start in array above */ PDL_Indx *par_realdim_ind_ids; /* each realdim, which ind is source */ PDL_Indx nind_ids; PDL_Indx ninds; char **ind_names; /* sorted names of "indices", eg for a(m), the "m" */ pdl_error (*redodims)(pdl_trans *tr); /* Only dims and internal trans (makes phys) */ pdl_error (*readdata)(pdl_trans *tr); /* Only data, to "data" ptr */ pdl_error (*writebackdata)(pdl_trans *tr); /* "data" ptr to parent or granny */ pdl_error (*freetrans)(pdl_trans *tr, char); int structsize; char *name; /* For debuggers, mostly */ } pdl_transvtable; /* offset into either par_realdim_ind_ids or inc_sizes */ #define PDL_INC_ID(vtable, i, j) \ ((vtable)->par_realdim_ind_start[i] + j) /* which ind_id (named dim) for the i-th pdl (aka param) in a vtable, the j-th dim on that param */ #define PDL_IND_ID(vtable, i, j) \ ((vtable)->par_realdim_ind_ids[PDL_INC_ID(vtable, i, j)]) #define PDL_PARAM_ISREAL 0x0001 #define PDL_PARAM_ISCOMPLEX 0x0002 #define PDL_PARAM_ISTYPED 0x0004 #define PDL_PARAM_ISTPLUS 0x0008 #define PDL_PARAM_ISCREAT 0x0010 #define PDL_PARAM_ISCREATEALWAYS 0x0020 #define PDL_PARAM_ISOUT 0x0040 #define PDL_PARAM_ISTEMP 0x0080 #define PDL_PARAM_ISWRITE 0x0100 #define PDL_PARAM_ISPHYS 0x0200 #define PDL_PARAM_ISIGNORE 0x0400 #define PDL_LIST_FLAGS_PARAMS(X) \ X(PDL_PARAM_ISREAL) \ X(PDL_PARAM_ISCOMPLEX) \ X(PDL_PARAM_ISTYPED) \ X(PDL_PARAM_ISTPLUS) \ X(PDL_PARAM_ISCREAT) \ X(PDL_PARAM_ISCREATEALWAYS) \ X(PDL_PARAM_ISOUT) \ X(PDL_PARAM_ISTEMP) \ X(PDL_PARAM_ISWRITE) \ X(PDL_PARAM_ISPHYS) \ X(PDL_PARAM_ISIGNORE) /* All trans must start with this */ /* Trans flags */ /* Reversible transform -- flag indicates data can flow both ways. */ /* This is critical in routines that both input from and output to */ /* a non-single-valued pdl: updating must occur. (Note that the */ /* transform is not necessarily mathematically reversible) */ #define PDL_ITRANS_TWOWAY 0x0001 /* Whether, if a child is changed, this trans should be destroyed or not */ /* (flow if set; sever if clear) */ #define PDL_ITRANS_DO_DATAFLOW_F 0x0002 #define PDL_ITRANS_DO_DATAFLOW_B 0x0004 #define PDL_ITRANS_DO_DATAFLOW_ANY (PDL_ITRANS_DO_DATAFLOW_F|PDL_ITRANS_DO_DATAFLOW_B) #define PDL_ITRANS_ISAFFINE 0x1000 #define PDL_LIST_FLAGS_PDLTRANS(X) \ X(PDL_ITRANS_TWOWAY) \ X(PDL_ITRANS_DO_DATAFLOW_F) \ X(PDL_ITRANS_DO_DATAFLOW_B) \ X(PDL_ITRANS_ISAFFINE) #define PDL_MAXSPACE 256 /* maximal number of prefix spaces in dump routines */ #define PDL_MAXLIN 60 // These define struct pdl_trans and all derived structures. There are many // structures that defined in other parts of the code that can be referenced // like a pdl_trans* because all of these structures have the same pdl_trans // initial piece. These structures can contain multiple pdl* elements in them. // Thus pdl_trans itself ends with a flexible pdl*[] array, which can be used to // reference any number of pdl objects. As a result pdl_trans itself can NOT be // instantiated #define PDL_TRANS_START_COMMON \ unsigned int magicno; \ short flags; \ pdl_transvtable *vtable; \ int bvalflag; \ pdl_thread pdlthread; \ PDL_Indx *ind_sizes; \ PDL_Indx *inc_sizes; \ char dims_redone; \ PDL_Indx *incs; PDL_Indx offs; /* only used for affine */ \ void *params; \ pdl_datatypes __datatype #define PDL_TRANS_START(np) \ PDL_TRANS_START_COMMON; \ /* The pdls involved in the transformation */ \ pdl *pdls[np] #define PDL_TRANS_START_FLEXIBLE() \ PDL_TRANS_START_COMMON; \ /* The pdls involved in the transformation */ \ pdl *pdls[] #define PDL_CHKMAGIC_GENERAL(it,this_magic,type) if((it)->magicno != this_magic) return pdl_make_error(PDL_EFATAL, "INVALID " #type "MAGIC NO 0x%p %d%s\n",it,(int)((it)->magicno), ((it)->magicno) == PDL_CLEARED_MAGICNO ? " (cleared)" : ""); else (void)0 #define PDL_TR_MAGICNO 0x91827364 #define PDL_TR_SETMAGIC(it) it->magicno = PDL_TR_MAGICNO #define PDL_TR_CLRMAGIC(it) it->magicno = PDL_CLEARED_MAGICNO #define PDL_TR_CHKMAGIC(it) PDL_CHKMAGIC_GENERAL(it, PDL_TR_MAGICNO, "TRANS ") // This is a generic parent of all the trans structures. It is a flexible array // (can store an arbitrary number of pdl objects). Thus this can NOT be // instantiated, only "child" structures can struct pdl_trans { PDL_TRANS_START_FLEXIBLE(); } ; typedef struct pdl_vaffine { PDL_TRANS_START(2); PDL_Indx ndims; pdl *from; } pdl_vaffine; #define PDL_VAFFOK(pdl) (pdl->state & PDL_OPT_VAFFTRANSOK) #define PDL_REPRINCS(pdl) (PDL_VAFFOK(pdl) ? pdl->vafftrans->incs : pdl->dimincs) #define PDL_REPRINC(pdl,which) (PDL_REPRINCS(pdl)[which]) #define PDL_REPROFFS(pdl) (PDL_VAFFOK(pdl) ? pdl->vafftrans->offs : 0) #define PDL_REPRP(pdl) (PDL_VAFFOK(pdl) ? pdl->vafftrans->from->data : pdl->data) #define PDL_TR_VAFFOK(flag) (flag & PDL_TPDL_VAFFINE_OK) #define PDL_REPRP_TRANS(pdl,flag) ((PDL_VAFFOK(pdl) && \ PDL_TR_VAFFOK(flag)) ? pdl->vafftrans->from->data : pdl->data) #define VAFFINE_FLAG_OK(flags,i) ((flags == NULL) ? 1 : PDL_TR_VAFFOK(flags[i])) typedef struct pdl_trans_children { pdl_trans *trans[PDL_NCHILDREN]; struct pdl_trans_children *next; } pdl_trans_children; struct pdl_magic; /**************************************** * PDL structure * Should be kept under 250 bytes if at all possible, for * easier segmentation... * See current size (360 bytes at time of writing) with: perl -Mblib -MInline=with,PDL \ -MInline=C,'size_t f() { return sizeof(struct pdl); }' -e 'die f()' * * The 'sv', 'datasv', and 'hdrsv' fields are all void * to avoid having to * load perl.h for C codes that only use PDLs and not the Perl API. * * Similarly, the 'magic' field is void * to avoid having to typedef pdl_magic * here -- it is declared in "pdl_magic.h". */ #define PDL_MAGICNO 0x24645399 #define PDL_CLEARED_MAGICNO 0x99876134 /* value once "cleared" */ #define PDL_CHKMAGIC(it) PDL_CHKMAGIC_GENERAL(it,PDL_MAGICNO,"") struct pdl { unsigned long magicno; /* Always stores PDL_MAGICNO as a sanity check */ /* This is first so most pointer accesses to wrong type are caught */ int state; /* What's in this pdl */ pdl_trans *trans_parent; /* Opaque pointer to internals of transformation from parent */ pdl_vaffine *vafftrans; /* pointer to vaffine transformation a vafftrans is an optimization that is possible for some types of trans (slice etc) - unused for non-affine transformations */ void* sv; /* (optional) pointer back to original sv. ALWAYS check for non-null before use. We cannot inc refcnt on this one or we'd never get destroyed */ void *datasv; /* Pointer to SV containing data. We own one inc of refcnt */ void *data; /* Pointer to actual data (in SV), or NULL if we have no data */ PDL_Anyval badvalue; /* BAD value is stored as a PDL_Anyval for portability */ int has_badvalue; /* whether this pdl has non-default badval */ PDL_Indx nvals; /* Real number of elements (not quite nelem in case of dummy) */ PDL_Indx nbytes; /* number of bytes allocated in data */ pdl_datatypes datatype; /* One of the usual suspects (PDL_L, PDL_D, etc.) */ PDL_Indx *dims; /* Array of data dimensions - could point below or to an allocated array */ PDL_Indx *dimincs; /* Array of data default increments, aka strides through memory for each dim (0 for dummies) */ PDL_Indx ndims; /* Number of data dimensions in dims and dimincs */ PDL_Indx *threadids; /* Starting index of the thread index set n */ PDL_Indx nthreadids; pdl_trans_children trans_children; PDL_Indx def_dims[PDL_NDIMS]; /* Preallocated space for efficiency */ PDL_Indx def_dimincs[PDL_NDIMS]; /* Preallocated space for efficiency */ PDL_Indx def_threadids[PDL_NTHREADIDS]; struct pdl_magic *magic; void *hdrsv; /* "header", settable from Perl */ }; typedef struct pdl_slice_args { PDL_Indx start; /* maps to start index of slice range (inclusive) */ PDL_Indx end; /* maps to end index of slice range (inclusive) */ PDL_Indx inc; /* maps to increment of slice range */ char dummy, squish; /* boolean */ struct pdl_slice_args *next; /* NULL is last */ } pdl_slice_args; /************* * Some macros for looping over the trans_children of a given PDL */ #define PDL_DECL_CHILDLOOP(p) \ int p##__i; pdl_trans_children *p##__c; #define PDL_START_CHILDLOOP(p) \ p##__c = &p->trans_children; \ do { \ for(p##__i=0; p##__itrans[p##__i]) { #define PDL_CHILDLOOP_THISCHILD(p) p##__c->trans[p##__i] #define PDL_END_CHILDLOOP(p) \ } \ } \ if(!p##__c) break; \ if(!p##__c->next) break; \ p##__c=p##__c->next; \ } while(1); #define PDLMAX(a,b) ((a) > (b) ? (a) : (b)) #define PDLMIN(a,b) ((a) < (b) ? (a) : (b)) /*************** * Some macros to guard against dataflow infinite recursion. */ #define DECL_RECURSE_GUARD static int __nrec=0; #define START_RECURSE_GUARD __nrec++; if(__nrec > 1000) {__nrec=0; return pdl_make_error_simple(PDL_EUSERERROR, "PDL:Internal Error: data structure recursion limit exceeded (max 1000 levels)\n\tThis could mean that you have found an infinite-recursion error in PDL, or\n\tthat you are building data structures with very long dataflow dependency\n\tchains. You may want to try using sever() to break the dependency.\n");} #define ABORT_RECURSE_GUARD __nrec=0; #define END_RECURSE_GUARD __nrec--; #define PDL_RETERROR(rv, expr) \ do { rv = expr; if (rv.error) return rv; } while (0) #define PDL_ENSURE_ALLOCATED(it) \ if (!(it->state & PDL_ALLOCATED)) { \ PDL_RETERROR(PDL_err, pdl_allocdata(it)); \ } /* for use with PDL_TYPELIST_REAL */ #define PDL_QSORT(symbol, ctype, ppsym, ...) \ static inline void qsort_ ## ppsym(ctype* xx, PDL_Indx a, PDL_Indx b) { \ PDL_Indx i,j; \ ctype t, median; \ i = a; j = b; \ median = xx[(i+j) / 2]; \ do { \ while (xx[i] < median) \ i++; \ while (median < xx[j]) \ j--; \ if (i <= j) { \ t = xx[i]; xx[i] = xx[j]; xx[j] = t; \ i++; j--; \ } \ } while (i <= j); \ if (a < j) \ qsort_ ## ppsym(xx,a,j); \ if (i < b) \ qsort_ ## ppsym(xx,i,b); \ } #define PDL_EXPAND(...) __VA_ARGS__ #define PDL_THREADLOOP_START(funcName, thr, vtable, ptrStep1, ptrStep2, ptrStep3) \ __thrloopval = PDL->startthreadloop(&(thr),(vtable)->funcName, __privtrans, &PDL_err); \ if (PDL_err.error) return PDL_err; \ if ( __thrloopval < 0 ) return PDL->make_error_simple(PDL_EFATAL, "Error starting threadloop"); \ if ( __thrloopval ) return PDL_err; \ do { \ PDL_Indx *__tdims = PDL->get_threaddims(&(thr)); \ if (!__tdims) return PDL->make_error_simple(PDL_EFATAL, "Error in get_threaddims"); \ register PDL_Indx __tdims0 = __tdims[0]; \ register PDL_Indx __tdims1 = __tdims[1]; \ register PDL_Indx *__offsp = PDL->get_threadoffsp(&(thr)); \ if (!__offsp ) return PDL->make_error_simple(PDL_EFATAL, "Error in get_threadoffsp"); \ PDL_COMMENT("incs are each pdl's stride, declared at func start") \ PDL_COMMENT("offs are each pthread's starting offset into each pdl") \ ptrStep1 \ for( __tind1 = 0 ; \ __tind1 < __tdims1 ; \ __tind1++ \ PDL_COMMENT("step by tinc1, undoing inner-loop of tinc0*tdims0") \ PDL_EXPAND ptrStep2 \ ) \ { \ for( __tind0 = 0 ; \ __tind0 < __tdims0 ; \ __tind0++ \ PDL_EXPAND ptrStep3 \ ) { \ PDL_COMMENT("This is the tightest threadloop. Make sure inside is optimal.") #define PDL_THREADLOOP_END(thr, ptrStep1) \ } \ } \ PDL_COMMENT("undo outer-loop of tinc1*tdims1, and original per-pthread offset") \ ptrStep1 \ __thrloopval = PDL->iterthreadloop(&(thr),2); \ if ( __thrloopval < 0 ) return PDL->make_error_simple(PDL_EFATAL, "Error in iterthreadloop"); \ } while(__thrloopval); /* __PDL_H */ #endif !NO!SUBS! PDL-2.074/Basic/Core/pdlcore.c0000644000175000017500000013240014200101477015574 0ustar osboxesosboxes#include "pdl.h" /* Data structure declarations */ #define PDL_IN_CORE /* access funcs directly not through PDL-> */ #include "pdlcore.h" /* Core declarations */ #include "pdlperl.h" static SV *getref_pdl(pdl *it) { SV *newref; if(!it->sv) { newref = newRV_noinc(it->sv = newSViv(PTR2IV(it))); (void)sv_bless(newref,gv_stashpv("PDL",TRUE)); } else { newref = newRV_inc(it->sv); SvAMAGIC_on(newref); } return newref; } void pdl_SetSV_PDL ( SV *sv, pdl *it ) { SV *newref = getref_pdl(it); /* YUCK!!!! */ sv_setsv(sv,newref); SvREFCNT_dec(newref); } /* Size of data type information */ size_t pdl_howbig (int datatype) { #define X(datatype, ctype, ...) \ return sizeof(ctype); PDL_GENERICSWITCH(PDL_TYPELIST2_ALL, datatype, X, croak("Not a known data type code=%d", datatype)) #undef X } /* Make a scratch dataspace for a scalar pdl */ pdl_error pdl_makescratchhash(pdl *ret, PDL_Anyval data) { pdl_error PDL_err = {0, NULL, 0}; PDLDEBUG_f(printf("pdl_makescratchhash type=%d val=", data.type); pdl_dump_anyval(data); printf("\n");); ret->datatype = data.type; ret->ndims = 0; pdl_resize_defaultincs(ret); PDL_RETERROR(PDL_err, pdl_allocdata(ret)); ret->ndims = 1; ret->dims[0] = 0; pdl_resize_defaultincs(ret); ret->state &= ~PDL_ALLOCATED; PDLDEBUG_f(printf("pdl_makescratchhash after alloc: "); pdl_dump(ret);); /* Refcnt should be 1 already... */ /* Make the whole pdl mortal so destruction happens at the right time. * If there are dangling references, pdlapi.c knows not to actually * destroy the C struct. */ sv_2mortal(getref_pdl(ret)); /* NULLs should be ok because no dimensions. */ PDL_RETERROR(PDL_err, pdl_set(ret->data, ret->datatype, NULL, NULL, NULL, 0, 0, data)); return PDL_err; } /* "Convert" a perl SV into a pdl (alright more like a mapping as the data block is not actually copied in the most common case of a single scalar) scalars are automatically converted to PDLs. */ pdl* pdl_SvPDLV ( SV* sv ) { pdl* ret; SV *sv2; if(sv_derived_from(sv, "PDL") && !SvROK(sv)) { /* object method called as class method */ pdl_pdl_barf("called object method on 'PDL' or similar"); } if ( !SvROK(sv) ) { /* The scalar is not a ref, so we can use direct conversion. */ PDL_Anyval data; ANYVAL_FROM_SV(data, sv, TRUE, -1); PDLDEBUG_f(printf("pdl_SvPDLV type: %d\n", data.type)); return pdl_scalar(data); } /* End of scalar case */ if(sv_derived_from(sv, "Math::Complex")) { dSP; int count, i; NV retval; double vals[2]; char *meths[] = { "Re", "Im" }; PDL_Anyval data; ENTER; SAVETMPS; for (i = 0; i < 2; i++) { PUSHMARK(sp); XPUSHs(sv); PUTBACK; count = perl_call_method(meths[i], G_SCALAR); SPAGAIN; if (count != 1) croak("Failed Math::Complex method '%s'", meths[i]); retval = POPn; vals[i] = (double)retval; PUTBACK; } FREETMPS; LEAVE; data.type = PDL_CD; data.value.C = (PDL_CDouble)(vals[0] + I * vals[1]); return pdl_scalar(data); } /* If execution reaches here, then sv is NOT a scalar * (i.e. it is a ref). */ if(SvTYPE(SvRV(sv)) == SVt_PVHV) { HV *hash = (HV*)SvRV(sv); SV **svp = hv_fetchs(hash,"PDL",0); if(svp == NULL) { croak("Hash given as a pdl (%s) - but not {PDL} key!", sv_reftype(SvRV(sv), TRUE)); } if(*svp == NULL) { croak("Hash given as a pdl (%s) - but not {PDL} key (*svp)!", sv_reftype(SvRV(sv), TRUE)); } /* This is the magic hook which checks to see if {PDL} is a code ref, and if so executes it. It should return a standard ndarray. This allows all kinds of funky objects to be derived from PDL, and allow normal PDL functions to still work so long as the {PDL} code returns a standard ndarray on demand - KGB */ if (SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVCV) { dSP; int count; ENTER ; SAVETMPS ; PUSHMARK(sp) ; count = perl_call_sv(*svp, G_SCALAR|G_NOARGS); SPAGAIN ; if (count != 1) croak("Execution of PDL structure failed to return one value\n") ; sv=newSVsv(POPs); PUTBACK ; FREETMPS ; LEAVE ; } else { sv = *svp; } if(SvGMAGICAL(sv)) { mg_get(sv); } if ( !SvROK(sv) ) { /* Got something from a hash but not a ref */ croak("Hash given as pdl - but PDL key is not a ref!"); } } if(SvTYPE(SvRV(sv)) == SVt_PVAV) { /* This is similar to pdl_avref in Core.xs.PL -- we do the same steps here. */ AV *dims, *av; int datalevel = -1; av = (AV *)SvRV(sv); dims = (AV *)sv_2mortal((SV *)newAV()); av_store(dims,0,newSViv( (IV) av_len(av)+1 ) ); /* Pull sizes using av_ndcheck */ av_ndcheck(av,dims,0,&datalevel); return pdl_from_array(av, dims, -1, NULL); /* -1 means pdltype autodetection */ } /* end of AV code */ if (SvTYPE(SvRV(sv)) != SVt_PVMG) croak("Error - tried to use an unknown data structure as a PDL"); else if( !( sv_derived_from( sv, "PDL") ) ) croak("Error - tried to use an unknown Perl object type as a PDL"); sv2 = (SV*) SvRV(sv); /* Return the pdl * pointer */ ret = INT2PTR(pdl *, SvIV(sv2)); /* Final check -- make sure it has the right magic number */ if(ret->magicno != PDL_MAGICNO) { croak("Fatal error: argument is probably not an ndarray, or\ magic no overwritten. You're in trouble, guv: %p %p %lu\n",sv2,ret,ret->magicno); } return ret; } /* Pack dims array - returns dims[] (pdl_smalloced) and ndims */ PDL_Indx* pdl_packdims ( SV* sv, PDL_Indx *ndims ) { if (!(SvROK(sv) && SvTYPE(SvRV(sv))==SVt_PVAV)) /* Test */ return NULL; AV *array = (AV *) SvRV(sv); /* dereference */ *ndims = (PDL_Indx) av_len(array) + 1; /* Number of dimensions */ PDL_Indx *dims = (PDL_Indx *) pdl_smalloc( (*ndims) * sizeof(*dims) ); /* Array space */ if (dims == NULL) return NULL; PDL_Indx i; for(i=0; i<(*ndims); i++) { dims[i] = (PDL_Indx) SvIV(*(av_fetch( array, i, 0 ))); } return dims; } PDL_Indx pdl_safe_indterm( PDL_Indx dsz, PDL_Indx at, char *file, int lineno) { if (!(at >= 0 && at < dsz)) pdl_pdl_barf("access [%d] out of range [0..%d] (inclusive) at %s line %d", at, dsz-1, file?file:"?", lineno); return at; } /* pdl_smalloc - utility to get temporary memory space. Uses a mortal *SV for this so it is automatically freed when the current context is terminated without having to call free(). Naughty but nice! */ void* pdl_smalloc ( STRLEN nbytes ) { SV* work = sv_2mortal(newSVpv("", 0)); SvGROW( work, nbytes); return (void *) SvPV_nolen(work); } /*********** Stuff for barfing *************/ /* This routine barfs/warns in a thread-safe manner. If we're in the main thread, this calls the perl-level barf/warn. If in a worker thread, we save the message to barf/warn in the main thread later For greppability: this is where pdl_pdl_barf and pdl_pdl_warn are defined */ static void pdl_barf_or_warn(const char* pat, int iswarn, va_list* args) { /* If we're in a worker thread, we queue the * barf/warn for later, and exit the thread ... */ if( pdl_pthread_barf_or_warn(pat, iswarn, args) ) return; /* ... otherwise we fall through and barf by calling * the perl-level PDL::barf() or PDL::cluck() */ dSP; ENTER; SAVETMPS; PUSHMARK(SP); SV *sv = sv_2mortal(newSV(0)); int size = vsnprintf(NULL, 0, pat, *args); va_end(*args); if (size < 0) { sv_setpv(sv, "vsnprintf error"); } else { size += 2; /* For '\0' + 1 as CentOS 7 is off by 1 */ char buf[size]; size = vsnprintf(buf, size, pat, *args); va_end(*args); sv_setpv(sv, size < 0 ? "vsnprintf error" : buf); } XPUSHs(sv); PUTBACK; call_pv(iswarn ? "PDL::cluck" : "PDL::barf", G_DISCARD); FREETMPS; LEAVE; } #define GEN_PDL_BARF_OR_WARN_I_STDARG(type, iswarn) \ void pdl_pdl_##type(const char* pat, ...) \ { \ va_list args; \ va_start(args, pat); \ pdl_barf_or_warn(pat, iswarn, &args); \ } GEN_PDL_BARF_OR_WARN_I_STDARG(barf, 0) GEN_PDL_BARF_OR_WARN_I_STDARG(warn, 1) /********************************************************************** * * CONSTRUCTOR/INGESTION HELPERS * * The following routines assist with the permissive constructor, * which is designed to build a PDL out of basically anything thrown at it. * * They are all called by pdl_avref in Core.xs, which in turn is called by the constructors * in Core.pm.PL. The main entry point is pdl_from_array(), which calls * av_ndcheck() to identify the necessary size of the output PDL, and then dispatches * the copy into pdl_setav_ according to the type of the output PDL. * */ /****************************** * av_ndcheck - * traverse a Perl array ref recursively, following down any number of * levels of references, and generate a minimal PDL dim list that can * encompass them all according to permissive-constructor rules. * * Scalars, array refs, and PDLs may be mixed in the incoming AV. * * The routine works out the dimensions of a corresponding * ndarray (in the AV dims) in reverse notation (vs PDL conventions). * * It does not enforce a rectangular array on the input, the idea being that * omitted values will be set to zero or the undefval in the resulting ndarray, * i.e. we can make ndarrays from 'sparse' array refs. * * Empty PDLs are treated like any other dimension -- i.e. their * 0-length dimensions are thrown into the mix just like nonzero * dimensions would be. * * The possible presence of empty PDLs forces us to pad out dimensions * to unity explicitly in cases like * [ Empty[2x0x2], 5 ] * where simple parsing would yield a dimlist of * [ 2,0,2,2 ] * which is still Empty. */ PDL_Indx av_ndcheck(AV* av, AV* dims, int level, int *datalevel) { PDL_Indx i, len, oldlen; int newdepth, depth = 0; int n_scalars = 0; SV *el, **elp; pdl *dest_pdl; /* Stores PDL argument */ if(dims==NULL) { pdl_pdl_barf("av_ndcheck - got a null dim array! This is a bug in PDL."); } /* Start with a clean slate */ if(level==0) { av_clear(dims); } len = av_len(av); /* Loop over elements of the AV */ for (i=0; i<= len; i++) { newdepth = 0; /* Each element - find depth */ elp = av_fetch(av,i,0); el = elp ? *elp : 0; /* Get the ith element */ if (el && SvROK(el)) { /* It is a reference */ if (SvTYPE(SvRV(el)) == SVt_PVAV) { /* It is an array reference */ /* Recurse to find depth inside the array reference */ newdepth = 1 + av_ndcheck((AV *) SvRV(el), dims, level+1, datalevel); } else if ( (dest_pdl = pdl_SvPDLV(el)) ) { /* It is a PDL - walk down its dimension list, exactly as if it * were a bunch of nested array refs. We pull the ndims and dims * fields out to local variables so that nulls can be treated specially. */ int j; short pndims; PDL_Indx *dest_dims; pdl_barf_if_error(pdl_make_physdims(dest_pdl)); pndims = dest_pdl->ndims; dest_dims = dest_pdl->dims; for(j=0;j= jl && av_fetch(dims,jl,0) != NULL && SvIOK(*(av_fetch(dims,jl,0)))) { /* We have already found something that specifies this dimension -- so */ /* we keep the size if possible, or enlarge if necessary. */ oldlen=(PDL_Indx)SvIV(*(av_fetch(dims,jl,0))); if(siz > oldlen) { sv_setiv(*(av_fetch(dims,jl,0)),(IV)(dest_dims[j])); } } else { /* Breaking new dimensional ground here -- if this is the first element */ /* in the arg list, then we can keep zero elements -- but if it is not */ /* the first element, we have to pad zero dims to unity (because the */ /* prior object had implicit size of 1 in all implicit dimensions) */ av_store(dims, jl, newSViv((IV)(siz?siz:(i?1:0)))); } } /* We have specified all the dims in this PDL. Now pad out the implicit */ /* dims of size unity, to wipe out any dims of size zero we have already */ /* marked. */ for(j=pndims+1; j <= av_len(dims); j++) { SV **svp = av_fetch(dims,j,0); if(!svp){ av_store(dims, j, newSViv((IV)1)); } else if( (int)SvIV(*svp) == 0 ) { sv_setiv(*svp, (IV)1); } } newdepth= pndims; } else { croak("av_ndcheck: non-array, non-PDL ref in structure\n\t(this is usually a problem with a pdl() call)"); } } else { /* got a scalar (not a ref) */ n_scalars++; } if (newdepth > depth) depth = newdepth; } len++; // convert from funky av_len return value to real count if (av_len(dims) >= level && av_fetch(dims, level, 0) != NULL && SvIOK(*(av_fetch(dims, level, 0)))) { oldlen = (PDL_Indx) SvIV(*(av_fetch(dims, level, 0))); if (len > oldlen) sv_setiv(*(av_fetch(dims, level, 0)), (IV) len); } else av_store(dims,level,newSViv((IV) len)); /* We found at least one element -- so pad dims to unity at levels earlier than this one */ if(n_scalars) { for(i=0;i, below, based on the * type of the destination PDL. */ pdl* pdl_from_array(AV* av, AV* dims, int dtype, pdl* dest_pdl) { int ndims, i, level=0; PDL_Anyval undefval = { PDL_INVALID, {0} }; ndims = av_len(dims)+1; PDL_Indx dest_dims[ndims]; for (i=0; idatatype = dtype; err = pdl_allocdata (dest_pdl); if (err.error) return NULL; err = pdl_make_physical(dest_pdl); if (err.error) return NULL; /****** * Copy the undefval to fill empty spots in the ndarray... */ PDLDEBUG_f(printf("pdl_from_array type: %d\n", dtype)); ANYVAL_FROM_SV(undefval, NULL, TRUE, dtype); #define X(dtype, ctype, ppsym, ...) \ pdl_setav_ ## ppsym(dest_pdl->data,av,dest_dims,ndims,level, undefval.value.ppsym, dest_pdl); PDL_GENERICSWITCH(PDL_TYPELIST2_ALL, dtype, X, return NULL) #undef X return dest_pdl; } /* Compute offset of (x,y,z,...) position in row-major list */ PDL_Indx pdl_get_offset(PDL_Indx* pos, PDL_Indx* dims, PDL_Indx *incs, PDL_Indx offset, PDL_Indx ndims) { PDL_Indx i; PDL_Indx result; for(i=0; i=dims[i]) return -1; } result = offset; for (i=0; invals < 1) { return result; } return pdl_at(PDL_REPRP(it), it->datatype, &nullp, &dummyd, &dummyi, PDL_REPROFFS(it),1); } /* Return value at position (x,y,z...) */ PDL_Anyval pdl_at( void* x, int datatype, PDL_Indx* pos, PDL_Indx* dims, PDL_Indx* incs, PDL_Indx offset, PDL_Indx ndims) { PDL_Anyval result = { PDL_INVALID, {0} }; PDL_Indx ioff = pdl_get_offset(pos, dims, incs, offset, ndims); if (ioff < 0) return result; ANYVAL_FROM_CTYPE_OFFSET(result, datatype, x, ioff); return result; } /* Set value at position (x,y,z...) */ pdl_error pdl_set( void* x, int datatype, PDL_Indx* pos, PDL_Indx* dims, PDL_Indx* incs, PDL_Indx offs, PDL_Indx ndims, PDL_Anyval value){ pdl_error PDL_err = {0, NULL, 0}; PDL_Indx ioff = pdl_get_offset(pos, dims, incs, offs, ndims); if (ioff < 0) return pdl_make_error_simple(PDL_EUSERERROR, "Position out of range"); ANYVAL_TO_CTYPE_OFFSET(x, ioff, datatype, value); return PDL_err; } /* * pdl_kludge_copy_ - copy a PDL into a part of a being-formed PDL. * It is only used by pdl_setav_, to handle the case where a PDL is part * of the argument list. * * kludge_copy recursively walks down the dim list of both the source and dest * pdls, copying values in as we go. It differs from PP copy in that it operates * on only a portion of the output pdl. * * (If I were Lazier I would have popped up into the perl level and used threadloops to * assign to a slice of the output pdl -- but this is probably a little faster.) * * -CED 17-Jun-2004 * * Arguments: * dest_off is an integer indicating which element along the current direction is being treated (for padding accounting) * dest_data is a pointer into the destination PDL's data; * dest_dims is a pointer to the destination PDL's dim list; * ndims is the size of the destination PDL's dimlist; * level is the conjugate dimension along which copying is happening (indexes dest_dims). * "conjugate" means that it counts backward through the dimension array. * stride is the increment in the data array corresponding to this dimension; * * pdl is the input PDL. * plevel is the dim number for the input PDL, which works in the same sense as level. * It is offset to account for the difference in dimensionality between the input and * output PDLs. It is allowed to be negative (which is equivalent to the "permissive * slicing" that treats missing dimensions as present and having size 1), but should * not match or exceed pdl->ndims. * source_data is the current offset data pointer into pdl->data. * * Kludge-copy works backward through the dim lists, so that padding is simpler: if undefval * padding is required at any particular dimension level, the padding occupies a contiguous * block of memory. */ #define INNERLOOP_X(datatype, ctype, ppsym, ...) \ /* copy data (unless the source pointer is null) */ \ i=0; \ if(source_data && dest_data && pdlsiz) { \ found_bad = 0; \ for(; ihas_badvalue || (source_pdl->state & PDL_BADVAL)) { \ /* Retrieve directly from .value.* instead of using ANYVAL_EQ_ANYVAL */ \ if( ((ctype *)source_data)[i] == source_badval.value.ppsym || PDL_ISNAN_ ## ppsym(((ctype *)source_data)[i]) ) { \ /* bad value in source PDL -- use our own type's bad value instead */ \ ANYVAL_TO_CTYPE(dest_data[i], ctype, dest_badval); \ found_bad = 1; \ } else { \ dest_data[i] = ((ctype *)source_data)[i]; \ } \ } else { \ dest_data[i] = ((ctype *)source_data)[i]; \ } \ } /* end of loop over pdlsiz */ \ if (found_bad) dest_pdl->state |= PDL_BADVAL; /* just once */ \ } else { \ /* source_data or dest_data or pdlsiz are 0 */ \ if(dest_data) \ dest_data[i] = undefval; \ } \ /* pad out, in the innermost dimension */ \ if( !oob ) { \ undef_count += dest_dims[0]-dest_off-i; \ for(; i< dest_dims[0]-dest_off; i++) dest_data[i] = undefval; \ } #define PDL_KLUDGE_COPY_X(X, datatype_out, ctype_out, ppsym_out, ...) \ PDL_Indx pdl_kludge_copy_ ## ppsym_out(PDL_Indx dest_off, /* Offset into the dest data array */ \ ctype_out* dest_data, /* Data pointer in the dest data array */ \ PDL_Indx* dest_dims,/* Pointer to the dimlist for the dest pdl */ \ PDL_Indx ndims, /* Number of dimensions in the dest pdl */ \ int level, /* Recursion level */ \ PDL_Indx stride, /* Stride through memory for the current dim */ \ pdl* source_pdl, /* pointer to the source pdl */ \ int plevel, /* level within the source pdl */ \ void* source_data, /* Data pointer in the source pdl */ \ ctype_out undefval, /* undefval for the dest pdl */ \ pdl* dest_pdl /* pointer to the dest pdl */ \ ) { \ PDL_Indx i; \ PDL_Indx undef_count = 0; \ /* Can't copy into a level deeper than the number of dims in the output PDL */ \ if(level > ndims ) { \ fprintf(stderr,"pdl_kludge_copy: level=%d; ndims=%"IND_FLAG"\n",level,ndims); \ croak("Internal error - please submit a bug report at https://github.com/PDLPorters/pdl/issues:\n pdl_kludge_copy: Assertion failed; ndims-1-level (%"IND_FLAG") < 0!.",ndims-1-level); \ } \ if(level >= ndims - 1) { \ /* We are in as far as we can go in the destination PDL, so direct copying is in order. */ \ int pdldim = source_pdl->ndims - 1 - plevel; /* which dim are we working in the source PDL? */ \ PDL_Indx pdlsiz; \ int oob = (ndims-1-level < 0); /* out-of-bounds flag */ \ /* Do bounds checking on the source dimension -- if we wander off the end of the \ * dimlist, we are doing permissive-slicing kind of stuff (not enough dims in the \ * source to fully account for the output dimlist); if we wander off the beginning, we \ * are doing dimensional padding. In either case, we just iterate once. \ */ \ if(pdldim < 0 || pdldim >= source_pdl->ndims) { \ pdldim = (pdldim < 0) ? (0) : (source_pdl->ndims - 1); \ pdlsiz = 1; \ } else { \ pdlsiz = source_pdl->dims[pdldim]; \ } \ /* This is used inside the switch in order to detect badvalues. */ \ PDL_Anyval source_badval = pdl_get_pdl_badvalue(source_pdl); \ if (source_badval.type < 0) barf("Error getting badvalue, type=%d", source_badval.type); \ PDL_Anyval dest_badval = pdl_get_pdl_badvalue(dest_pdl); \ if (dest_badval.type < 0) barf("Error getting badvalue, type=%d", dest_badval.type); \ char found_bad = 0; \ PDL_GENERICSWITCH(PDL_TYPELIST2_ALL_, source_pdl->datatype, X, croak("Not a known data type code=%d", source_pdl->datatype)) \ return undef_count; \ } \ /* If we are here, we are not at the bottom level yet. So walk \ * across this dim and handle copying one dim deeper via recursion. \ * The loop is placed in a convenience block so we can define the \ * dimensional boundscheck flag -- that avoids having to evaluate the complex \ * ternary expression for every loop iteration. \ */ \ { \ PDL_Indx limit = ( \ (plevel >= 0 && \ (source_pdl->ndims - 1 - plevel >= 0) \ ) \ ? (source_pdl->dims[ source_pdl->ndims-1-plevel ]) \ : 1 \ ); \ for(i=0; i < limit ; i++) { \ undef_count += pdl_kludge_copy_ ## ppsym_out(0, dest_data + stride * i, \ dest_dims, \ ndims, \ level+1, \ stride / ((dest_dims[ndims-2-level]) ? (dest_dims[ndims-2-level]) : 1), \ source_pdl, \ plevel+1, \ ((PDL_Byte *) source_data) + source_pdl->dimincs[source_pdl->ndims-1-plevel] * i * pdl_howbig(source_pdl->datatype), \ undefval, \ dest_pdl \ ); \ } /* end of kludge_copy recursion loop */ \ } /* end of recursion convenience block */ \ /* pad the rest of this dim to zero if there are not enough elements in the source PDL... */ \ if(i < dest_dims[ndims - 1 - level]) { \ int cursor, target; \ cursor = i * stride; \ target = dest_dims[ndims-1-level]*stride; \ undef_count += target - cursor; \ for(; \ cursor < target; \ cursor++) { \ dest_data[cursor] = undefval; \ } \ } /* end of padding IF statement */ \ return undef_count; \ } PDL_TYPELIST2_ALL(PDL_KLUDGE_COPY_X, INNERLOOP_X) #undef PDL_KLUDGE_COPY_X /* * pdl_setav_ loads a new PDL with values from a Perl AV, another PDL, or * a mix of both. Heterogeneous sizes are handled by padding the new PDL's * values out to size with the undefval. It is only called by pdl_setav in Core.XS, * via the trampoline pdl_from_array just above. pdl_from_array dispatches execution * to pdl_setav_ according to the type of the destination PDL. * * The code is complicated by the "bag-of-stuff" nature of AVs. We handle * Perl scalars, AVs, *and* PDLs (via pdl_kludge_copy). * * - dest_data is the data pointer from a PDL * - av is the array ref (or PDL) to use to fill the data with, * - dest_dims is the dimlist * - ndims is the size of the dimlist * - level is the recursion level, which is also the dimension that we are filling */ #define PDL_SETAV_X(X, datatype_out, ctype_out, ppsym_out, ...) \ PDL_Indx pdl_setav_ ## ppsym_out(ctype_out* dest_data, AV* av, \ PDL_Indx* dest_dims, int ndims, int level, ctype_out undefval, pdl *dest_pdl) \ { \ PDL_Indx cursz = dest_dims[ndims-1-level]; /* we go from the highest dim inward */ \ PDL_Indx len = av_len(av); \ PDL_Indx i,stride=1; \ SV *el, **elp; \ PDL_Indx undef_count = 0; \ for (i=0;i= 0 && pddex < ndims ? dest_dims[ pddex ] : 0); \ if(!pd) \ pd = 1; \ undef_count += pdl_kludge_copy_ ## ppsym_out(0, dest_data,dest_dims,ndims, level+1, stride / pd , pdl, 0, pdl->data, undefval, dest_pdl); \ } else { /* el==0 || SvROK(el)==0: this is a scalar or undef element */ \ if( PDL_SV_IS_UNDEF(el) ) { /* undef case */ \ *dest_data = (ctype_out) undefval; \ undef_count++; \ } else { /* scalar case */ \ *dest_data = SvIOK(el) ? (ctype_out) SvIV(el) : (ctype_out) SvNV(el); \ } \ /* Pad dim if we are not deep enough */ \ if(level < ndims-1) { \ ctype_out *cursor = dest_data; \ ctype_out *target = dest_data + stride; \ undef_count += stride; \ for( cursor++; cursor < target; cursor++ ) \ *cursor = (ctype_out)undefval; \ } \ } \ } /* end of element loop through the supplied AV */ \ /* in case this dim is incomplete set any remaining elements to the undefval */ \ if(len < cursz-1 ) { \ ctype_out *target = dest_data + stride * (cursz - 1 - len); \ undef_count += target - dest_data; \ for( ; dest_data < target; dest_data++ ) \ *dest_data = (ctype_out) undefval; \ } \ /* If the Perl scalar PDL::debug is set, announce padding */ \ if(level==0 && undef_count) { \ if(SvTRUE(get_sv("PDL::debug",0))) { \ fflush(stdout); \ fprintf(stderr,"Warning: pdl_setav_" #ppsym_out " converted undef to $PDL::undefval (%g) %"IND_FLAG" time%s\\n",(double)undefval,undef_count,undef_count==1?"":"s"); \ fflush(stderr); \ } \ } \ return undef_count; \ } PDL_TYPELIST2_ALL(PDL_SETAV_X, INNERLOOP_X) #undef PDL_SETAV_X #undef INNERLOOP_X SV *pdl_hdr_copy(SV *hdrp) { /* call the perl routine _hdr_copy */ int count; SV *retval; dSP; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs( hdrp ); PUTBACK; count = call_pv("PDL::_hdr_copy",G_SCALAR); SPAGAIN; if (count != 1) croak("PDL::_hdr_copy didn\'t return a single value - please report this bug (B)."); retval = (SV *) POPs ; if(retval != &PL_sv_undef ) (void)SvREFCNT_inc(retval); FREETMPS; LEAVE; return retval; } /* examine the various PDLs that form the output PDL, and copy headers as necessary. The first header found with the hdrcpy bit set is used. This used to do just a simple ref copy but now it uses the perl routine PDL::_hdr_copy to do the dirty work. That routine makes a deep copy of the header. Copies of the deep copy are distributed to all the names of the ndarray that are not the source of the header. I believe that is the Right Thing to do but I could be wrong. Here's the flow: - Check the hdrcpy flag. If it's set, then check the header to see if it exists. If it does, we need to call the perl-land PDL::_hdr_copy routine. There are some shenanigans to keep the return value from evaporating before we've had a chance to do our bit with it. - For each output argument in the function signature, try to put a reference to the new header into that argument's header slot. (For functions with multiple outputs, this produces multiple linked headers -- that could be Wrong; fixing it would require making yet more explicit copies!) - Remortalize the return value from PDL::_hdr_copy, so that we don't leak memory. --CED 12-Apr-2003 */ void pdl_hdr_childcopy(pdl_trans *trans) { void *hdrp = NULL; char propagate_hdrcpy = 0; SV *hdr_copy = NULL; pdl_transvtable *vtable = trans->vtable; pdl **pdls = trans->pdls; PDL_Indx i; for (i=0; inpdls; i++) { pdl *pdl = pdls[i]; short flags = vtable->par_flags[i]; if (!(flags & PDL_PARAM_ISTEMP) && (!(flags & PDL_PARAM_ISCREAT) || ((flags & PDL_PARAM_ISCREAT) && !PDL_DIMS_FROM_TRANS(trans,pdl))) && pdl->hdrsv && (pdl->state & PDL_HDRCPY) ) { hdrp = pdl->hdrsv; propagate_hdrcpy = ((pdl->state & PDL_HDRCPY) != 0); break; } } if (hdrp) { hdr_copy = ((hdrp == &PL_sv_undef) ? &PL_sv_undef : pdl_hdr_copy(hdrp)); /* Found the header -- now copy it into all the right places */ for (i=0; inpdls; i++) { pdl *pdl = pdls[i]; short flags = vtable->par_flags[i]; if (!(flags & PDL_PARAM_ISCREAT)) continue; if (pdl->hdrsv != hdrp) { if (pdl->hdrsv && pdl->hdrsv != &PL_sv_undef) (void)SvREFCNT_dec( pdl->hdrsv ); if (hdr_copy != &PL_sv_undef) (void)SvREFCNT_inc(hdr_copy); pdl->hdrsv = hdr_copy; } if (propagate_hdrcpy) pdl->state |= PDL_HDRCPY; } if(hdr_copy != &PL_sv_undef) SvREFCNT_dec(hdr_copy); /* make hdr_copy mortal again */ } } void pdl_dump_slice_args(pdl_slice_args* args) { printf("slice_args (%p):\n", args); while (args) { printf(" start=%"IND_FLAG", end=%"IND_FLAG", inc=%"IND_FLAG", squish=%d, dummy=%d, next=%p\n", args->start, args->end, args->inc, args->squish, args->dummy, args->next ); args = args->next; } } /****************************************************************/ /*** String handling part of slice is here. Parse out each ***/ /*** term: ***/ /*** (or NV) - extract one element from this dim ***/ /*** : - extract to ; autoreverse if nec. ***/ /*** :: - extract to , stepping by ***/ /*** () - extract element and discard this dim ***/ /*** * - insert a dummy dimension of size ***/ /*** : - keep this dim in its entirety ***/ /*** X - keep this dim in its entirety ***/ /****************************************************************/ pdl_error pdl_slice_args_parse_string(char* s, pdl_slice_args *retvalp) { PDLDEBUG_f(printf("slice_args_parse_string input: '%s'\n", s)); pdl_error PDL_error = {0, NULL, 0}; int subargno = 0; char flagged = 0; char squish_closed = 0, squish_flag = 0, dummy_flag = 0; pdl_slice_args this_arg = {0,-1,0}; /* start,end,inc 0=do in RedoDims */ PDL_Indx i = 0; while(*s) { if( isspace( *s ) ) { s++; /* ignore and loop again */ continue; } /* not whitespace */ switch(*(s++)) { case '*': if(flagged || subargno) return pdl_make_error(PDL_EUSERERROR, "slice: Erroneous '*' (arg %d)",i); dummy_flag = flagged = 1; this_arg.start = 1; /* default this number to 1 (size 1); '*0' yields an empty */ this_arg.end = 1; /* no second arg allowed - default to 1 so start is element count */ this_arg.inc = -1; /* -1 so we count down to end from start */ break; case '(': if(flagged || subargno) return pdl_make_error(PDL_EUSERERROR, "slice: Erroneous '(' (arg %d)",i); squish_flag = flagged = 1; break; case 'X': case 'x': if(flagged || subargno > 1) return pdl_make_error(PDL_EUSERERROR, "slice: Erroneous 'X' (arg %d)",i); if(subargno==0) { flagged = 1; } else /* subargno is 1 - squish */ { squish_flag = squish_closed = flagged = 1; } break; case '+': case '-': case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': switch(subargno) { case 0: /* first arg - change default to 1 element */ this_arg.end = this_arg.start = strtoll(--s, &s, 10); if(dummy_flag) this_arg.start = 1; break; case 1: /* second arg - parse and keep end */ this_arg.end = strtoll(--s, &s, 10); break; case 2: /* third arg - parse and keep inc */ if ( squish_flag || dummy_flag ) return pdl_make_error(PDL_EUSERERROR, "slice: erroneous third field in slice specifier (arg %d)",i); this_arg.inc = strtoll(--s, &s, 10); break; default: /* oops */ return pdl_make_error(PDL_EUSERERROR, "slice: too many subargs in scalar slice specifier %d",i); break; } break; case ')': if( squish_closed || !squish_flag || subargno > 0) return pdl_make_error(PDL_EUSERERROR, "slice: erroneous ')' (arg %d)",i); squish_closed = 1; break; case ':': if(squish_flag && !squish_closed) return pdl_make_error(PDL_EUSERERROR, "slice: must close squishing parens (arg %d)",i); if( subargno == 0 ) this_arg.end = -1; /* Set ":" default to get the rest of the range */ if( subargno > 1 ) return pdl_make_error(PDL_EUSERERROR, "slice: too many ':'s in scalar slice specifier %d",i); subargno++; break; case ',': return pdl_make_error_simple(PDL_EUSERERROR, "slice: ',' not allowed (yet) in scalar slice specifiers!"); break; default: return pdl_make_error(PDL_EUSERERROR, "slice: unexpected '%c' in slice specifier (arg %d)",*s,i); break; } i++; } /* end of parse loop */ this_arg.squish = squish_flag; this_arg.dummy = dummy_flag; PDLDEBUG_f(pdl_dump_slice_args(&this_arg)); *retvalp = this_arg; return PDL_error; } pdl_slice_args* pdl_slice_args_parse_sv(SV* sv) { /*** Make sure we got an array ref as input and extract its corresponding AV ***/ if(!(sv && SvROK(sv) && SvTYPE(SvRV(sv))==SVt_PVAV)) barf("slice requires an ARRAY ref containing zero or more arguments"); pdl_slice_args* retval = NULL, *this_arg_ptr = NULL; AV *arglist = (AV *)(SvRV(sv)); /* Detect special case of a single comma-delimited string; in that case, */ /* split out our own arglist. */ if (av_len(arglist) == 0) { /*** single-element list: pull first element ***/ SV **svp = av_fetch(arglist, 0, 0); if(svp && *svp && *svp != &PL_sv_undef && SvPOKp(*svp)) { /*** The element exists and is not undef and has a cached string value ***/ char *s,*ss; s = ss = SvPVbyte_nolen(*svp); for(; *ss && *ss != ','; ss++) {} if(*ss == ',') { char *s1; /* the string contains at least one comma. ATTACK! */ /* We make a temporary array and populate it with */ /* SVs containing substrings -- basically split(/\,/)... */ AV *al = (AV *)sv_2mortal((SV *)(newAV())); do { for(s1=s; *s1 && *s1 != ','; s1++); av_push(al, newSVpvn(s, s1-s)); s = (*s1==',') ? ++s1 : s1; } while(*s); arglist = al; /* al is ephemeral and will evaporate at the next perl gc */ } /* end of contains-comma case */ } /* end of nontrivial single-element detection */ }/* end of single-element detection */ PDL_Indx nargs = av_len( arglist ) + 1; /**********************************************************************/ /**** Loop over the elements of the AV input and parse into values ****/ /**** in the start/inc/end array ****/ PDL_Indx i; for(i=0; i 3) barf("slice: array refs can have at most 3 elements!"); if(nelem==0) { /* No elements - keep it all */ all_flag = 1; } else /* Got at least one element */{ /* Load the first into start and check for dummy or all-clear */ /* (if element is missing use the default value already in start) */ svp = av_fetch(sublist, 0, 0); if(svp && *svp && *svp != &PL_sv_undef) { /* There is a first element. Check if it's a string, then an IV */ if( SvPOKp(*svp)) { char *str = SvPVbyte_nolen(*svp); switch(*str) { case 'X': all_flag = 1; break; case '*': this_arg.dummy = 1; this_arg.start = 1; /* start is 1 so 2nd field is element count */ this_arg.end = 1; /* size defaults to 1 for dummy dims */ this_arg.inc = 1; /* inc is forced to 1 so ['*',0] gives an empty */ break; default: /* Doesn't start with '*' or 'X' */ this_arg.end = this_arg.start = SvIV(*svp); /* end defaults to start if start is present */ break; } } else /* the element has no associated string - just parse */ { this_arg.end = this_arg.start = SvIV(*svp); /* end defaults to start if start is present */ } } /* end of defined check. if it's undef, leave the n's at their default value. */ /* Read the second element into end and check for alternate squish syntax */ if( (nelem > 1) && (!all_flag) ) { svp = av_fetch(sublist, 1, 0); if( svp && *svp && *svp != &PL_sv_undef ) { if( SvPOKp(*svp) ) { /* Second element has a string - make sure it's not 'X'. */ char *str = SvPVbyte_nolen(*svp); if(*str == 'X') { this_arg.squish = 1; this_arg.end = this_arg.start; } else { this_arg.end = SvIV(*svp); } } else { /* Not a PDL, no string -- just get the IV */ this_arg.end = SvIV(*svp); } } /* If not defined, leave at the default */ } /* End of second-element check */ /*** Now try to read the third element (inc). ***/ if ((nelem > 2) && !(all_flag) && !(this_arg.squish) && !(this_arg.dummy)) { svp = av_fetch(sublist, 2, 0); if ( svp && *svp && *svp != &PL_sv_undef ) { STRLEN len; SvPV( *svp, len ); if(len>0) { /* nonzero length -> actual value given */ this_arg.inc = SvIV(*svp); /* if the step is passed in as 0, it is a squish */ if(this_arg.inc==0) { this_arg.end = this_arg.start; this_arg.squish = 1; } } } /* end of nontrivial third-element parsing */ } /* end of third-element parsing */ } /* end of nontrivial sublist parsing */ } else /* this argument is not an ARRAY ref - parse as a scalar */ { if(SvPOKp(this)) { /* this argument has a cached string */ STRLEN len; char *s = SvPVbyte(this, len); pdl_barf_if_error(pdl_slice_args_parse_string(s, &this_arg)); } else /* end of string parsing */ { /* Simplest case -- there's no cached string, so it */ /* must be a number. In that case it's a simple */ /* extraction. Treated as a separate case for speed. */ this_arg.end = this_arg.start = SvNV(this); this_arg.inc = 0; } } /* end of scalar handling */ } /* end of defined-element handling (!all_flag) */ if( (!all_flag) + (!this_arg.squish) + (!this_arg.dummy) < 2 ) barf("Looks like you triggered a bug in slice. two flags set in dim %d",i); /* Force all_flag case to be a "normal" slice */ if(all_flag) { this_arg.start = 0; this_arg.end = -1; this_arg.inc = 1; } if (!retval) this_arg_ptr = retval = pdl_smalloc(sizeof(*retval)); else { this_arg_ptr = this_arg_ptr->next = pdl_smalloc(sizeof(*retval)); } if (!this_arg_ptr) croak("Out of Memory\n"); /* Copy parsed values into the limits */ *this_arg_ptr = this_arg; } /* end of arg-parsing loop */ PDLDEBUG_f(pdl_dump_slice_args(retval)); return retval; } /* pdl_seed() - prefix as "seed" #define-d by Perl * * Used to seed PDL's built-in RNG. */ uint64_t pdl_pdl_seed() { /* This implementation is from section 7.1 Seeding of * * Helmut G. Katzgraber. "Random Numbers in Scientific Computing: * An Introduction". . */ uint64_t s, pid; /* Start of Perl-specific symbols */ Time_t seconds; pid = (uint64_t)PerlProc_getpid(); (void)time(&seconds); /* End of Perl-specific symbols */ s = (uint64_t)seconds; return abs(((s*181)*((pid-83)*359))%104729); } PDL-2.074/Basic/Core/IFiles.pm0000644000175000017500000000303614165337651015532 0ustar osboxesosboxes=head1 NAME PDL::Install::Files -- Module for use by L and L =head1 SYNOPSIS use Inline with => 'PDL'; # or alternatively, if your XS module uses PDL: use ExtUtils::Depends; my $pkg = ExtUtils::Depends->new(qw(MyPackage PDL)); =head1 DESCRIPTION This module is for use by L and L. There are no user-serviceable parts inside. =cut package PDL::Install::Files; use strict; use warnings; # support ExtUtils::Depends require PDL::Core::Dev; our $VERSION = '2.009'; my $self = { 'typemaps' => [ &PDL::Core::Dev::PDL_TYPEMAP ], 'inc' => &PDL::Core::Dev::PDL_INCLUDE, 'libs' => '', 'deps' => [], }; my @deps = @{ $self->{deps} }; my @typemaps = @{ $self->{typemaps} }; my $libs = $self->{libs}; my $inc = $self->{inc}; my $CORE = undef; foreach (@INC) { if ( -f "$_/PDL/Install/Files.pm") { $CORE = $_ . "/PDL/Install/"; last; } } sub deps { } # support: use Inline with => 'PDL'; require Inline; sub Inline { my ($class, $lang) = @_; return {} if $lang eq 'Pdlpp'; unless($ENV{"PDL_Early_Inline"} // ($Inline::VERSION >= 0.68) ) { die "PDL::Inline: requires Inline version 0.68 or higher to make sense\n (yours is $Inline::VERSION). You should upgrade Inline, \n or else set \$ENV{PDL_Early_Inline} to a true value to ignore this message.\n"; } +{ TYPEMAPS => [ &PDL::Core::Dev::PDL_TYPEMAP ], INC => &PDL::Core::Dev::PDL_INCLUDE, AUTO_INCLUDE => &PDL::Core::Dev::PDL_AUTO_INCLUDE, BOOT => &PDL::Core::Dev::PDL_BOOT, }; } 1; PDL-2.074/Basic/Core/pdlutil.c0000644000175000017500000003647214172756416015656 0ustar osboxesosboxes#include "pdl.h" /* Data structure declarations */ #include "pdlcore.h" /* Core declarations */ #include #define msgptr_advance() \ do { \ int N = strlen(msgptr); \ msgptr += N; \ remaining -= N; \ } while(0) #define SET_SPACE(s, nspac) char spaces[PDL_MAXSPACE]; do { \ int i; \ if (nspac >= PDL_MAXSPACE) { \ printf("too many spaces requested: %d" \ " (increase PDL_MAXSPACE in pdlapi.c), returning\n",nspac); \ return; \ } \ for(i=0; i= vtable->npdls) { strcat(msgptr, "ERROR: UNKNOWN PARAMETER"); msgptr_advance(); } else { snprintf(msgptr, remaining, "PDL: %s(", vtable->name); msgptr_advance(); for(i=0; inpdls; i++) { snprintf(msgptr, remaining, "%s", vtable->par_names[i]); msgptr_advance(); if(i < vtable->npdls-1) { snprintf(msgptr, remaining, ","); msgptr_advance(); } } snprintf(msgptr, remaining, "): Parameter '%s':\n", vtable->par_names[paramIndex]); msgptr_advance(); } } va_start(args,pat); vsnprintf(msgptr, remaining, pat, args); va_end(args); return pdl_make_error(PDL_EUSERERROR, "%s", message); } void pdl_print_iarr(PDL_Indx *iarr, int n) { int i; printf("("); for (i=0;itransvtable) { pdl_transvtable *vtable = thread->transvtable; psp; printf("Funcname: %s\n",vtable->name); psp; printf("Types: "); found=0; sz=0; for (i=0;vtable->gentypes[i]!=-1; i++) { if (sz>PDL_MAXLIN) {sz=0; printf("\n");psp;psp;} printf("%s%s",found ? ",":"",typechar[vtable->gentypes[i]]); found = 1; sz += strlen(typechar[vtable->gentypes[i]]); } printf("\n"); psp; printf("Parameters:\n"); for (i=0;inpdls;i++) { psp; psp; printf("%s(",vtable->par_names[i]); found=0; for (j=0;jpar_realdims[i];j++) { if (found) printf(","); found=1; printf("%s",vtable->ind_names[PDL_IND_ID(vtable, i, j)]); } printf(") ("); if (vtable->par_types[i] < 0) printf("no type"); else { for (j=0;typeval[j]>=0; j++) if (vtable->par_types[i] == typeval[j]) { printf("%s",typechar[j]); break; } } printf("): "); found=0; sz=0; for (j=0;paramflagval[j]!=0; j++) if (vtable->par_flags[i] & paramflagval[j]) { if (sz>PDL_MAXLIN) {sz=0; printf("\n");psp;psp;psp;} printf("%s",found ? "|":""); found = 1; printf("%s",paramflagchar[j]); sz += strlen(paramflagchar[j]); } if (!found) printf("(no flags set)"); printf("\n"); } psp; printf("Indices: "); for (i=0;ininds;i++) printf("%s ",vtable->ind_names[i]); printf("\n"); psp; printf("Realdims: "); pdl_print_iarr(vtable->par_realdims,thread->npdls); printf("\n"); } psp; printf("Flags: "); found=0; sz=0; for (i=0;flagval[i]!=0; i++) if (thread->gflags & flagval[i]) { if (sz>PDL_MAXLIN) {sz=0; printf("\n");psp;} printf("%s%s",found ? "|":"",flagchar[i]); found = 1; sz += strlen(flagchar[i]); } printf("\n"); psp; printf("Ndims: %"IND_FLAG", Nimplicit: %"IND_FLAG", Npdls: %"IND_FLAG", Nextra: %"IND_FLAG"\n", thread->ndims,thread->nimpl,thread->npdls,thread->nextra); psp; printf("Mag_nth: %"IND_FLAG", Mag_nthpdl: %"IND_FLAG", Mag_nthr: %"IND_FLAG", Mag_skip: %"IND_FLAG", Mag_stride: %"IND_FLAG"\n", thread->mag_nth,thread->mag_nthpdl,thread->mag_nthr,thread->mag_skip,thread->mag_stride); if (thread->mag_nthr <= 0) { psp; printf("Dims: "); pdl_print_iarr(thread->dims,thread->ndims); printf("\n"); psp; printf("Inds: "); pdl_print_iarr(thread->inds,thread->ndims); printf("\n"); psp; printf("Offs: "); pdl_print_iarr(thread->offs,thread->npdls); printf("\n"); } else { psp; printf("Dims (per thread):\n"); for (i=0;imag_nthr;i++) { psp; psp; pdl_print_iarr(thread->dims + i*thread->ndims,thread->ndims); printf("\n"); } psp; printf("Inds (per thread):\n"); for (i=0;imag_nthr;i++) { psp; psp; pdl_print_iarr(thread->inds + i*thread->ndims,thread->ndims); printf("\n"); } psp; printf("Offs (per thread):\n"); for (i=0;imag_nthr;i++) { psp; psp; pdl_print_iarr(thread->offs + i*thread->npdls,thread->npdls); printf("\n"); } } psp; printf("Incs (per dim):\n"); for (i=0;indims;i++) { psp; psp; pdl_print_iarr(&PDL_THR_INC(thread->incs, thread->npdls, 0, i),thread->npdls); printf("\n"); } psp; printf("Realdims: "); pdl_print_iarr(thread->realdims,thread->npdls); printf("\n"); psp; printf("Pdls: ("); for (i=0;inpdls;i++) printf("%s%p",(i?" ":""),(void*)(thread->pdls[i])); printf(")\n"); psp; printf("Per pdl flags: ("); for (i=0;inpdls;i++) printf("%s%d",(i?" ":""),thread->flags[i]); printf(")\n"); } void pdl_dump_threading_info( int npdls, PDL_Indx* creating, int target_pthread, PDL_Indx *nthreadedDims, PDL_Indx **threadedDims, PDL_Indx **threadedDimSizes, int maxPthreadPDL, int maxPthreadDim, int maxPthread ) { PDL_Indx j, k; for(j=0; jdims[i],pdls[j]->dims[i+realdims[j]], thread->npdls,nimpl,(nimpl==1)?"":"s" ); s += strlen(s); for(ii=maxrealdims=0; iinpdls; ii++) if(thread->realdims[ii]>maxrealdims) maxrealdims=thread->realdims[ii]; sprintf(s, " PDL IN EXPR. "); s += strlen(s); if(maxrealdims > 0) { char format[80]; sprintf(format,"%%%ds",8 * maxrealdims + 3); sprintf(s,format,"ACTIVE DIMS | "); s += strlen(s); } sprintf(s,"THREAD DIMS\n"); s += strlen(s); for(ii=0; iinpdls; ii++) { sprintf(s," #%3d (%s",ii,creating[ii]?"null)\n":"normal): "); s += strlen(s); if(creating[ii]) continue; if(maxrealdims == 1) { sprintf(s," "); s += strlen(s); } for(jj=0; jj< maxrealdims - thread->realdims[ii]; jj++) { sprintf(s,"%8s"," "); s += strlen(s); } for(jj=0; jj< thread->realdims[ii]; jj++) { sprintf(s,"%8"IND_FLAG,pdls[ii]->dims[jj]); s += strlen(s); } if(maxrealdims) { sprintf(s," | "); s += strlen(s); } for(jj=0; jjrealdims[ii] < pdls[ii]->ndims; jj++) { sprintf(s,"%8"IND_FLAG,pdls[ii]->dims[jj+thread->realdims[ii]]); s += strlen(s); } sprintf(s,"\n"); s += strlen(s); } } void pdl_dump_flags_fixspace(int flags, int nspac, pdl_flags type) { int i; int found = 0; size_t sz = 0; int pdlflagval[] = { #define X(f) f, PDL_LIST_FLAGS_PDLSTATE(X) #undef X 0 }; char *pdlflagchar[] = { #define X(f) #f, PDL_LIST_FLAGS_PDLSTATE(X) #undef X NULL }; int transflagval[] = { #define X(f) f, PDL_LIST_FLAGS_PDLTRANS(X) #undef X 0 }; char *transflagchar[] = { #define X(f) #f, PDL_LIST_FLAGS_PDLTRANS(X) #undef X NULL }; int vtableflagval[] = { #define X(f) f, PDL_LIST_FLAGS_PDLVTABLE(X) #undef X 0 }; char *vtableflagchar[] = { #define X(f) #f, PDL_LIST_FLAGS_PDLVTABLE(X) #undef X NULL }; int *flagval; char **flagchar; SET_SPACE(spaces, nspac); switch (type) { case PDL_FLAGS_PDL: { flagval = pdlflagval; flagchar = pdlflagchar; break; } case PDL_FLAGS_VTABLE: { flagval = vtableflagval; flagchar = vtableflagchar; break; } default: { flagval = transflagval; flagchar = transflagchar; } } printf("%sState: (%d) ",spaces,flags); found = 0; sz = 0; for (i=0;flagval[i]!=0; i++) if (flags & flagval[i]) { if (sz>PDL_MAXLIN) {sz=0; printf("\n %s",spaces);} printf("%s%s",found ? "|":"",flagchar[i]); found = 1; sz += strlen(flagchar[i]); } printf("\n"); } /* Dump a transformation (don't dump the pdls, just pointers to them */ void pdl_dump_trans_fixspace (pdl_trans *it, int nspac) { PDL_Indx i; SET_SPACE(spaces, nspac); printf("%sDUMPTRANS %p (%s)\n",spaces,(void*)it,it->vtable->name); pdl_dump_flags_fixspace(it->flags,nspac+3,PDL_FLAGS_TRANS); printf("%s vtable flags ",spaces); pdl_dump_flags_fixspace(it->vtable->flags,nspac+3,PDL_FLAGS_VTABLE); if(it->flags & PDL_ITRANS_ISAFFINE) { if(it->pdls[1]->state & PDL_PARENTDIMSCHANGED) { printf("%s AFFINE, BUT DIMSCHANGED\n",spaces); } else { printf("%s AFFINE: o:%"IND_FLAG", i:",spaces,it->offs); if (it->incs) pdl_print_iarr(it->incs, it->pdls[1]->ndims); printf(" d:"); pdl_print_iarr(it->pdls[1]->dims, it->pdls[1]->ndims); printf("\n"); } } /* if(it->vtable->dump) {it->vtable->dump(it);} */ printf("%s ind_sizes: ",spaces); pdl_print_iarr(it->ind_sizes, it->vtable->ninds); printf("\n"); printf("%s inc_sizes: ",spaces); pdl_print_iarr(it->inc_sizes, it->vtable->nind_ids); printf("\n"); printf("%s INPUTS: (",spaces); for(i=0; ivtable->nparents; i++) printf("%s%p",(i?" ":""),(void*)(it->pdls[i])); printf(") OUTPUTS: ("); for(;ivtable->npdls; i++) printf("%s%p",(i?" ":""),(void*)(it->pdls[i])); printf(")\n"); } void pdl_dump_fixspace(pdl *it,int nspac) { PDL_DECL_CHILDLOOP(it) PDL_Indx i; SET_SPACE(spaces, nspac); printf("%sDUMPING %p datatype: %d\n",spaces,(void*)it,it->datatype); pdl_dump_flags_fixspace(it->state,nspac+3,PDL_FLAGS_PDL); printf("%s transvtable: %p, trans: %p, sv: %p\n",spaces, (void*)(it->trans_parent?it->trans_parent->vtable:0), (void*)(it->trans_parent), (void*)(it->sv)); if(it->datasv) printf("%s datasv: %p, Svlen: %d, refcnt: %d\n", spaces, (void*)it->datasv, (int)SvCUR((SV*)it->datasv), (int)SvREFCNT((SV*)it->datasv)); if(it->data) printf("%s data: %p, nbytes: %"IND_FLAG", nvals: %"IND_FLAG"\n", spaces, (void*)(it->data), it->nbytes, it->nvals); if(it->hdrsv) printf("%s hdrsv: %p, reftype %s\n", spaces, (void*)it->hdrsv, sv_reftype((SV*)it->hdrsv, TRUE)); printf("%s Dims: %p ",spaces,(void*)it->dims); pdl_print_iarr(it->dims, it->ndims); printf("\n%s ThreadIds: %p ",spaces,(void*)(it->threadids)); pdl_print_iarr(it->threadids, it->nthreadids); if(PDL_VAFFOK(it)) { printf("\n%s Vaffine ok: %p (parent), o:%"IND_FLAG", i:", spaces,(void*)(it->vafftrans->from),it->vafftrans->offs); pdl_print_iarr(PDL_REPRINCS(it), it->vafftrans->ndims); } if(it->state & PDL_ALLOCATED) { printf("\n%s First values: (",spaces); for(i=0; invals && i<10; i++) { if (i) printf(" "); pdl_dump_anyval(pdl_get_offs(it,i)); } } else { printf("\n%s (not allocated",spaces); } printf(")\n"); if(it->trans_parent) { pdl_dump_trans_fixspace(it->trans_parent,nspac+3); } printf("%s CHILDREN:\n",spaces); PDL_START_CHILDLOOP(it) pdl_dump_trans_fixspace(PDL_CHILDLOOP_THISCHILD(it),nspac+4); PDL_END_CHILDLOOP(it) /* XXX phys etc. also */ } void pdl_dump (pdl *it) { pdl_dump_fixspace(it,0); } void pdl_dump_anyval(PDL_Anyval v) { if (v.type < PDL_CF) { #define X(datatype, ctype, ppsym, ...) \ printf("%Lg", (long double)v.value.ppsym); PDL_GENERICSWITCH(PDL_TYPELIST2_REAL, v.type, X, printf("(UNKNOWN PDL_Anyval type=%d)", v.type)) #undef X } else { #define X(datatype, ctype, ppsym, ...) \ printf("%Lg%+Lgi", creall((complex long double)v.value.ppsym), cimagl((complex long double)v.value.ppsym)); PDL_GENERICSWITCH(PDL_TYPELIST2_COMPLEX, v.type, X, printf("(UNKNOWN PDL_Anyval type=%d)", v.type)) #undef X } } void pdl_error_free(pdl_error e) { if (e.needs_free == 1) { free((void *)e.message); } else { /* needs mutex-protected and de-Perl-ified */ pdl_pthread_free((void *)e.message); } } void pdl_barf_if_error(pdl_error err) { if (!err.error) return; const char *msg = err.message; if (err.needs_free) { char *cpy = pdl_smalloc(strlen(msg) + 1); strcpy(cpy, err.message); pdl_error_free(err); msg = cpy; } pdl_pdl_barf(msg); } pdl_error pdl_error_accumulate(pdl_error err_current, pdl_error err_new) { if (!err_new.error) return err_current; if (!err_current.error) return err_new; pdl_error PDL_err = pdl_make_error( PDLMAX(err_current.error, err_current.error), "%s\n%s", err_current.message, err_new.message ); if (err_current.needs_free) pdl_error_free(err_current); if (err_new.needs_free) pdl_error_free(err_new); return PDL_err; } PDL-2.074/Basic/Core/Core.xs0000644000175000017500000005176014200147020015247 0ustar osboxesosboxes#ifndef WIN32 #include #include #endif #include "EXTERN.h" /* std perl include */ #include "perl.h" /* std perl include */ #include "XSUB.h" /* XSUB include */ #if defined(CONTEXT) #undef CONTEXT #endif #include "pdl.h" /* Data structure declarations */ #define PDL_IN_CORE /* access funcs directly not through PDL-> */ #include "pdlcore.h" /* Core declarations */ #include "pdlperl.h" #define TRANS_PDLS(from, to) \ pdl_transvtable *vtable = trans->vtable; \ if (!vtable) croak("This transformation doesn't have a vtable!"); \ PDL_Indx i; \ EXTEND(SP, to - from); \ for (i=from; ipdls[i]); \ PUSHs(sv); \ } #define setflag(reg,flagval,val) (val?(reg |= flagval):(reg &= ~flagval)) Core PDL; /* Struct holding pointers to shared C routines */ int pdl_debugging=0; int pdl_autopthread_targ = 0; /* No auto-pthreading unless set using the set_autopthread_targ */ int pdl_autopthread_actual = 0; PDL_Indx pdl_autopthread_dim = -1; int pdl_autopthread_size = 1; MODULE = PDL::Core PACKAGE = PDL # Destroy a PDL - note if a hash do nothing, the $$x{PDL} component # will be destroyed anyway on a separate call void DESTROY(sv) SV * sv; PREINIT: pdl *self; CODE: if ( !( (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV) ) ) { self = pdl_SvPDLV(sv); PDLDEBUG_f(printf("DESTROYING %p\n",(void*)self);) if (self != NULL) pdl_barf_if_error(pdl_destroy(self)); } # Return the transformation object or an undef otherwise. pdl_trans * trans_parent(self) pdl *self; CODE: RETVAL = self->trans_parent; OUTPUT: RETVAL void trans_children(self) pdl *self PPCODE: PDL_DECL_CHILDLOOP(self); PDL_START_CHILDLOOP(self) pdl_trans *t = PDL_CHILDLOOP_THISCHILD(self); if (!t) continue; SV *sv = sv_newmortal(); sv_setref_pv(sv, "PDL::Trans", (void*)t); XPUSHs(sv); PDL_END_CHILDLOOP(self) INCLUDE_COMMAND: $^X -e "require q{./Dev.pm}; PDL::Core::Dev::generate_core_flags()" void set_inplace(self,val) pdl *self; int val; CODE: setflag(self->state,PDL_INPLACE,val); IV address(self) pdl *self; CODE: RETVAL = PTR2IV(self); OUTPUT: RETVAL int set_donttouchdata(it,size) pdl *it IV size CODE: it->state |= PDL_DONTTOUCHDATA | PDL_ALLOCATED; it->nbytes = size; RETVAL = 1; OUTPUT: RETVAL IV nbytes(self) pdl *self; CODE: RETVAL = self->nbytes; OUTPUT: RETVAL # Free the datasv if possible void freedata(it) pdl *it CODE: if(it->datasv) { SvREFCNT_dec(it->datasv); it->datasv=0; it->data=0; } else if(it->data) { die("Trying to free data of pdl with data != 0 and datasv==0"); } int set_data_by_offset(it,orig,offset) pdl *it pdl *orig STRLEN offset CODE: it->data = ((char *) orig->data) + offset; it->datasv = orig->sv; (void)SvREFCNT_inc(it->datasv); it->state |= PDL_DONTTOUCHDATA | PDL_ALLOCATED; RETVAL = 1; OUTPUT: RETVAL PDL_Indx nelem(x) pdl *x CODE: pdl_barf_if_error(pdl_make_physdims(x)); RETVAL = x->nvals; OUTPUT: RETVAL # Call my howbig function int howbig_c(datatype) int datatype CODE: RETVAL = pdl_howbig(datatype); OUTPUT: RETVAL int set_autopthread_targ(i) int i; CODE: RETVAL = i; pdl_autopthread_targ = i; OUTPUT: RETVAL int get_autopthread_targ() CODE: RETVAL = pdl_autopthread_targ; OUTPUT: RETVAL int set_autopthread_size(i) int i; CODE: RETVAL = i; pdl_autopthread_size = i; OUTPUT: RETVAL int get_autopthread_size() CODE: RETVAL = pdl_autopthread_size; OUTPUT: RETVAL int get_autopthread_actual() CODE: RETVAL = pdl_autopthread_actual; OUTPUT: RETVAL int get_autopthread_dim() CODE: RETVAL = pdl_autopthread_dim; OUTPUT: RETVAL void _ci(...) PPCODE: PDL_XS_SCALAR(PDL_CD, 0 + 1I) void _nan(...) PPCODE: PDL_XS_SCALAR(PDL_D, (PDL_Double)NAN) void _inf(...) PPCODE: PDL_XS_SCALAR(PDL_D, INFINITY) MODULE = PDL::Core PACKAGE = PDL::Trans void parents(trans) pdl_trans *trans PPCODE: TRANS_PDLS(0, vtable->nparents) void children(trans) pdl_trans *trans PPCODE: TRANS_PDLS(vtable->nparents, vtable->npdls) MODULE = PDL::Core PACKAGE = PDL::Core IV seed() CODE: RETVAL = pdl_pdl_seed(); OUTPUT: RETVAL int online_cpus() CODE: RETVAL = pdl_online_cpus(); OUTPUT: RETVAL unsigned int is_scalar_SvPOK(arg) SV* arg; CODE: RETVAL = SvPOK(arg); OUTPUT: RETVAL int set_debugging(i) int i; CODE: RETVAL = pdl_debugging; pdl_debugging = i; OUTPUT: RETVAL SV * sclr_c(it) pdl* it PREINIT: PDL_Anyval result = { PDL_INVALID, {0} }; CODE: /* get the first element of an ndarray and return as * Perl scalar (autodetect suitable type IV or NV) */ result = pdl_at0(it); if (result.type < 0) croak("Position out of range"); ANYVAL_TO_SV(RETVAL, result); OUTPUT: RETVAL SV * at_bad_c(x,pos) pdl* x PDL_Indx *pos PREINIT: PDL_Indx ipos; int badflag; volatile PDL_Anyval result = { PDL_INVALID, {0} }; CODE: pdl_barf_if_error(pdl_make_physvaffine( x )); if (pos == NULL || pos_count < x->ndims) barf("Invalid position with pos=%p, count=%"IND_FLAG" for ndarray with %"IND_FLAG" dims", pos, pos_count, x->ndims); /* allow additional trailing indices * which must be all zero, i.e. a * [3,1,5] ndarray is treated as an [3,1,5,1,1,1,....] * infinite dim ndarray */ for (ipos=x->ndims; iposdatatype, pos, x->dims, PDL_REPRINCS(x), PDL_REPROFFS(x), x->ndims); if (result.type < 0) barf("Position %"IND_FLAG" out of range", pos); badflag = (x->state & PDL_BADVAL) > 0; if (badflag) { volatile PDL_Anyval badval = pdl_get_pdl_badvalue(x); if (badval.type < 0) barf("Error getting badvalue, type=%d", badval.type); int isbad = ANYVAL_ISBAD(result, badval); if (isbad == -1) barf("ANYVAL_ISBAD error on types %d, %d", result.type, badval.type); if (isbad) RETVAL = newSVpvn( "BAD", 3 ); else ANYVAL_TO_SV(RETVAL, result); } else ANYVAL_TO_SV(RETVAL, result); OUTPUT: RETVAL # returns the string 'BAD' if an element is bad # SV * listref_c(x) pdl *x PREINIT: PDL_Indx * incs; PDL_Indx offs; void *data; int ind; int lind; int stop = 0; AV *av; SV *sv; volatile PDL_Anyval pdl_val = { PDL_INVALID, {0} }; /* same reason as below */ volatile PDL_Anyval pdl_badval = { PDL_INVALID, {0} }; CODE: /* # note: # the badvalue is stored in a PDL_Anyval, but that's what pdl_at() # returns */ int badflag = (x->state & PDL_BADVAL) > 0; if (badflag) { pdl_badval = pdl_get_pdl_badvalue( x ); if (pdl_badval.type < 0) barf("Error getting badvalue, type=%d", pdl_badval.type); } pdl_barf_if_error(pdl_make_physvaffine( x )); data = PDL_REPRP(x); incs = PDL_REPRINCS(x); offs = PDL_REPROFFS(x); av = newAV(); av_extend(av,x->nvals); lind=0; PDL_Indx inds[x->ndims]; for(ind=0; ind < x->ndims; ind++) inds[ind] = 0; while(!stop) { pdl_val = pdl_at( data, x->datatype, inds, x->dims, incs, offs, x->ndims ); if (pdl_val.type < 0) croak("Position out of range"); if (badflag) { /* volatile because gcc optimiser otherwise won't recalc for complex double when long-double code added */ volatile int isbad = ANYVAL_ISBAD(pdl_val, pdl_badval); if (isbad == -1) croak("ANYVAL_ISBAD error on types %d, %d", pdl_val.type, pdl_badval.type); if (isbad) sv = newSVpvn( "BAD", 3 ); else ANYVAL_TO_SV(sv, pdl_val); } else { ANYVAL_TO_SV(sv, pdl_val); } av_store( av, lind, sv ); lind++; stop = 1; for(ind = 0; ind < x->ndims; ind++) { if(++(inds[ind]) >= x->dims[ind]) { inds[ind] = 0; } else { stop = 0; break; } } } RETVAL = newRV_noinc((SV *)av); OUTPUT: RETVAL void set_c(x,pos,value) pdl* x PDL_Indx *pos PDL_Anyval value PREINIT: PDL_Indx ipos; CODE: pdl_barf_if_error(pdl_make_physvaffine( x )); if (pos == NULL || pos_count < x->ndims) croak("Invalid position"); /* allow additional trailing indices * which must be all zero, i.e. a * [3,1,5] ndarray is treated as an [3,1,5,1,1,1,....] * infinite dim ndarray */ for (ipos=x->ndims; iposdatatype, pos, x->dims, PDL_REPRINCS(x), PDL_REPROFFS(x), x->ndims,value)); pdl_barf_if_error(pdl_changed(PDL_VAFFOK(x)?x->vafftrans->from:x, PDL_PARENTDATACHANGED, 0)); BOOT: { /* Initialize structure of pointers to core C routines */ PDL.Version = PDL_CORE_VERSION; #define X(sym, rettype, args) PDL.sym = pdl_ ## sym; PDL_CORE_LIST(X) #undef X #define X(symbol, ctype, ppsym, shortctype, defbval, ...) \ PDL.bvals.shortctype = defbval; PDL_TYPELIST_ALL(X) #undef X /* "Publish" pointer to this structure in perl variable for use by other modules */ sv_setiv(get_sv("PDL::SHARE",TRUE|GV_ADDMULTI), PTR2IV(&PDL)); } # make ndarray belonging to 'class' and of type 'type' # from avref 'array_ref' which is checked for being # rectangular first SV* pdl_avref(array_ref, class, type) SV* array_ref char* class int type PREINIT: AV *dims, *av; int datalevel = -1; SV* psv; pdl* p; CODE: /* make an ndarray from a Perl array ref */ if (!SvROK(array_ref)) croak("pdl_avref: not a reference"); if (SvTYPE(SvRV(array_ref)) != SVt_PVAV) croak("pdl_avref: not an array reference"); // Expand the array ref to a list, and allocate a Perl list to hold the dimlist av = (AV *) SvRV(array_ref); dims = (AV *) sv_2mortal( (SV *) newAV()); av_store(dims,0,newSViv((IV) av_len(av)+1)); av_ndcheck(av,dims,0,&datalevel); /* printf("will make type %s\n",class); */ /* at this stage start making an ndarray and populate it with values from the array (which has already been checked in av_check) */ if (strcmp(class,"PDL") == 0) { p = pdl_from_array(av,dims,type,NULL); /* populate with data */ RETVAL = newSV(0); pdl_SetSV_PDL(RETVAL,p); } else { /* call class->initialize method */ PUSHMARK(SP); XPUSHs(sv_2mortal(newSVpv(class, 0))); PUTBACK; perl_call_method("initialize", G_SCALAR); SPAGAIN; psv = POPs; PUTBACK; p = pdl_SvPDLV(psv); /* and get ndarray from returned object */ RETVAL = psv; SvREFCNT_inc(psv); pdl_from_array(av,dims,type,p); /* populate ;) */ } OUTPUT: RETVAL MODULE = PDL::Core PACKAGE = PDL::Core PREFIX = pdl_ int pdl_pthreads_enabled() MODULE = PDL::Core PACKAGE = PDL PREFIX = pdl_ int isnull(self) pdl *self; CODE: RETVAL= !!(self->state & PDL_NOMYDIMS); OUTPUT: RETVAL pdl * make_physical(self) pdl *self; CODE: pdl_barf_if_error(pdl_make_physical(self)); RETVAL = self; OUTPUT: RETVAL pdl * make_physvaffine(self) pdl *self; CODE: pdl_barf_if_error(pdl_make_physvaffine(self)); RETVAL = self; OUTPUT: RETVAL pdl * make_physdims(self) pdl *self; CODE: pdl_barf_if_error(pdl_make_physdims(self)); RETVAL = self; OUTPUT: RETVAL pdl * _convert_int(self, new_dtype) pdl *self; int new_dtype; CODE: RETVAL = pdl_get_convertedpdl(self, new_dtype); OUTPUT: RETVAL void set_datatype(a,datatype) pdl *a int datatype CODE: pdl_barf_if_error(pdl_set_datatype(a, datatype)); int get_datatype(self) pdl *self CODE: RETVAL = self->datatype; OUTPUT: RETVAL pdl * pdl_sever(src) pdl *src; CODE: pdl_barf_if_error(pdl_sever(src)); RETVAL = src; OUTPUT: RETVAL void pdl_dump(x) pdl *x; void pdl_add_threading_magic(it,nthdim,nthreads) pdl *it int nthdim int nthreads CODE: pdl_barf_if_error(pdl_add_threading_magic(it,nthdim,nthreads)); void pdl_remove_threading_magic(it) pdl *it CODE: pdl_barf_if_error(pdl_add_threading_magic(it,-1,-1)); MODULE = PDL::Core PACKAGE = PDL SV * initialize(class) SV *class PREINIT: CODE: HV *bless_stash = SvROK(class) ? SvSTASH(SvRV(class)) /* a reference to a class */ : gv_stashsv(class, 0); /* a class name */ RETVAL = newSV(0); pdl *n = pdl_pdlnew(); if (!n) pdl_pdl_barf("Error making null pdl"); pdl_SetSV_PDL(RETVAL,n); /* set a null PDL to this SV * */ RETVAL = sv_bless(RETVAL, bless_stash); /* bless appropriately */ OUTPUT: RETVAL SV * get_dataref(self) pdl *self CODE: if(self->state & PDL_DONTTOUCHDATA) croak("Trying to get dataref to magical (mmaped?) pdl"); pdl_barf_if_error(pdl_make_physical(self)); /* XXX IS THIS MEMLEAK WITHOUT MORTAL? */ if (!self->datasv) { self->datasv = newSVpvn("", 0); (void)SvGROW((SV *)self->datasv, self->nbytes); } RETVAL = newRV(self->datasv); OUTPUT: RETVAL void upd_data(self) pdl *self CODE: if(self->state & PDL_DONTTOUCHDATA) croak("Trying to touch dataref of magical (mmaped?) pdl"); self->data = SvPV_nolen((SV*)self->datasv); void set_dataflow_f(self,value) pdl *self; int value; CODE: if(value) self->state |= PDL_DATAFLOW_F; else self->state &= ~PDL_DATAFLOW_F; int getndims(x) pdl *x ALIAS: PDL::ndims = 1 CODE: (void)ix; pdl_barf_if_error(pdl_make_physdims(x)); RETVAL = x->ndims; OUTPUT: RETVAL void dims_c(x) pdl *x PREINIT: PDL_Indx i; U8 gimme = GIMME_V; PPCODE: pdl_barf_if_error(pdl_make_physdims(x)); if (gimme == G_ARRAY) { EXTEND(sp, x->ndims); for(i=0; indims; i++) mPUSHi(x->dims[i]); } else if (gimme == G_SCALAR) { mXPUSHu(x->ndims); } PDL_Indx getdim(x,y) pdl *x int y ALIAS: PDL::dim = 1 CODE: (void)ix; pdl_barf_if_error(pdl_make_physdims(x)); if (y < 0) y += x->ndims; if (y < 0) croak("negative dim index too large"); RETVAL = y < x->ndims ? x->dims[y] : 1; /* all other dims=1 */ OUTPUT: RETVAL int getnthreadids(x) pdl *x CODE: pdl_barf_if_error(pdl_make_physdims(x)); RETVAL = x->nthreadids; OUTPUT: RETVAL void threadids_c(x) pdl *x PREINIT: PDL_Indx i; U8 gimme = GIMME_V; PPCODE: pdl_barf_if_error(pdl_make_physdims(x)); if (gimme == G_ARRAY) { EXTEND(sp, x->nthreadids); for(i=0; inthreadids; i++) mPUSHi(x->threadids[i]); } else if (gimme == G_SCALAR) { mXPUSHu(x->nthreadids); } int getthreadid(x,y) pdl *x int y CODE: RETVAL = x->threadids[y]; OUTPUT: RETVAL void setdims(x,dims) pdl *x PDL_Indx *dims CODE: pdl_barf_if_error(pdl_setdims(x,dims,dims_count)); void dowhenidle() CODE: pdl_run_delayed_magic(); XSRETURN(0); void bind(p,c) pdl *p SV *c PROTOTYPE: $& CODE: if (!pdl_add_svmagic(p,c)) croak("Failed to add magic"); XSRETURN(0); void sethdr(p,h) pdl *p SV *h PREINIT: CODE: if(p->hdrsv == NULL) { p->hdrsv = &PL_sv_undef; /*(void*) newSViv(0);*/ } /* Throw an error if we're not either undef or hash */ if ( (h != &PL_sv_undef && h != NULL) && ( !SvROK(h) || SvTYPE(SvRV(h)) != SVt_PVHV ) ) croak("Not a HASH reference"); /* Clear the old header */ SvREFCNT_dec(p->hdrsv); /* Put the new header (or undef) in place */ if(h == &PL_sv_undef || h == NULL) p->hdrsv = NULL; else p->hdrsv = (void*) newRV( (SV*) SvRV(h) ); SV * hdr(p) pdl *p CODE: pdl_barf_if_error(pdl_make_physdims(p)); /* Make sure that in the undef case we return not */ /* undef but an empty hash ref. */ if((p->hdrsv==NULL) || (p->hdrsv == &PL_sv_undef)) { p->hdrsv = (void*) newRV_noinc( (SV*)newHV() ); } RETVAL = newRV( (SV*) SvRV((SV*)p->hdrsv) ); OUTPUT: RETVAL SV * gethdr(p) pdl *p CODE: pdl_barf_if_error(pdl_make_physdims(p)); if((p->hdrsv==NULL) || (p->hdrsv == &PL_sv_undef)) { RETVAL = &PL_sv_undef; } else { RETVAL = newRV( (SV*) SvRV((SV*)p->hdrsv) ); } OUTPUT: RETVAL void threadover_n(...) PREINIT: int npdls; SV *sv; CODE: npdls = items - 1; if(npdls <= 0) croak("Usage: threadover_n(pdl[,pdl...],sub)"); int i,sd; pdl *pdls[npdls]; PDL_Indx realdims[npdls]; pdl_thread pdl_thr; SV *code = ST(items-1); for(i=0; i 0) nothers = SvIV(ST(0)); if(targs <= 0 || nothers < 0 || nothers >= targs) croak("Usage: threadover(nothers,pdl[,pdl...][,otherpars..],realdims,creating,sub)"); npdls = targs-nothers; int i,dtype=0; PDL_Indx nc=npdls,nd1,nd2; SV* rdimslist = ST(items-3); SV* cdimslist = ST(items-2); SV *code = ST(items-1); pdl_thread pdl_thr; pdl *pdls[npdls], *child[npdls]; SV *csv[npdls], *others[nothers]; PDL_Indx *creating = pdl_packdims(cdimslist,&nd2); if (!creating) croak("Failed to packdims for creating"); PDL_Indx *realdims = pdl_packdims(rdimslist,&nd1); if (!realdims) croak("Failed to packdims for realdims"); if (nd1 != npdls) croak("threadover: need one realdim flag per pdl!"); if (nd2 != npdls) croak("threadover: need one creating flag per pdl!"); for(i=0; idatatype); } } for (i=npdls+1; i<=targs; i++) others[i-npdls-1] = ST(i); if (nd2 < nc) croak("Not enough dimension info to create pdls"); PDLDEBUG_f(for (i=0;idatatype = dtype; pdl_barf_if_error(pdl_thread_create_parameter(&pdl_thr,i,cp,0)); nc += realdims[i]; pdl_barf_if_error(pdl_make_physical(pdls[i])); PDLDEBUG_f(pdl_dump(pdls[i])); /* And make it nonnull, now that we've created it */ pdls[i]->state &= (~PDL_NOMYDIMS); } pdl_error error_ret = {0, NULL, 0}; if (pdl_startthreadloop(&pdl_thr,NULL,NULL,&error_ret) < 0) croak("Error starting threadloop"); pdl_barf_if_error(error_ret); for(i=0; idims, *theseincs = PDL_REPRINCS(pdls[i]); /* need to make sure we get the vaffine (grand)parent */ if (PDL_VAFFOK(pdls[i])) pdls[i] = pdls[i]->vafftrans->from; child[i]=pdl_pdlnew(); if (!child[i]) pdl_pdl_barf("Error making null pdl"); /* instead of pdls[i] its vaffine parent !!!XXX */ pdl_barf_if_error(pdl_affine_new(pdls[i],child[i],pdl_thr.offs[i], thesedims,realdims[i], theseincs,realdims[i])); pdl_barf_if_error(pdl_make_physical(child[i])); /* make sure we can get at the vafftrans */ csv[i] = sv_newmortal(); pdl_SetSV_PDL(csv[i], child[i]); /* pdl* into SV* */ } int thrloopval; do { /* the actual threadloop */ pdl_trans *traff; dSP; PUSHMARK(sp); EXTEND(sp,npdls); for(i=0; itrans_parent; traff->offs = pdl_thr.offs[i]; child[i]->vafftrans->offs = pdl_thr.offs[i]; child[i]->state |= PDL_PARENTDATACHANGED; PUSHs(csv[i]); } for (i=0; i and L. =head1 SYNOPSIS use PDL::Basic; =head1 FUNCTIONS =cut package PDL::Basic; use strict; use warnings; use PDL::Core ''; use PDL::Types; use PDL::Exporter; use PDL::Options; our @ISA=qw/PDL::Exporter/; our @EXPORT_OK = qw/ ndcoords rvals axisvals allaxisvals xvals yvals zvals sec ins hist whist similar_assign transpose sequence xlinvals ylinvals zlinvals axislinvals/; our %EXPORT_TAGS = (Func=>[@EXPORT_OK]); # Exportable functions *axisvals = \&PDL::axisvals; *allaxisvals = \&PDL::allaxisvals; *sec = \&PDL::sec; *ins = \&PDL::ins; *hist = \&PDL::hist; *whist = \&PDL::whist; *similar_assign = \&PDL::similar_assign; *transpose = \&PDL::transpose; *xlinvals = \&PDL::xlinvals; *ylinvals = \&PDL::ylinvals; *zlinvals = \&PDL::zlinvals; =head2 xvals =for ref Fills an ndarray with X index values. Uses similar specifications to L and L, except that as of 2.064, the returned ndarray will be at least type C. CAVEAT: If you use the single argument ndarray form (top row in the usage table) the output will have the same type as the input; this may give surprising results if, e.g., you have a byte array with a dimension of size greater than 256. To force a type, use the third form. =for usage $x = xvals($somearray); $x = xvals([OPTIONAL TYPE],$nx,$ny,$nz...); $x = xvals([OPTIONAL TYPE], $somarray->dims); etc. see L. =for example pdl> print xvals zeroes(5,10) [ [0 1 2 3 4] [0 1 2 3 4] [0 1 2 3 4] [0 1 2 3 4] [0 1 2 3 4] [0 1 2 3 4] [0 1 2 3 4] [0 1 2 3 4] [0 1 2 3 4] [0 1 2 3 4] ] =head2 yvals =for ref Fills an ndarray with Y index values. See the CAVEAT for L. =for usage $x = yvals($somearray); yvals(inplace($somearray)); $x = yvals([OPTIONAL TYPE],$nx,$ny,$nz...); etc. see L. =for example pdl> print yvals zeroes(5,10) [ [0 0 0 0 0] [1 1 1 1 1] [2 2 2 2 2] [3 3 3 3 3] [4 4 4 4 4] [5 5 5 5 5] [6 6 6 6 6] [7 7 7 7 7] [8 8 8 8 8] [9 9 9 9 9] ] =head2 zvals =for ref Fills an ndarray with Z index values. See the CAVEAT for L. =for usage $x = zvals($somearray); zvals(inplace($somearray)); $x = zvals([OPTIONAL TYPE],$nx,$ny,$nz...); etc. see L. =for example pdl> print zvals zeroes(3,4,2) [ [ [0 0 0] [0 0 0] [0 0 0] [0 0 0] ] [ [1 1 1] [1 1 1] [1 1 1] [1 1 1] ] ] =head2 xlinvals =for ref X axis values between endpoints (see L). =for usage $w = zeroes(100,100); $x = $w->xlinvals(0.5,1.5); $y = $w->ylinvals(-2,-1); # calculate Z for X between 0.5 and 1.5 and # Y between -2 and -1. $z = f($x,$y); C, C and C return an ndarray with the same shape as their first argument and linearly scaled values between the two other arguments along the given axis. =head2 ylinvals =for ref Y axis values between endpoints (see L). See L for more information. =head2 zlinvals =for ref Z axis values between endpoints (see L). See L for more information. =head2 xlogvals =for ref X axis values logarithmically spaced between endpoints (see L). =for usage $w = zeroes(100,100); $x = $w->xlogvals(1e-6,1e-3); $y = $w->ylinvals(1e-4,1e3); # calculate Z for X between 1e-6 and 1e-3 and # Y between 1e-4 and 1e3. $z = f($x,$y); C, C and C return an ndarray with the same shape as their first argument and logarithmically scaled values between the two other arguments along the given axis. =head2 ylogvals =for ref Y axis values logarithmically spaced between endpoints (see L). See L for more information. =head2 zlogvals =for ref Z axis values logarithmically spaced between endpoints (see L). See L for more information. =cut # Conveniently named interfaces to axisvals() sub xvals { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->xvals : PDL->xvals(@_) } sub yvals { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->yvals : PDL->yvals(@_) } sub zvals { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->zvals : PDL->zvals(@_) } sub PDL::xvals { axisvals2(&PDL::Core::_construct,0,0); } sub PDL::yvals { axisvals2(&PDL::Core::_construct,1,0); } sub PDL::zvals { axisvals2(&PDL::Core::_construct,2,0); } sub _dimcheck { my ($pdl, $whichdim, $name) = @_; my $dim = $pdl->getdim($whichdim); barf "Must have at least two elements in dimension for $name" if $dim <= 1; $dim; } sub _linvals { my ($pdl, $v1, $v2, $dim, $method) = @_; $pdl->$method * (($v2 - $v1) / ($dim-1)) + $v1; } sub PDL::xlinvals { _linvals(@_[0..2], _dimcheck($_[0], 0, 'xlinvals'), 'xvals'); } sub PDL::ylinvals { _linvals(@_[0..2], _dimcheck($_[0], 1, 'ylinvals'), 'yvals'); } sub PDL::zlinvals { _linvals(@_[0..2], _dimcheck($_[0], 2, 'zlinvals'), 'zvals'); } sub _logvals { my ($pdl, $min, $max, $dim, $method) = @_; barf "min and max must be positive" if $min <= 0 || $max <= 0; my ($lmin,$lmax) = map log($_), $min, $max; exp($pdl->$method * (($lmax - $lmin) / ($dim-1)) + $lmin); } sub PDL::xlogvals { _logvals(@_[0..2], _dimcheck($_[0], 0, 'xlogvals'), 'xvals'); } sub PDL::ylogvals { _logvals(@_[0..2], _dimcheck($_[0], 1, 'ylogvals'), 'yvals'); } sub PDL::zlogvals { _logvals(@_[0..2], _dimcheck($_[0], 2, 'zlogvals'), 'zvals'); } =head2 allaxisvals =for ref Synonym for L - enumerates all coordinates in a PDL or dim list, adding an extra dim on the front to accommodate the vector coordinate index (the form expected by L, L, and L). See L for more detail. =for usage $indices = allaxisvals($pdl); $indices = allaxisvals(@dimlist); $indices = allaxisvals($type,@dimlist); =cut =head2 ndcoords =for ref Enumerate pixel coordinates for an N-D ndarray Returns an enumerated list of coordinates suitable for use in L or L: you feed in a dimension list and get out an ndarray whose 0th dimension runs over dimension index and whose 1st through Nth dimensions are the dimensions given in the input. If you feed in an ndarray instead of a perl list, then the dimension list is used, as in L etc. Unlike L etc., if you supply an ndarray input, you get out an ndarray of the default ndarray type: double. This causes less surprises than the previous default of keeping the data type of the input ndarray since that rarely made sense in most usages. =for usage $indices = ndcoords($pdl); $indices = ndcoords(@dimlist); $indices = ndcoords($type,@dimlist); =for example pdl> print ndcoords(2,3) [ [ [0 0] [1 0] ] [ [0 1] [1 1] ] [ [0 2] [1 2] ] ] pdl> $w = zeroes(byte,2,3); # $w is a 2x3 byte ndarray pdl> $y = ndcoords($w); # $y inherits $w's type pdl> $c = ndcoords(long,$w->dims); # $c is a long ndarray, same dims as $y pdl> help $y; This variable is Byte D [2,2,3] P 0.01Kb pdl> help $c; This variable is Long D [2,2,3] P 0.05Kb =cut sub PDL::ndcoords { my $type; if(ref $_[0] eq 'PDL::Type') { $type = shift; } my @dims = (ref $_[0]) ? (shift)->dims : @_; my @d = @dims; unshift(@d,scalar(@dims)); unshift(@d,$type) if defined($type); my $out = PDL->zeroes(@d); for my $d(0..$#dims) { my $w = $out->index($d)->mv($d,0); $w .= xvals($w); } $out; } *ndcoords = \&PDL::ndcoords; *allaxisvals = \&PDL::ndcoords; *PDL::allaxisvals = \&PDL::ndcoords; =head2 hist =for ref Create histogram of an ndarray =for usage $hist = hist($data); ($xvals,$hist) = hist($data); or $hist = hist($data,$min,$max,$step); ($xvals,$hist) = hist($data,[$min,$max,$step]); If C is run in list context, C<$xvals> gives the computed bin centres as double values. A nice idiom (with L) is bin hist $data; # Plot histogram =for example pdl> p $y [13 10 13 10 9 13 9 12 11 10 10 13 7 6 8 10 11 7 12 9 11 11 12 6 12 7] pdl> $h = hist $y,0,20,1; # hist with step 1, min 0 and 20 bins pdl> p $h [0 0 0 0 0 0 2 3 1 3 5 4 4 4 0 0 0 0 0 0] =cut sub PDL::hist { my $usage = "\n" . ' Usage: $hist = hist($data)' . "\n" . ' $hist = hist($data,$min,$max,$step)' . "\n" . ' ($xvals,$hist) = hist($data)' . "\n" . ' ($xvals,$hist) = hist($data,$min,$max,$step)' . "\n" ; barf($usage) if $#_<0; my($pdl,$min,$max,$step)=@_; ($step, $min, my $bins, my $xvals) = _hist_bin_calc($pdl, $min, $max, $step, wantarray()); PDL::Primitive::histogram($pdl->clump(-1),(my $hist = null), $step,$min,$bins); return wantarray() ? ($xvals,$hist) : $hist; } =head2 whist =for ref Create a weighted histogram of an ndarray =for usage $hist = whist($data, $wt, [$min,$max,$step]); ($xvals,$hist) = whist($data, $wt, [$min,$max,$step]); If requested, C<$xvals> gives the computed bin centres as type double values. C<$data> and C<$wt> should have the same dimensionality and extents. A nice idiom (with L) is bin whist $data, $wt; # Plot histogram =for example pdl> p $y [13 10 13 10 9 13 9 12 11 10 10 13 7 6 8 10 11 7 12 9 11 11 12 6 12 7] pdl> $wt = grandom($y->nelem) pdl> $h = whist $y, $wt, 0, 20, 1 # hist with step 1, min 0 and 20 bins pdl> p $h [0 0 0 0 0 0 -0.49552342 1.7987439 0.39450696 4.0073722 -2.6255299 -2.5084501 2.6458365 4.1671676 0 0 0 0 0 0] =cut sub PDL::whist { barf('Usage: ([$xvals],$hist) = whist($data,$wt,[$min,$max,$step])') if @_ < 2; my($pdl,$wt,$min,$max,$step)=@_; ($step, $min, my $bins, my $xvals) = _hist_bin_calc($pdl, $min, $max, $step, wantarray()); PDL::Primitive::whistogram($pdl->clump(-1),$wt->clump(-1), (my $hist = null), $step, $min, $bins); return wantarray() ? ($xvals,$hist) : $hist; } sub _hist_bin_calc { my($pdl,$min,$max,$step,$wantarray)=@_; $min = $pdl->min() unless defined $min; $max = $pdl->max() unless defined $max; my $nelem = $pdl->nelem; barf "empty ndarray, no values to work with" if $nelem == 0; $step = ($max-$min)/(($nelem>10_000) ? 100 : sqrt($nelem)) unless defined $step; barf "step is zero (or all data equal to one value)" if $step == 0; my $bins = int(($max-$min)/$step+0.5); print "hist with step $step, min $min and $bins bins\n" if $PDL::debug; # Need to use double for $xvals here my $xvals = $min + $step/2 + sequence(PDL::Core::double,$bins)*$step if $wantarray; return ( $step, $min, $bins, $xvals ); } =head2 sequence =for ref Create array filled with a sequence of values =for usage $w = sequence($y); $w = sequence [OPTIONAL TYPE], @dims; etc. see L. =for example pdl> p sequence(10) [0 1 2 3 4 5 6 7 8 9] pdl> p sequence(3,4) [ [ 0 1 2] [ 3 4 5] [ 6 7 8] [ 9 10 11] ] =cut sub sequence { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->sequence : PDL->sequence(@_) } sub PDL::sequence { my $type_given = grep +(ref($_[$_])||'') eq 'PDL::Type', 0..1; $type_given ||= ref($_[0]) && UNIVERSAL::isa($_[0], 'PDL'); # instance method my $pdl = &PDL::Core::_construct; my $bar = $pdl->clump(-1)->inplace; axisvals2($bar,0,$type_given); return $pdl; } =head2 rvals =for ref Fills an ndarray with radial distance values from some centre. =for usage $r = rvals $ndarray,{OPTIONS}; $r = rvals [OPTIONAL TYPE],$nx,$ny,...{OPTIONS}; =for options Options: Centre => [$x,$y,$z...] # Specify centre Center => [$x,$y.$z...] # synonym. Squared => 1 # return distance squared (i.e., don't take the square root) =for example pdl> print rvals long,7,7,{Centre=>[2,2]} [ [2 2 2 2 2 3 4] [2 1 1 1 2 3 4] [2 1 0 1 2 3 4] [2 1 1 1 2 3 4] [2 2 2 2 2 3 4] [3 3 3 3 3 4 5] [4 4 4 4 4 5 5] ] If C
is not specified, the midpoint for a given dimension of size C is given by C< int(N/2) > so that the midpoint always falls on an exact pixel point in the data. For dimensions of even size, that means the midpoint is shifted by 1/2 pixel from the true center of that dimension. Also note that the calculation for C for integer values does not promote the datatype so you will have wraparound when the value calculated for C< r**2 > is greater than the datatype can hold. If you need exact values, be sure to use large integer or floating point datatypes. For a more general metric, one can define, e.g., sub distance { my ($w,$centre,$f) = @_; my ($r) = $w->allaxisvals-$centre; $f->($r); } sub l1 { sumover(abs($_[0])); } sub euclid { use PDL::Math 'pow'; pow(sumover(pow($_[0],2)),0.5); } sub linfty { maximum(abs($_[0])); } so now distance($w, $centre, \&euclid); will emulate rvals, while C<\&l1> and C<\&linfty> will generate other well-known norms. =cut sub rvals { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->rvals(@_[1..$#_]) : PDL->rvals(@_) } sub PDL::rvals { # Return radial distance from given point and offset my $opt = pop @_ if ref($_[$#_]) eq "HASH"; my %opt = defined $opt ? iparse( { CENTRE => undef, # needed, otherwise centre/center handling painful Squared => 0, }, $opt ) : (); my $r = &PDL::Core::_construct; my @pos; @pos = @{$opt{CENTRE}} if defined $opt{CENTRE}; my $offset; $r .= 0.0; my $tmp = $r->copy; my $i; for ($i=0; $i<$r->getndims; $i++) { $offset = (defined $pos[$i] ? $pos[$i] : int($r->getdim($i)/2)); # Note careful coding for speed and min memory footprint PDL::Primitive::axisvalues($tmp->xchg(0,$i)->inplace); $tmp -= $offset; $tmp *= $tmp; $r += $tmp; } return $opt{Squared} ? $r : $r->inplace->sqrt; } =head2 axisvals =for ref Fills an ndarray with index values on Nth dimension =for usage $z = axisvals ($ndarray, $nth); This is the routine, for which L, L etc are mere shorthands. C can be used to fill along any dimension, using a parameter. See also L, which generates all axis values simultaneously in a form useful for L, L, L, etc. Note the 'from specification' style (see L) is not available here, for obvious reasons. =cut sub PDL::axisvals { my($this,$nth) = @_; my $dummy = $this->new_or_inplace; if($dummy->getndims() <= $nth) { # This is 'kind of' consistency... $dummy .= 0; return $dummy; } my $bar = $dummy->xchg(0,$nth); PDL::Primitive::axisvalues($bar->inplace); return $dummy; } # We need this version for xvals etc to work in place sub axisvals2 { my($dummy,$nth,$keep_type) = @_; $dummy = PDL::Core::double($dummy) if !$keep_type && $dummy->get_datatype < PDL::Core::double()->enum; if($dummy->getndims() <= $nth) { # This is 'kind of' consistency... $dummy .= 0; return $dummy; } my $bar = $dummy->xchg(0,$nth); PDL::Primitive::axisvalues($bar->inplace); return $dummy; } sub PDL::sec { my($this,@coords) = @_; my $i; my @maps; while($#coords > -1) { $i = int(shift @coords) ; push @maps, "$i:".int(shift @coords); } my $tmp = PDL->null; $tmp .= $this->slice(join ',',@maps); return $tmp; } sub PDL::ins { my($this,$what,@coords) = @_; my $w = PDL::Core::alltopdl($PDL::name,$what); my $tmp; if($this->is_inplace) { $this->set_inplace(0); } else { $this = $this->copy; } ($tmp = $this->slice( (join ',',map {int($coords[$_]).":". ((int($coords[$_])+$w->getdim($_)-1)<$this->getdim($_) ? (int($coords[$_])+$w->getdim($_)-1):$this->getdim($_)) } 0..$#coords))) .= $w; return $this; } sub PDL::similar_assign { my($from,$to) = @_; if((my $fd = join ',',@{$from->dims}) ne (my $td = join ',',@{$to->dims})) { barf "Similar_assign: dimensions [$fd] and [$td] do not match!\n"; } $to .= $from; } =head2 transpose =for ref transpose rows and columns. =for usage $y = transpose($w); =for example pdl> $w = sequence(3,2) pdl> p $w [ [0 1 2] [3 4 5] ] pdl> p transpose( $w ) [ [0 3] [1 4] [2 5] ] =cut sub PDL::transpose { my ($this) = @_; $this->getndims > 1 ? $this->xchg(0,1) : $this->getndims > 0 ? $this->dummy(0) : $this->dummy(0)->dummy(0); } 1; PDL-2.074/Basic/Core/Dbg.pm0000644000175000017500000001133114165337504015045 0ustar osboxesosboxes=head1 NAME PDL::Dbg - functions to support debugging of PDL scripts =head1 SYNOPSIS use PDL; use PDL::Dbg; $c = $x->slice("5:10,2:30")->px->diagonal(3,4); PDL->px; =head1 DESCRIPTION These packages implements a couple of functions that should come in handy when debugging your PDL scripts. They make a lot of sense while you're doing rapid prototyping of new PDL code, let's say inside the perldl or pdl2 shell. =cut #' fool emacs package PDL::Dbg; use strict; use warnings; # used by info our $Title = "Type Dimension Flow State Mem"; our $Infostr = "%6T %-15D %3F %-5S %12M"; package PDL; =head1 FUNCTIONS =head2 px =for ref Print info about an ndarray (or all known ndarrays) =for example pdl> PDL->px pdl> $y += $x->clump(2)->px('clumptest')->sumover pdl> $x->px('%C (%A) Type: %T') # prints nothing unless $PDL::debug pdl> $PDL::debug = 1 pdl> $x->px('%C (%A) Type: %T') PDL (52433464) Type: Double This function prints some information about ndarrays. It can be invoked as a class method (e.g. Cpx> ) or as an instance method (e.g. C<$pdl-Epx($arg)>). If =over 2 =item invoked as a class method it prints info about all ndarrays found in the current package (I C variables). This comes in quite handy when you are not quite sure which pdls you have already defined, what data they hold , etc. C is supposed to support inheritance and prints info about all symbols for which an C is true. An optional string argument is interpreted as the package name for which to print symbols: pdl> PDL->px('PDL::Mypack') The default package is that of the caller. =item invoked as an instance method it prints info about that particular ndarray if C<$PDL::debug> is true and returns the pdl object upon completion. It accepts an optional string argument that is simply prepended to the default info if it doesn't contain a C<%> character. If, however, the argument contains a C<%> then the string is passed to the C method to control the format of the printed information. This can be used to achieve customized output from C. See the documentation of C for further details. =back The output of px will be determined by the default formatting string that is passed to the C method (unless you pass a string containing C<%> to px when invoking as an instance method, see above). This default string is stored in C<$PDL::Dbg::Infostr> and the default output format can be accordingly changed by setting this variable. If you do this you should also change the default title string that the class method branch prints at the top of the listing to match your new format string. The default title is stored in the variable C<$PDL::Dbg::Title>. For historical reasons C is an alias for C. =cut sub px { my $arg = shift; my $str=""; if (ref($arg)) { return $arg unless $PDL::debug; my $info = $arg->info($#_ > -1 ? ($_[0] =~ /%/ ? $_[0] : "$_[0] $PDL::Dbg::Infostr") : $PDL::Dbg::Infostr); print "$info\n"; return $arg; } # we have been called as a class method my $package = $#_ > -1 ? shift : caller; my $classname = $arg; # find the correct package my $stab = \%main::; $stab = $stab->{$1} for grep length, split /::/, $package; print "$classname variables in package $package\n\n"; my $title = "Name $PDL::Dbg::Title\n"; print $title; print '-'x(length($title)+3)."\n"; my ($pdl,$npdls,$key,$val,$info) = ((),0,"","",""); # while (($key,$val) = each(%$stab)) { foreach $key ( sort { lc($a) cmp lc($b) } keys(%$stab) ) { $val = $stab->{$key}; $pdl = ${"$package$key"}; # print info for all objects derived from this class if (UNIVERSAL::isa($pdl,$classname)) { $npdls++; $info = $pdl->info($PDL::Dbg::Infostr); printf "\$%-11s %s %s\n",$key,$info,(ref($pdl) eq $classname ? '' : ref($pdl)); # also print classname for derived classes } } print "no $classname objects in package $package\n" unless $npdls; return $arg; } =head2 vars =for ref Alias for C =cut # make vars an alias # I hope this works with inheritance *vars = \&px; 1; # return success =head1 BUGS There are probably some. Please report if you find any. Bug reports should be sent to the PDL mailing list pdl-general@lists.sourceforge.net. =head1 AUTHOR Copyright(C) 1997 Christian Soeller (c.soeller@auckland.ac.nz). 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. PDL-2.074/Basic/Core/typemap0000644000175000017500000000130214160015533015400 0ustar osboxesosboxesTYPEMAP pdl * T_PDL pdl_trans * T_PDLTRANS PDL_Indx T_IV float T_NV PDL_Anyval T_PDL_ANYVAL pdl_slice_args * T_PDL_SLICEARGS PDL_Indx * T_PDL_DIMLIST INPUT T_PDL $var = PDL_CORE_(SvPDLV)($arg); T_PDL_ANYVAL ANYVAL_FROM_SV($var, $arg, FALSE, -1) T_PDLTRANS if(sv_isa($arg,\"PDL::Trans\")) $var = INT2PTR(pdl_trans *,SvIV(SvRV($arg))); else croak(\"$var is not of type PDL::Trans\"); T_PDL_SLICEARGS $var = PDL_CORE_(slice_args_parse_sv)($arg); T_PDL_DIMLIST PDL_Indx ${var}_count; $var = PDL_CORE_(packdims)($arg, &${var}_count); OUTPUT T_PDL PDL_CORE_(SetSV_PDL)($arg,$var); T_PDL_ANYVAL ANYVAL_TO_SV($arg, $var) T_PDLTRANS sv_setref_pv($arg, \"PDL::Trans\", (void*)$var); PDL-2.074/Basic/Core/pdlconv.c0000644000175000017500000000656614172737500015640 0ustar osboxesosboxes#include "pdl.h" /* Data structure declarations */ #include "pdlcore.h" /* Core declarations */ #define XCODE(code, datatype, ctype, ...) \ ctype *ap = (ctype *) a->data; \ ctype *pp = (ctype *) a->vafftrans->from->data; \ pp += a->vafftrans->offs; \ for(i=0; invals; i++) { \ code; \ for(j=0; jndims; j++) { \ pp += a->vafftrans->incs[j]; \ if((j < a->ndims - 1 && \ (i+1) % a->dimincs[j+1]) || \ j == a->ndims - 1) \ break; \ pp -= a->vafftrans->incs[j] * \ a->dims[j]; \ } \ ap ++; \ } #define VAFF_IO(name, X) \ pdl_error pdl_ ## name(pdl *a) { \ pdl_error PDL_err = {0, NULL, 0}; \ PDL_Indx i; \ int j; \ int intype = a->datatype; \ if(!PDL_VAFFOK(a)) { \ return pdl_make_error_simple(PDL_EUSERERROR, "pdl_" #name " without vaffine"); \ } \ PDL_ENSURE_ALLOCATED(a); \ PDL_GENERICSWITCH(PDL_TYPELIST2_ALL, intype, X, return pdl_make_error(PDL_EUSERERROR, "Not a known data type code=%d", intype)) \ return PDL_err; \ } #define X(...) XCODE(*ap = *pp, __VA_ARGS__) VAFF_IO(readdata_vaffine, X) #undef X #define X(...) XCODE(*pp = *ap, __VA_ARGS__) VAFF_IO(writebackdata_vaffine, X) #undef X #undef XCODE pdl_error pdl_converttype( pdl* a, int targtype ) { pdl_error PDL_err = {0, NULL, 0}; PDLDEBUG_f(printf("pdl_converttype %p, %d, %d\n", (void*)a, a->datatype, targtype)); if(a->state & PDL_DONTTOUCHDATA) return pdl_make_error_simple(PDL_EUSERERROR, "Trying to converttype magical (mmaped?) pdl"); int intype = a->datatype; if (intype == targtype) return PDL_err; STRLEN nbytes = a->nvals * pdl_howbig(targtype); /* Size of converted data */ STRLEN ncurr = a->nvals * pdl_howbig(intype); char diffsize = ncurr != nbytes; void *b = a->data; /* pointer to old data */ if (diffsize) a->data = pdl_smalloc(nbytes); /* Space for changed data */ #define THIS_ISBAD(from_badval_isnan, from_badval, from_val) \ ((from_badval_isnan) \ ? isnan((double)(from_val)) \ : (from_val) == (from_badval)) #define X_OUTER(datatype_from, ctype_from, ppsym_from, ...) \ PDL_Indx i = a->nvals; \ ctype_from *bb = (ctype_from *) b; \ ctype_from from_badval = pdl_get_pdl_badvalue(a).value.ppsym_from; \ char from_badval_isnan = PDL_ISNAN_##ppsym_from(from_badval); \ PDL_GENERICSWITCH2(PDL_TYPELIST2_ALL_, targtype, X_INNER, return pdl_make_error(PDL_EUSERERROR, "Not a known data type code=%d", targtype)) #define X_INNER(datatype_to, ctype_to, ppsym_to, shortctype_to, defbval_to, ...) \ ctype_to *aa = (ctype_to *) a->data; \ aa += i-1; bb += i-1; \ if (a->state & PDL_BADVAL) { \ ctype_to to_badval = defbval_to; \ a->has_badvalue = 0; \ while (i--) { \ *aa-- = THIS_ISBAD(from_badval_isnan, from_badval, *bb) \ ? to_badval : (ctype_to) *bb; \ bb--; \ } \ } else \ while (i--) \ *aa-- = (ctype_to) *bb--; PDL_GENERICSWITCH(PDL_TYPELIST2_ALL, intype, X_OUTER, return pdl_make_error(PDL_EUSERERROR, "Not a known data type code=%d", intype)) #undef X_INNER #undef X_OUTER #undef THIS_ISBAD /* Store new data */ if (diffsize) { sv_setpvn((SV*) a->datasv, (char*) a->data, nbytes); a->data = SvPV_nolen((SV*) a->datasv); } a->datatype = targtype; return PDL_err; } PDL-2.074/Basic/Core/pdlapi.c0000644000175000017500000011323014200150406015411 0ustar osboxesosboxes/* pdlapi.c - functions for manipulating pdl structs */ #include "pdl.h" /* Data structure declarations */ #include "pdlcore.h" /* Core declarations */ #define VTABLE_OR_DEFAULT(trans, func, default_func) \ PDL_RETERROR(PDL_err, ((trans)->vtable->func \ ? (trans)->vtable->func \ : pdl_ ## default_func)(trans)) #define REDODIMS(trans) do { \ if (trans->dims_redone) { \ FREETRANS(trans, 0); \ if (PDL_err.error) return PDL_err; \ trans->dims_redone = 0; \ } \ VTABLE_OR_DEFAULT(trans, redodims, redodims_default); \ } while (0) #define READDATA(trans) VTABLE_OR_DEFAULT(trans, readdata, readdata_affine) #define WRITEDATA(trans) VTABLE_OR_DEFAULT(trans, writebackdata, writebackdata_affine) #define FREETRANS(trans, destroy) \ if(trans->vtable->freetrans) { \ PDLDEBUG_f(printf("call freetrans\n")); \ PDL_err = trans->vtable->freetrans(trans, destroy); \ /* ignore error for now as need to still free rest */ \ if (destroy) PDL_TR_CLRMAGIC(trans); \ } extern Core PDL; /* Make sure transformation is done */ pdl_error pdl__ensure_trans(pdl_trans *trans,int what,int *wd) { pdl_error PDL_err = {0, NULL, 0}; PDLDEBUG_f(printf("pdl__ensure_trans\n")); PDL_TR_CHKMAGIC(trans); PDL_Indx j, flag=what, par_pvaf=0; pdl_transvtable *vtable = trans->vtable; /* Make parents physical */ for(j=0; jnparents; j++) { if(VAFFINE_FLAG_OK(vtable->per_pdl_flags,j)) par_pvaf++; PDL_RETERROR(PDL_err, pdl_make_physvaffine(trans->pdls[j])); } for(; jnpdls; j++) { if(VAFFINE_FLAG_OK(vtable->per_pdl_flags,j)) par_pvaf++; PDL_RETERROR(PDL_err, pdl_make_physvaffine(trans->pdls[j])); flag |= trans->pdls[j]->state & PDL_ANYCHANGED; } if (flag & PDL_PARENTDIMSCHANGED) REDODIMS(trans); for(j=0; jnpdls; j++) if(trans->pdls[j]->trans_parent == trans) PDL_ENSURE_ALLOCATED(trans->pdls[j]); if(flag & (PDL_PARENTDATACHANGED | PDL_PARENTDIMSCHANGED)) { if(par_pvaf && (trans->flags & PDL_ITRANS_ISAFFINE)) { /* Attention: this assumes affine = p2child */ /* need to signal that redodims has already been called */ trans->pdls[1]->state &= ~PDL_PARENTDIMSCHANGED; PDL_RETERROR(PDL_err, pdl_make_physvaffine(trans->pdls[1])); PDL_RETERROR(PDL_err, pdl_readdata_vaffine(trans->pdls[1])); } else READDATA(trans); } for(j=vtable->nparents; jnpdls; j++) { pdl *child = trans->pdls[j]; child->state &= ~PDL_ANYCHANGED; if (!wd) continue; char isvaffine = (PDL_VAFFOK(child) && VAFFINE_FLAG_OK(vtable->per_pdl_flags,j)); if (!isvaffine || (wd[j] & PDL_PARENTDIMSCHANGED)) PDL_RETERROR(PDL_err, pdl_changed(child,wd[j],0)); if (isvaffine) PDL_RETERROR(PDL_err, pdl_changed(child->vafftrans->from,PDL_PARENTDATACHANGED,0)); } return PDL_err; } pdl *pdl_null() { PDL_Anyval zero = { PDL_D, {.D=0.0} }; PDLDEBUG_f(printf("pdl_null\n")); pdl *it = pdl_pdlnew(); if (!it) return it; pdl_error PDL_err = pdl_makescratchhash(it, zero); if (PDL_err.error) { pdl_destroy(it); return NULL; } return it; } pdl *pdl_scalar(PDL_Anyval anyval) { PDLDEBUG_f(printf("pdl_scalar type=%d val=", anyval.type); pdl_dump_anyval(anyval); printf("\n");); pdl *it = pdl_pdlnew(); if (!it) return it; pdl_error PDL_err = pdl_makescratchhash(it, anyval); if (PDL_err.error) { pdl_destroy(it); return NULL; } it->threadids[0] = it->ndims = 0; /* 0 dims in a scalar */ it->state &= ~(PDL_ALLOCATED|PDL_NOMYDIMS); /* size changed, has dims */ it->nvals = 1; /* 1 val in a scalar */ return it; } pdl *pdl_get_convertedpdl(pdl *old,int type) { PDLDEBUG_f(printf("pdl_get_convertedpdl\n")); if(old->datatype == type) return old; pdl *it = pdl_null(); if (!it) return it; pdl_error PDL_err = pdl_converttypei_new(old,it,type); if (PDL_err.error) { pdl_destroy(it); return NULL; } return it; } pdl_error pdl_allocdata(pdl *it) { pdl_error PDL_err = {0, NULL, 0}; PDLDEBUG_f(printf("pdl_allocdata %p, %"IND_FLAG", %d\n",(void*)it, it->nvals, it->datatype)); PDL_Indx nbytes = it->nvals * pdl_howbig(it->datatype); PDL_Indx ncurr = it->nbytes; if (ncurr == nbytes) return PDL_err; /* Nothing to be done */ if(it->state & PDL_DONTTOUCHDATA) return pdl_make_error_simple(PDL_EUSERERROR, "Trying to touch data of an untouchable (mmapped?) pdl"); if(it->datasv == NULL) it->datasv = newSVpv("",0); SV* foo = it->datasv; (void)SvGROW ( foo, nbytes ); SvCUR_set( foo, (STRLEN) nbytes ); it->data = (void *) SvPV_nolen( foo ); if (nbytes > ncurr) memset(it->data + ncurr, 0, nbytes - ncurr); it->nbytes = nbytes; it->state |= PDL_ALLOCATED; PDLDEBUG_f(pdl_dump(it)); return PDL_err; } pdl* pdl_pdlnew() { pdl* it; it = (pdl*) malloc(sizeof(pdl)); if (!it) return it; memset(it, 0, sizeof(pdl)); it->magicno = PDL_MAGICNO; it->datatype = PDL_D; it->trans_parent = NULL; it->vafftrans = NULL; it->sv = NULL; it->datasv = 0; it->data = 0; it->has_badvalue = 0; it->state = PDL_NOMYDIMS; it->dims = it->def_dims; it->nbytes = it->nvals = it->dims[0] = 0; it->dimincs = it->def_dimincs; it->dimincs[0] = 1; it->nthreadids = 1; it->threadids = it->def_threadids; it->threadids[0] = it->ndims = 1; PDL_Indx i; for(i=0; itrans_children.trans[i]=NULL;} it->trans_children.next = NULL; it->magic = 0; it->hdrsv = 0; PDLDEBUG_f(printf("pdl_pdlnew %p (size=%zu)\n",(void*)it,sizeof(pdl))); return it; } void pdl_vafftrans_free(pdl *it) { if(it->vafftrans && it->vafftrans->incs) free(it->vafftrans->incs); if(it->vafftrans) free(it->vafftrans); it->vafftrans=0; it->state &= ~PDL_OPT_VAFFTRANSOK; } pdl_error pdl_vafftrans_alloc(pdl *it) { pdl_error PDL_err = {0, NULL, 0}; if(!it->vafftrans) { it->vafftrans = malloc(sizeof(*(it->vafftrans))); if (!it->vafftrans) return pdl_make_error_simple(PDL_EFATAL, "Out of Memory\n"); it->vafftrans->incs = 0; it->vafftrans->ndims = 0; } if(!it->vafftrans->incs || it->vafftrans->ndims < it->ndims ) { if(it->vafftrans->incs) free(it->vafftrans->incs); it->vafftrans->incs = malloc(sizeof(*(it->vafftrans->incs)) * (size_t)it->ndims); if (!it->vafftrans->incs) return pdl_make_error_simple(PDL_EFATAL, "Out of Memory\n"); it->vafftrans->ndims = it->ndims; } return PDL_err; } /* Recursive! */ void pdl_vafftrans_remove(pdl * it) { PDLDEBUG_f(printf("pdl_vafftrans_remove: %p\n", (void*)it)); PDL_DECL_CHILDLOOP(it); PDL_START_CHILDLOOP(it) pdl_trans *t = PDL_CHILDLOOP_THISCHILD(it); if(!(t->flags & PDL_ITRANS_ISAFFINE)) continue; int i; for(i=t->vtable->nparents; ivtable->npdls; i++) pdl_vafftrans_remove(t->pdls[i]); PDL_END_CHILDLOOP(it) pdl_vafftrans_free(it); } /* Explicit free. Do not use, use destroy instead, which causes this to be called when the time is right */ pdl_error pdl__free(pdl *it) { pdl_error PDL_err = {0, NULL, 0}; PDLDEBUG_f(printf("pdl__free %p\n",(void*)it)); PDL_CHKMAGIC(it); /* now check if magic is still there */ if (pdl__ismagic(it)) { PDLDEBUG_f(printf("%p is still magic\n",(void*)it);pdl__print_magic(it)); } it->magicno = 0x42424245; if(it->dims != it->def_dims) free((void*)it->dims); if(it->dimincs != it->def_dimincs) free((void*)it->dimincs); if(it->threadids != it->def_threadids) free((void*)it->threadids); if(it->vafftrans) { pdl_vafftrans_free(it); } pdl_trans_children *p1 = it->trans_children.next; while(p1) { pdl_trans_children *p2 = p1->next; free(p1); p1 = p2; } /* Call special freeing magic, if exists */ if(PDL_ISMAGIC(it)) { pdl__call_magic(it, PDL_MAGIC_DELETEDATA); pdl__magic_free(it); } if(it->datasv) { SvREFCNT_dec(it->datasv); it->data=0; } else if(it->data) { pdl_pdl_warn("Warning: special data without datasv is not freed currently!!"); } if(it->hdrsv) { SvREFCNT_dec(it->hdrsv); it->hdrsv = 0; } free(it); PDLDEBUG_f(printf("pdl__free end %p\n",(void*)it)); return PDL_err; } void pdl__removechildtrans(pdl *it,pdl_trans *trans) { PDLDEBUG_f(printf("pdl__removechildtrans(%s=%p): %p\n", trans->vtable->name, (void*)trans, (void*)(it))); PDL_Indx i; int flag = 0; for(i=0; ivtable->nparents; i++) if(trans->pdls[i] == it) trans->pdls[i] = NULL; PDL_DECL_CHILDLOOP(it); PDL_START_CHILDLOOP(it) if (PDL_CHILDLOOP_THISCHILD(it) != trans) continue; PDL_CHILDLOOP_THISCHILD(it) = NULL; flag = 1; /* Can't return; might be many times (e.g. $x+$x) */ PDL_END_CHILDLOOP(it) /* this might be due to a croak when performing the trans; so warn only for now, otherwise we leave trans undestructed ! */ if(!flag) pdl_pdl_warn("Child not found for pdl %d, %d\n",it, trans); } void pdl__removeparenttrans(pdl *it, pdl_trans *trans, PDL_Indx nth) { PDLDEBUG_f(printf("pdl__removeparenttrans(%s=%p): %p %"IND_FLAG"\n", trans->vtable->name, (void*)trans, (void*)(it), nth)); trans->pdls[nth] = 0; it->trans_parent = 0; } pdl_error pdl_destroytransform(pdl_trans *trans,int ensure,int *wd) { pdl_error PDL_err = {0, NULL, 0}; PDL_TR_CHKMAGIC(trans); PDL_Indx j; int ismutual = (trans->flags & PDL_ITRANS_DO_DATAFLOW_ANY); if (!trans->vtable) return pdl_make_error(PDL_EFATAL, "ZERO VTABLE DESTTRAN 0x%p %d\n",trans,ensure); if (!ismutual) for(j=0; jvtable->nparents; j++) if (trans->pdls[j]->state & PDL_DATAFLOW_ANY) { ismutual=1; break; } PDLDEBUG_f(printf("pdl_destroytransform %s=%p (ensure=%d ismutual=%d)\n", trans->vtable ? trans->vtable->name : "NULL", (void*)trans,ensure,ismutual)); if(ensure) PDL_RETERROR(PDL_err, pdl__ensure_trans(trans,ismutual ? 0 : PDL_PARENTDIMSCHANGED,wd)); pdl *destbuffer[trans->vtable->npdls]; int ndest = 0; if (ismutual) { for(j=0; jvtable->nparents; j++) { pdl *parent = trans->pdls[j]; if(!parent) continue; PDL_CHKMAGIC(parent); pdl__removechildtrans(parent,trans); if(!(parent->state & PDL_DESTROYING) && !parent->sv) destbuffer[ndest++] = parent; } for(; jvtable->npdls; j++) { pdl *child = trans->pdls[j]; PDL_CHKMAGIC(child); pdl__removeparenttrans(child,trans,j); if(child->vafftrans) pdl_vafftrans_remove(child); if(!(child->state & PDL_DESTROYING) && !child->sv) destbuffer[ndest++] = child; } } else { for(j=trans->vtable->nparents; jvtable->npdls; j++) { pdl *child = trans->pdls[j]; if(child->trans_parent == trans) child->trans_parent = 0; } } FREETRANS(trans, 1); if(trans->vtable->flags & PDL_TRANS_DO_THREAD) pdl_freethreadstruct(&trans->pdlthread); trans->vtable = 0; /* Make sure no-one uses this */ PDLDEBUG_f(printf("call free\n")); if (trans->params) free(trans->params); free(trans->ind_sizes); free(trans->inc_sizes); free(trans); for(j=0; jstate & PDL_DESTROYING) { PDLDEBUG_f(printf(" already destroying, returning\n")); return PDL_err; } it->state |= PDL_DESTROYING; /* Clear the sv field so that there will be no dangling ptrs */ if(it->sv) { sv_setiv(it->sv,0x4242); it->sv = NULL; } /* 1. count the trans_children that do flow */ PDL_START_CHILDLOOP(it) pdl_trans *curt = PDL_CHILDLOOP_THISCHILD(it); if(curt->flags & PDL_ITRANS_DO_DATAFLOW_F) nforw ++; if(curt->flags & PDL_ITRANS_DO_DATAFLOW_B) { nback ++; /* Cases where more than two in relationship * must always be soft-destroyed */ if(curt->vtable->npdls > 2) nback2++; } if ((curt->flags & PDL_ITRANS_ISAFFINE) && !(curt->pdls[1]->state & PDL_ALLOCATED)) nafn ++; PDL_END_CHILDLOOP(it) /* First case where we may not destroy */ if(nback2 > 0) goto soft_destroy; if(nback > 1) goto soft_destroy; /* Also not here */ if(it->trans_parent && nforw) goto soft_destroy; /* Also, we do not wish to destroy if the trans_children would be larger * than the parent and are currently not allocated (e.g. lags). * Because this is too much work to check, we refrain from destroying * for now if there is an affine child that is not allocated */ if(nafn) goto soft_destroy; if(pdl__magic_isundestroyable(it)) { PDLDEBUG_f(printf("pdl_destroy not destroying as magic %p\n",(void*)it)); goto soft_destroy; } PDL_START_CHILDLOOP(it) PDL_RETERROR(PDL_err, pdl_destroytransform(PDL_CHILDLOOP_THISCHILD(it),1,NULL)); PDL_END_CHILDLOOP(it) pdl_trans *trans = it->trans_parent; if (trans) /* Ensure only if there are other children! */ PDL_RETERROR(PDL_err, pdl_destroytransform(trans,trans->vtable->npdls - trans->vtable->nparents > 1,NULL)); /* Here, this is a child but has no children - fall through to hard_destroy */ PDL_RETERROR(PDL_err, pdl__free(it)); PDLDEBUG_f(printf("pdl_destroy end %p\n",(void*)it)); return PDL_err; soft_destroy: PDLDEBUG_f(printf("pdl_destroy may have dependencies, not destroy %p, nba(%d, %d), nforw(%d), tra(%p), nafn(%d)\n", (void*)it, nback, nback2, nforw, (void*)(it->trans_parent), nafn)); it->state &= ~PDL_DESTROYING; return PDL_err; } /* Straight copy, no dataflow */ pdl *pdl_hard_copy(pdl *src) { pdl_error PDL_err = pdl_make_physical(src); /* Wasteful XXX... should be lazier */ if (PDL_err.error) return NULL; int i; PDLDEBUG_f(printf("pdl_hard_copy\n")); pdl *it = pdl_pdlnew(); if (!it) return it; it->state = 0; PDLDEBUG_f(printf("pdl_hard_copy (%p): ", src);pdl_dump(it)); it->datatype = src->datatype; PDL_err = pdl_setdims(it,src->dims,src->ndims); if (PDL_err.error) { pdl_destroy(it); return NULL; } PDL_err = pdl_allocdata(it); if (PDL_err.error) { pdl_destroy(it); return NULL; } if(src->state & PDL_NOMYDIMS) it->state |= PDL_NOMYDIMS; PDL_err = pdl_reallocthreadids(it,src->nthreadids); if (PDL_err.error) { pdl_destroy(it); return NULL; } for(i=0; inthreadids; i++) { it->threadids[i] = src->threadids[i]; } memcpy(it->data,src->data, pdl_howbig(it->datatype) * (size_t)it->nvals); return it; } /* Reallocate this PDL to have ndims dimensions. */ pdl_error pdl_reallocdims(pdl *it, PDL_Indx ndims) { pdl_error PDL_err = {0, NULL, 0}; if (it->ndims < ndims) { /* Need to realloc for more */ if(it->dims != it->def_dims) free(it->dims); if(it->dimincs != it->def_dimincs) free(it->dimincs); if (ndims>PDL_NDIMS) { /* Need to malloc */ if (!(it->dims = malloc(ndims*sizeof(*(it->dims))))) return pdl_make_error_simple(PDL_EFATAL, "Out of Memory\n"); if (!(it->dimincs = malloc(ndims*sizeof(*(it->dimincs))))) { free(it->dims); return pdl_make_error_simple(PDL_EFATAL, "Out of Memory\n"); } } else { it->dims = it->def_dims; it->dimincs = it->def_dimincs; } } it->ndims = ndims; return PDL_err; } /* Reallocate n threadids. Set the new extra ones to the end */ pdl_error pdl_reallocthreadids(pdl *it, PDL_Indx n) { pdl_error PDL_err = {0, NULL, 0}; PDL_Indx i; PDL_Indx *olds; PDL_Indx nold; if(n <= it->nthreadids) { it->nthreadids = n; it->threadids[n-1] = it->ndims; return PDL_err; } nold = it->nthreadids; olds = it->threadids; if(n > PDL_NTHREADIDS) { it->threadids = malloc(sizeof(*(it->threadids))*n); if (!it->threadids) return pdl_make_error_simple(PDL_EFATAL, "Out of Memory\n"); } else { it->threadids = it->def_threadids; } it->nthreadids = n; if(it->threadids != olds) { for(i=0; ithreadids[i] = olds[i]; } if(olds != it->def_threadids) { free(olds); } for(i=nold; inthreadids; i++) { it->threadids[i] = it->ndims; } return PDL_err; } /* Recalculate default increments */ void pdl_resize_defaultincs(pdl *it) { PDL_Indx inc = 1, i = 0; for(i=0; indims; i++) { it->dimincs[i] = inc; inc *= it->dims[i]; } if (it->nvals != inc) /* Need to realloc only if nvals changed */ it->state &= ~PDL_ALLOCATED; it->nvals = inc; } /* Init dims & incs - if *incs is NULL ignored (but space is always same for both) */ pdl_error pdl_setdims(pdl* it, PDL_Indx * dims, PDL_Indx ndims) { pdl_error PDL_err = {0, NULL, 0}; PDLDEBUG_f(printf("pdl_setdims %p: ", it);pdl_print_iarr(dims, ndims);printf("\n")); PDL_Indx i, old_nvals = it->nvals, new_nvals = 1; for (i=0; istate & PDL_NOMYDIMS) || ndims != it->ndims) what |= PDL_PARENTDIMSCHANGED; else for (i=0; idims[i]) { what |= PDL_PARENTDIMSCHANGED; break; } if (!what) { PDLDEBUG_f(printf("pdl_setdims NOOP\n")); return PDL_err; } PDL_RETERROR(PDL_err, pdl_reallocdims(it,ndims)); for(i=0; idims[i] = dims[i]; pdl_resize_defaultincs(it); PDL_RETERROR(PDL_err, pdl_reallocthreadids(it,1)); it->threadids[0] = ndims; it->state &= ~PDL_NOMYDIMS; PDL_RETERROR(PDL_err, pdl_changed(it,what,0)); return PDL_err; } /* This is *not* careful! */ pdl_error pdl_setdims_careful(pdl *it) { pdl_error PDL_err = {0, NULL, 0}; pdl_resize_defaultincs(it); PDL_err = pdl_reallocthreadids(it,1); /* XXX For now */ return PDL_err; } PDL_Anyval pdl_get_offs(pdl *it, PDL_Indx offs) { PDL_Indx dummy1=offs+1; PDL_Indx dummy2=1; return pdl_at(it->data, it->datatype, &offs, &dummy1, &dummy2, 0, 1); } pdl_error pdl__addchildtrans(pdl *it,pdl_trans *trans) { pdl_error PDL_err = {0, NULL, 0}; PDLDEBUG_f(printf("pdl__addchildtrans\n")); int i; pdl_trans_children *c = &it->trans_children; do { if (c->next) { c=c->next; continue; } else { for(i=0; itrans[i]) { c->trans[i] = trans; return PDL_err; } break; } } while(1); c = c->next = malloc(sizeof(pdl_trans_children)); if (!c) return pdl_make_error_simple(PDL_EFATAL, "Out of Memory\n"); c->trans[0] = trans; for(i=1; itrans[i] = 0; c->next = 0; return PDL_err; } pdl_error pdl_make_physdims(pdl *it) { pdl_error PDL_err = {0, NULL, 0}; PDL_Indx i; int c = (it->state & PDL_PARENTDIMSCHANGED); PDLDEBUG_f(printf("make_physdims %p (%X)\n",(void*)it, c)); PDL_CHKMAGIC(it); if(!c) { PDLDEBUG_f(printf("make_physdims exit (NOP) %p\n",(void*)it)); return PDL_err; } it->state &= ~PDL_PARENTDIMSCHANGED; PDLDEBUG_f(printf("make_physdims %p TRANS:\n",(void*)it); pdl_dump_trans_fixspace(it->trans_parent,3)); for(i=0; itrans_parent->vtable->nparents; i++) { PDL_RETERROR(PDL_err, pdl_make_physdims(it->trans_parent->pdls[i])); } /* doesn't this mean that all children of this trans have now their dims set and accordingly all those flags should be reset? Otherwise redodims will be called for them again? */ PDLDEBUG_f(printf("make_physdims: calling redodims %p on %p\n", (void*)(it->trans_parent),(void*)it)); REDODIMS(it->trans_parent); /* why this one? will the old allocated data be freed correctly? */ if((c & PDL_PARENTDIMSCHANGED) && (it->state & PDL_ALLOCATED)) { it->state &= ~PDL_ALLOCATED; } PDLDEBUG_f(printf("make_physdims exit %p\n",(void*)it)); return PDL_err; } static inline pdl_error pdl_trans_flow_checks(pdl_trans *trans, int *ret) { pdl_error PDL_err = {0, NULL, 0}; int pfflag=0; PDL_Indx i; pdl_transvtable *vtable = trans->vtable; /* Then, set our children. This is: */ /* First, determine whether any of our children already have * a parent, and whether they need to be updated. If this is * the case, we need to do some thinking. */ for(i=0; inparents; i++) if(trans->pdls[i]->state & PDL_DATAFLOW_ANY) pfflag++; for(; inpdls; i++) { /* If children are flowing, croak. It's too difficult to handle properly */ if(trans->pdls[i]->state & PDL_DATAFLOW_ANY) return pdl_make_error_simple(PDL_EUSERERROR, "Sorry, cannot flowing families right now\n"); /* Same, if children have trans yet parents are flowing */ if(trans->pdls[i]->trans_parent && pfflag) return pdl_make_error_simple(PDL_EUSERERROR, "Sorry, cannot flowing families right now (2)\n"); } *ret = pfflag; return PDL_err; } /* Called with a filled pdl_trans struct. * Sets the parent and trans fields of the ndarrays correctly, * creating families and the like if necessary. * Alternatively may just execute transformation * that would require families but is not dataflowed. */ pdl_error pdl_make_trans_mutual(pdl_trans *trans) { pdl_error PDL_err = {0, NULL, 0}; PDLDEBUG_f(printf("make_trans_mutual %p\n",(void*)trans);pdl_dump_trans_fixspace(trans,3)); pdl_transvtable *vtable = trans->vtable; PDL_Indx i, npdls=vtable->npdls, nparents=vtable->nparents; PDL_TR_CHKMAGIC(trans); int pfflag=0; PDL_RETERROR(PDL_err, pdl_trans_flow_checks(trans, &pfflag)); char dataflow = !!(pfflag || (trans->flags & PDL_ITRANS_DO_DATAFLOW_ANY)); if (dataflow) for(i=0; ipdls[i]; PDL_RETERROR(PDL_err, pdl__addchildtrans(parent,trans)); if (parent->state & PDL_DATAFLOW_F) trans->flags |= PDL_ITRANS_DO_DATAFLOW_F; } int wd[npdls]; for(i=nparents; ipdls[i]; char isnull = !!(child->state & PDL_NOMYDIMS); wd[i]=(isnull ? PDL_PARENTDIMSCHANGED : PDL_PARENTDATACHANGED); if (dataflow) { /* This is because for "+=" (a = a + b) we must check for previous parent transformations and mutate if they exist if no dataflow. */ child->state |= PDL_PARENTDIMSCHANGED | PDL_PARENTDATACHANGED; } if (dataflow || isnull) child->trans_parent = trans; if (isnull) child->state = (child->state & ~PDL_NOMYDIMS) | PDL_MYDIMS_TRANS; } if (!dataflow) PDL_RETERROR(PDL_err, pdl_destroytransform(trans,1,wd)); PDLDEBUG_f(printf("make_trans_mutual exit %p\n",(void*)trans)); return PDL_err; } /* pdl_make_trans_mutual() */ pdl_error pdl_redodims_default(pdl_trans *trans) { pdl_error PDL_err = {0, NULL, 0}; PDLDEBUG_f(printf("pdl_redodims_default ");pdl_dump_trans_fixspace(trans,0)); pdl_transvtable *vtable = trans->vtable; PDL_Indx creating[vtable->npdls]; pdl **pdls = trans->pdls; PDL_Indx i; for (i=0; inpdls; i++) { short flags = vtable->par_flags[i]; creating[i] = (flags & PDL_PARAM_ISCREAT) && PDL_DIMS_FROM_TRANS(trans,pdls[i]); } PDL_RETERROR(PDL_err, pdl_initthreadstruct(2, pdls, vtable->par_realdims, creating, vtable->npdls, vtable, &trans->pdlthread, trans->ind_sizes, trans->inc_sizes, vtable->per_pdl_flags, vtable->flags & PDL_TRANS_NO_PARALLEL)); pdl_hdr_childcopy(trans); trans->dims_redone = 1; return PDL_err; } pdl_error pdl_make_physical(pdl *it) { pdl_error PDL_err = {0, NULL, 0}; int i, vaffinepar=0; DECL_RECURSE_GUARD; PDLDEBUG_f(printf("make_physical %p\n",(void*)it)); PDL_CHKMAGIC(it); START_RECURSE_GUARD; if(it->state & PDL_ALLOCATED && !(it->state & PDL_ANYCHANGED)) { goto mkphys_end; } if(!(it->state & PDL_ANYCHANGED)) { PDL_RETERROR(PDL_err, pdl_allocdata(it)); goto mkphys_end; } if(!it->trans_parent) { ABORT_RECURSE_GUARD; return pdl_make_error_simple(PDL_EFATAL, "PDL Not physical but doesn't have parent"); } if(it->trans_parent->flags & PDL_ITRANS_ISAFFINE) { if(!PDL_VAFFOK(it)) PDL_RETERROR(PDL_err, pdl_make_physvaffine(it)); } if(PDL_VAFFOK(it)) { PDLDEBUG_f(printf("make_physical: VAFFOK\n")); PDL_RETERROR(PDL_err, pdl_readdata_vaffine(it)); it->state &= (~PDL_ANYCHANGED); PDLDEBUG_f(pdl_dump(it)); goto mkphys_end; } PDL_TR_CHKMAGIC(it->trans_parent); for(i=0; itrans_parent->vtable->nparents; i++) { if(VAFFINE_FLAG_OK(it->trans_parent->vtable->per_pdl_flags,i)) { PDL_RETERROR(PDL_err, pdl_make_physvaffine(it->trans_parent->pdls[i])); /* check if any of the parents is a vaffine */ vaffinepar = vaffinepar || (it->trans_parent->pdls[i]->data != PDL_REPRP(it->trans_parent->pdls[i])); } else PDL_RETERROR(PDL_err, pdl_make_physical(it->trans_parent->pdls[i])); } /* XXX The real question is: why do we need another call to * redodims if !(it->state & PDL_ALLOCATED)?????? */ if((!(it->state & PDL_ALLOCATED) && vaffinepar) || it->state & PDL_PARENTDIMSCHANGED) REDODIMS(it->trans_parent); if(!(it->state & PDL_ALLOCATED)) { PDL_RETERROR(PDL_err, pdl_allocdata(it)); } READDATA(it->trans_parent); it->state &= ~(PDL_ANYCHANGED | PDL_OPT_ANY_OK); mkphys_end: PDLDEBUG_f(printf("make_physical exit %p\n",(void*)it)); END_RECURSE_GUARD; return PDL_err; } pdl_error pdl_changed(pdl *it, int what, int recursing) { pdl_error PDL_err = {0, NULL, 0}; int i; int j; PDLDEBUG_f( printf("pdl_changed: entry for pdl %p recursing: %d, what ", (void*)it,recursing); pdl_dump_flags_fixspace(what,0,PDL_FLAGS_PDL); if (it->state & PDL_TRACEDEBUG) pdl_dump(it); ); if(recursing) { it->state |= what; if(pdl__ismagic(it)) pdl__call_magic(it,PDL_MAGIC_MARKCHANGED); } if(it->trans_parent && !recursing && (it->trans_parent->flags & PDL_ITRANS_DO_DATAFLOW_B)) { pdl_trans *trans = it->trans_parent; if((trans->flags & PDL_ITRANS_ISAFFINE) && (PDL_VAFFOK(it))) { PDLDEBUG_f(printf("pdl_changed: calling writebackdata_vaffine (pdl %p)\n",(void*)it)); PDL_RETERROR(PDL_err, pdl_writebackdata_vaffine(it)); PDL_RETERROR(PDL_err, pdl_changed(it->vafftrans->from,what,0)); } else { PDLDEBUG_f(printf("pdl_changed: calling writebackdata from vtable, triggered by pdl %p, using trans %p\n",(void*)it,(void*)(trans))); WRITEDATA(trans); for(i=0; ivtable->nparents; i++) { pdl *pdl = trans->pdls[i]; PDL_RETERROR(PDL_err, pdl_changed( (VAFFINE_FLAG_OK(trans->vtable->per_pdl_flags,i) && pdl->trans_parent && (pdl->trans_parent->flags & PDL_ITRANS_ISAFFINE) && PDL_VAFFOK(pdl)) ? pdl->vafftrans->from : pdl, what,0)); } } } else { PDL_DECL_CHILDLOOP(it); PDL_START_CHILDLOOP(it) pdl_trans *trans = PDL_CHILDLOOP_THISCHILD(it); for(j=trans->vtable->nparents; jvtable->npdls; j++) PDL_RETERROR(PDL_err, pdl_changed(trans->pdls[j],what,1)); PDL_END_CHILDLOOP(it) } PDLDEBUG_f(printf("pdl_changed: exiting for pdl %p\n",(void*)it)); return PDL_err; } /* Current assumptions: only * "slice" and "diagonal"-type things supported. * * We need to do careful testing for clump-type things. */ /* pdl_make_physvaffine can be called on *any* pdl -- vaffine or not -- it will call make_physical as needed on those this function is the right one to call in any case if you want to make only those physical (i.e. allocating their own data, etc) which have to be and leave those vaffine with updated dims, etc, that do have an appropriate transformation of which they are a child should probably have been called make_physcareful to point out what it really does */ pdl_error pdl_make_physvaffine(pdl *it) { pdl_error PDL_err = {0, NULL, 0}; pdl_trans *t; pdl *parent; pdl *current; PDL_Indx i,j; PDL_Indx inc; PDL_Indx newinc; PDL_Indx ninced; int flag; int incsign; PDLDEBUG_f(printf("make_physvaffine %p\n",(void*)it)); PDL_RETERROR(PDL_err, pdl_make_physdims(it)); PDL_Indx incsleft[it->ndims]; if(!it->trans_parent) { PDL_RETERROR(PDL_err, pdl_make_physical(it)); goto mkphys_vaff_end; } if(!(it->trans_parent->flags & PDL_ITRANS_ISAFFINE)) { PDL_RETERROR(PDL_err, pdl_make_physical(it)); goto mkphys_vaff_end; } if (!it->vafftrans || it->vafftrans->ndims < it->ndims) PDL_RETERROR(PDL_err, pdl_vafftrans_alloc(it)); for(i=0; indims; i++) { it->vafftrans->incs[i] = it->dimincs[i]; } flag=0; it->vafftrans->offs = 0; t=it->trans_parent; current = it; while(t && (t->flags & PDL_ITRANS_ISAFFINE)) { PDL_Indx cur_offset = 0; if (!t->incs) return pdl_make_error_simple(PDL_EUSERERROR, "pdl_make_physvaffine: affine trans has NULL incs\n"); parent = t->pdls[0]; /* For all dimensions of the childest ndarray */ for(i=0; indims; i++) { PDL_Indx offset_left = it->vafftrans->offs; /* inc = the increment at the current stage */ inc = it->vafftrans->incs[i]; incsign = (inc >= 0 ? 1:-1); inc *= incsign; newinc = 0; /* For all dimensions of the current ndarray */ for(j=current->ndims-1; j>=0 && current->dimincs[j] != 0; j--) { cur_offset = offset_left / current->dimincs[j]; offset_left -= cur_offset * current->dimincs[j]; if(incsign < 0) { cur_offset = (current->dims[j]-1) - cur_offset; } /* If the absolute value > this so */ /* we have a contribution from this dimension */ if(inc >= current->dimincs[j]) { /* We used this many of this dim */ ninced = inc / current->dimincs[j]; if(cur_offset + it->dims[i]*ninced > current->dims[j]) { PDL_Indx foo = (cur_offset + it->dims[i]*ninced)* current->dimincs[j]; PDL_Indx k; for(k=j+1; kndims; k++) { foo -= current->dimincs[k-1] * current->dims[k-1]; if(foo<=0) break; if(t->incs[k] != t->incs[k-1] * current->dims[k-1]) { /* XXXXX */ flag=1; /* warn("Illegal vaffine; fix loop to break: %d %d %d k=%d s=%d, (%d+%d*%d>%d) %d %d %d %d.\n",t,current,it, k,incsign,cur_offset,it->dims[i],ninced,current->dims[j],current->dimincs[j], t->incs[k],t->incs[k-1],current->dims[k-1]); */ } } } newinc += t->incs[j]*ninced; inc %= current->dimincs[j]; } } incsleft[i] = incsign*newinc; } if(flag) break; for(i=0; indims; i++) { it->vafftrans->incs[i] = incsleft[i]; } { PDL_Indx offset_left = it->vafftrans->offs; inc = it->vafftrans->offs; newinc = 0; for(j=current->ndims-1; j>=0 && current->dimincs[j] != 0; j--) { cur_offset = offset_left / current->dimincs[j]; offset_left -= cur_offset * current->dimincs[j]; newinc += t->incs[j]*cur_offset; } it->vafftrans->offs = newinc; it->vafftrans->offs += t->offs; } t = parent->trans_parent; current = parent; } it->vafftrans->from = current; it->state |= PDL_OPT_VAFFTRANSOK; PDL_RETERROR(PDL_err, pdl_make_physical(current)); mkphys_vaff_end: PDLDEBUG_f(printf("make_physvaffine exit %p\n",(void*)it)); return PDL_err; } pdl_error pdl_set_datatype(pdl *a, int datatype) { pdl_error PDL_err = {0, NULL, 0}; PDL_RETERROR(PDL_err, pdl_make_physical(a)); if(a->trans_parent) PDL_RETERROR(PDL_err, pdl_destroytransform(a->trans_parent,1,NULL)); if (a->state & PDL_NOMYDIMS) a->datatype = datatype; else PDL_RETERROR(PDL_err, pdl_converttype( a, datatype )); return PDL_err; } pdl_error pdl_sever(pdl *src) { pdl_error PDL_err = {0, NULL, 0}; if (!src->trans_parent) return PDL_err; PDL_RETERROR(PDL_err, pdl_make_physvaffine(src)); PDL_RETERROR(PDL_err, pdl_destroytransform(src->trans_parent,1,NULL)); return PDL_err; } /* newval = 1 means set flag, 0 means clear it */ void pdl_propagate_badflag( pdl *it, int newval ) { PDL_DECL_CHILDLOOP(it) PDL_START_CHILDLOOP(it) { pdl_trans *trans = PDL_CHILDLOOP_THISCHILD(it); int i; for( i = trans->vtable->nparents; i < trans->vtable->npdls; i++ ) { pdl *child = trans->pdls[i]; char need_recurse = (!!newval != !!(child->state & PDL_BADVAL)); if ( newval ) { child->state |= PDL_BADVAL; } else { child->state &= ~PDL_BADVAL; } /* make sure we propagate to grandchildren, etc if changed */ if (need_recurse) pdl_propagate_badflag( child, newval ); } /* for: i */ } PDL_END_CHILDLOOP(it) } /* pdl_propagate_badflag */ void pdl_propagate_badvalue( pdl *it ) { PDL_DECL_CHILDLOOP(it) PDL_START_CHILDLOOP(it) { pdl_trans *trans = PDL_CHILDLOOP_THISCHILD(it); int i; for( i = trans->vtable->nparents; i < trans->vtable->npdls; i++ ) { pdl *child = trans->pdls[i]; child->has_badvalue = 1; child->badvalue = it->badvalue; /* make sure we propagate to grandchildren, etc */ pdl_propagate_badvalue( child ); } /* for: i */ } PDL_END_CHILDLOOP(it) } /* pdl_propagate_badvalue */ PDL_Anyval pdl_get_badvalue( int datatype ) { PDL_Anyval retval = { PDL_INVALID, {0} }; #define X(datatype, ctype, ppsym, shortctype, ...) \ retval.type = datatype; retval.value.ppsym = PDL.bvals.shortctype; PDL_GENERICSWITCH(PDL_TYPELIST2_ALL, datatype, X, return retval) #undef X return retval; } PDL_Anyval pdl_get_pdl_badvalue( pdl *it ) { return it->has_badvalue ? it->badvalue : pdl_get_badvalue( it->datatype ); } pdl_trans *pdl_create_trans(pdl_transvtable *vtable) { size_t it_sz = sizeof(pdl_trans)+sizeof(pdl *)*vtable->npdls; pdl_trans *it = malloc(it_sz); if (!it) return it; memset(it, 0, it_sz); PDL_TR_SETMAGIC(it); if (vtable->structsize) { it->params = malloc(vtable->structsize); if (!it->params) return NULL; memset(it->params, 0, vtable->structsize); } it->flags = vtable->iflags; it->dims_redone = 0; it->bvalflag = 0; it->vtable = vtable; PDL_THR_CLRMAGIC(&it->pdlthread); it->pdlthread.inds = 0; it->ind_sizes = (PDL_Indx *)malloc(sizeof(PDL_Indx) * vtable->ninds); if (!it->ind_sizes) return NULL; int i; for (i=0; ininds; i++) it->ind_sizes[i] = -1; it->inc_sizes = (PDL_Indx *)malloc(sizeof(PDL_Indx) * vtable->nind_ids); if (!it->inc_sizes) return NULL; for (i=0; inind_ids; i++) it->inc_sizes[i] = -1; it->offs = -1; it->incs = NULL; it->__datatype = PDL_INVALID; return it; } pdl_error pdl_type_coerce(pdl_trans *trans) { pdl_error PDL_err = {0, NULL, 0}; PDL_Indx i; pdl_transvtable *vtable = trans->vtable; pdl **pdls = trans->pdls; trans->__datatype = -1; char parent_has_badvalue = 0; PDL_Anyval parent_badvalue = {PDL_INVALID, {0}}; if (vtable->npdls == 2 && pdls[0]->has_badvalue && (vtable->par_flags[1] & PDL_PARAM_ISCREATEALWAYS)) { /* P2Child case */ parent_has_badvalue = 1; parent_badvalue = pdls[0]->badvalue; } for (i=0; inpdls; i++) { pdl *pdl = pdls[i]; short flags = vtable->par_flags[i]; if (flags & (PDL_PARAM_ISIGNORE|PDL_PARAM_ISTYPED|PDL_PARAM_ISCREATEALWAYS)) continue; if (trans->__datatype < pdl->datatype && ( !(flags & PDL_PARAM_ISCREAT) || ((flags & PDL_PARAM_ISCREAT) && !((pdl->state & PDL_NOMYDIMS) && pdl->trans_parent == NULL)) )) trans->__datatype = pdl->datatype; } int type_match = 0, last_dtype = -1; for (i=0;vtable->gentypes[i]!=-1; i++) { last_dtype = vtable->gentypes[i]; if (trans->__datatype != last_dtype) continue; type_match = 1; break; } if (!type_match) trans->__datatype = last_dtype; pdl_datatypes trans_dtype = trans->__datatype; for (i=0; inpdls; i++) { pdl *pdl = pdls[i]; short flags = vtable->par_flags[i]; pdl_datatypes new_dtype = trans_dtype; if (flags & PDL_PARAM_ISIGNORE) continue; if (flags & PDL_PARAM_ISTYPED) { new_dtype = vtable->par_types[i]; if (flags & PDL_PARAM_ISTPLUS) new_dtype = PDLMAX(new_dtype, trans_dtype); } else if (flags & PDL_PARAM_ISREAL) { if (trans_dtype >= PDL_CF) new_dtype = trans_dtype - (PDL_CF - PDL_F); } else if (flags & PDL_PARAM_ISCOMPLEX) { if (trans_dtype < PDL_CF) new_dtype = PDLMAX(PDL_CF, trans_dtype + (PDL_CF - PDL_F)); } if ((pdl->state & PDL_NOMYDIMS) && (!pdl->trans_parent || pdl->trans_parent == trans)) { pdl->badvalue = parent_badvalue; pdl->has_badvalue = parent_has_badvalue; pdl->datatype = new_dtype; } else if (new_dtype != pdl->datatype) { PDLDEBUG_f(printf("pdl_type_coerce (%s) pdl=%"IND_FLAG" from %d to %d\n", vtable->name, i, pdl->datatype, new_dtype)); pdl = pdl_get_convertedpdl(pdl, new_dtype); if (!pdl) return pdl_make_error(PDL_EFATAL, "%s got NULL pointer from get_convertedpdl on param %s", vtable->name, vtable->par_names[i]); if (pdl->datatype != new_dtype) return pdl_make_error_simple(PDL_EFATAL, "type not expected value after get_convertedpdl\n"); pdls[i] = pdl; } } return PDL_err; } char pdl_trans_badflag_from_inputs(pdl_trans *trans) { PDL_Indx i; pdl_transvtable *vtable = trans->vtable; pdl **pdls = trans->pdls; char retval = 0; for (i=0; inpdls; i++) { pdl *pdl = pdls[i]; if ((vtable->par_flags[i] & (PDL_PARAM_ISOUT|PDL_PARAM_ISTEMP)) || !(pdl->state & PDL_BADVAL)) continue; trans->bvalflag = retval = 1; break; } if (retval && (vtable->flags & PDL_TRANS_BADIGNORE)) { printf("WARNING: %s does not handle bad values.\n", vtable->name); trans->bvalflag = 0; /* but still return true */ } return retval; } pdl_error pdl_trans_check_pdls(pdl_trans *trans) { pdl_error PDL_err = {0, NULL, 0}; PDL_Indx i; pdl_transvtable *vtable = trans->vtable; pdl **pdls = trans->pdls; for (i=0; inpdls; i++) { if (vtable->par_flags[i] & PDL_PARAM_ISTEMP) if (!(pdls[i] = pdl_pdlnew())) return pdl_make_error_simple(PDL_EFATAL, "Error in pdlnew"); if (!pdls[i]) return pdl_make_error(PDL_EFATAL, "%s got NULL pointer on param %s", vtable->name, vtable->par_names[i]); } return PDL_err; } PDL-2.074/Basic/Core/Types.pm.PL0000644000175000017500000005752514172770563016012 0ustar osboxesosboxesuse strict; use Config; use File::Basename qw(&basename &dirname); my @TYPE_VERBATIM = qw/ realctype ppforcetype usenan real unsigned integer identifier /; # Figure out the 4 byte integer type on this machine sub packtypeof_PDL_Indx { if ($Config{'ivsize'} == 8) { return 'q*'; } elsif ($Config{'ivsize'} == 4 ) { return 'l*'; } else { die "Types.pm.PL: packtype for ivsize==$Config{'ivsize'} not handled\n"; } } # Data types *must* be listed in order of complexity!! # this is critical for type conversions!!! # my @types = ( { identifier => 'SB', onecharident => 'A', # only needed if different from identifier pdlctype => 'PDL_SByte',# to be defined in pdl.h realctype => 'signed char', ppforcetype => 'sbyte', # for some types different from ctype usenan => 0, # do we need NaN handling for this type? packtype => 'c*', # the perl pack type defaultbadval => 'SCHAR_MIN', real=>1, integer=>1, unsigned=>0, }, { identifier => 'B', pdlctype => 'PDL_Byte',# to be defined in pdl.h realctype => 'unsigned char', ppforcetype => 'byte', # for some types different from ctype usenan => 0, # do we need NaN handling for this type? packtype => 'C*', # the perl pack type defaultbadval => 'UCHAR_MAX', real=>1, integer=>1, unsigned=>1, }, { identifier => 'S', pdlctype => 'PDL_Short', realctype => 'short', ppforcetype => 'short', usenan => 0, packtype => 's*', defaultbadval => 'SHRT_MIN', real=>1, integer=>1, unsigned=>0, }, { identifier => 'US', onecharident => 'U', # only needed if different from identifier pdlctype => 'PDL_Ushort', realctype => 'unsigned short', ppforcetype => 'ushort', usenan => 0, packtype => 'S*', defaultbadval => 'USHRT_MAX', real=>1, integer=>1, unsigned=>1, }, { identifier => 'L', pdlctype => 'PDL_Long', realctype => 'int32_t', ppforcetype => 'int', usenan => 0, packtype => 'l*', defaultbadval => 'INT32_MIN', real=>1, integer=>1, unsigned=>0, }, { identifier => 'UL', onecharident => 'K', # only needed if different from identifier pdlctype => 'PDL_ULong', realctype => 'uint32_t', ppforcetype => 'uint', usenan => 0, packtype => 'L*', defaultbadval => 'UINT32_MAX', real=>1, integer=>1, unsigned=>1, }, # The PDL_Indx type will be either the same as PDL_Long or, probably, # the same as PDL_LongLong depending on the platform. Will need to # determine the actual type at build time. { identifier => 'IND', onecharident => 'N', # only needed if different from identifier pdlctype => 'PDL_Indx', realctype => 'ptrdiff_t', ppforcetype => 'indx', usenan => 0, packtype => &packtypeof_PDL_Indx, defaultbadval => 'PTRDIFF_MIN', real=>1, integer=>1, unsigned=>0, }, # note that the I/O routines have *not* been updated to be aware of # such a type yet { # this one before LL so last integer is signed, to avoid default-type (last in list) changing to unsigned identifier => 'ULL', onecharident => 'P', # only needed if different from identifier pdlctype => 'PDL_ULongLong', realctype => 'uint64_t', ppforcetype => 'ulonglong', usenan => 0, packtype => 'Q*', defaultbadval => 'UINT64_MAX', real=>1, integer=>1, unsigned=>1, }, { identifier => 'LL', onecharident => 'Q', # only needed if different from identifier pdlctype => 'PDL_LongLong', realctype => 'int64_t', ppforcetype => 'longlong', usenan => 0, packtype => 'q*', defaultbadval => 'INT64_MIN', real=>1, integer=>1, unsigned=>0, }, # IMPORTANT: # PDL_F *must* be the first non-integer type in this list # as there are many places in the code (.c/.xs/.pm/.pd) # with tests like this: # if (ndarraytype < PDL_F) { ... } { identifier => 'F', pdlctype => 'PDL_Float', realctype => 'float', ppforcetype => 'float', usenan => 1, packtype => 'f*', defaultbadval => '-FLT_MAX', real=>1, complexversion=> 'G', integer=>0, unsigned=>0, isnan=>'isnan(%1$s)', isfinite=>'isfinite(%1$s)', floatsuffix=>'f', }, { identifier => 'D', pdlctype => 'PDL_Double', realctype => 'double', ppforcetype => 'double', usenan => 1, packtype => 'd*', defaultbadval => '-DBL_MAX', real=>1, complexversion=> 'C', integer=>0, unsigned=>0, isnan=>'isnan(%1$s)', isfinite=>'isfinite(%1$s)', floatsuffix=>'', }, { identifier => 'LD', onecharident => 'E', # only needed if different from identifier pdlctype => 'PDL_LDouble', realctype => 'long double', ppforcetype => 'ldouble', usenan => 1, packtype => 'D*', defaultbadval => '-LDBL_MAX', real=>1, complexversion=> 'CLD', integer=>0, unsigned=>0, isnan=>'isnan(%1$s)', isfinite=>'isfinite(%1$s)', floatsuffix=>'l', }, # the complex types need to be in the same order as their real # counterparts, because the "real" ppforcetype relies on a fixed interval # between real and complex versions # they also need to occur at the end of the types, as a < PDL_CF # comparison is done at C level to see if a type is real, analogous to # the < PDL_F above { identifier => 'CF', onecharident => 'G', # only needed if different from identifier pdlctype => 'PDL_CFloat', realctype => 'complex float', ppforcetype => 'cfloat', usenan => 1, packtype => '(ff)*', defaultbadval => '(-FLT_MAX - I*FLT_MAX)', real=>0, realversion=>'F', integer=>0, unsigned=>0, isnan=>'(isnan(crealf(%1$s)) || isnan(cimagf(%1$s)))', isfinite=>'(isfinite(crealf(%1$s)) && isfinite(cimagf(%1$s)))', floatsuffix=>'f', }, { identifier => 'CD', onecharident => 'C', # only needed if different from identifier pdlctype => 'PDL_CDouble', realctype => 'complex double', ppforcetype => 'cdouble', usenan => 1, packtype => '(dd)*', defaultbadval => '(-DBL_MAX - I*DBL_MAX)', real=>0, realversion=>'D', integer=>0, unsigned=>0, isnan=>'(isnan(creal(%1$s)) || isnan(cimag(%1$s)))', isfinite=>'(isfinite(creal(%1$s)) && isfinite(cimag(%1$s)))', floatsuffix=>'', }, { identifier => 'CLD', onecharident => 'H', # only needed if different from identifier pdlctype => 'PDL_CLDouble', realctype => 'complex long double', ppforcetype => 'cldouble', usenan => 1, packtype => '(DD)*', defaultbadval => '(-LDBL_MAX - I*LDBL_MAX)', real=>0, realversion=>'LD', integer=>0, unsigned=>0, isnan=>'(isnan(creall(%1$s)) || isnan(cimagl(%1$s)))', isfinite=>'(isfinite(creall(%1$s)) && isfinite(cimagl(%1$s)))', floatsuffix=>'l', }, ); sub checktypehas { my ($key,@types) = @_; for my $type (@types) { die "type is not a HASH ref" unless ref $type eq 'HASH'; die "type hash doesn't have a key '$key'" unless exists $type->{$key}; } } sub gentypevars { my @types = @_; checktypehas 'identifier', @types; my @ret = map {"\$PDL_$_->{identifier}"} @types; return wantarray ? @ret : $ret[0]; } sub genexports { my @types = @_; return join ' ', gentypevars @types; } sub gentypenames { my @types = @_; checktypehas 'identifier', @types; my @ret = map {"PDL_$_->{identifier}"} @types; return wantarray ? @ret : $ret[0]; } sub genpacktypes { my @types = @_; checktypehas 'packtype', @types; my @ret = map {"$_->{packtype}"} @types; return wantarray ? @ret : $ret[0]; } sub convertfunc { my ($type) = @_; return $type->{'convertfunc'} if exists $type->{'convertfunc'}; checktypehas 'pdlctype', $type; my $cfunc = $type->{pdlctype}; $cfunc =~ s/PDL_//; return lc $cfunc; } sub gentypehashentry ($$) { my ($type,$num) = @_; checktypehas $_, $type for qw/pdlctype defaultbadval/, @TYPE_VERBATIM; my $convertfunc = convertfunc($type); (my $shortctype = $type->{pdlctype}) =~ s/PDL_//; my $ppsym = $type->{onecharident} || $type->{identifier}; +{ ctype => $type->{pdlctype}, ppsym => $ppsym, convertfunc => $convertfunc, sym => &gentypenames($type), numval => $num, ioname => $convertfunc, defbval => $type->{defaultbadval}, shortctype => $shortctype, realversion => $type->{realversion} || $ppsym, complexversion => $type->{complexversion} || (!$type->{real} ? $ppsym : 'G'), (map +($_ => $type->{$_}), @TYPE_VERBATIM, qw(isnan isfinite floatsuffix)), }; } sub gentypehashcode { my @types = @_; use Data::Dumper; local $Data::Dumper::Terse = 1; local $Data::Dumper::Indent = 1; local $Data::Dumper::Sortkeys = 1; local $Data::Dumper::Pad = "\t\t"; my $i = 0; my $perlcode = ''; $perlcode .= "our %typehash = (\n"; for my $type (@types) { $perlcode .= "\t".gentypenames($type)." =>\n"; $perlcode .= Data::Dumper::Dumper(gentypehashentry($type, $i++)); $perlcode .= "\t\t,\n"; } $perlcode .= "); # end typehash definition\n"; return $perlcode; } # List explicitly here the variables you want Configure to # generate. Metaconfig only looks for shell variables, so you # have to mention them as if they were shell variables, not # %Config entries. Thus you write # $startperl # to ensure Configure will look for $Config{startperl}. # This forces PL files to create target in same directory as PL file. # This is so that make depend always knows where to find PL derivatives. chdir(dirname($0)); my $file; ($file = basename($0)) =~ s/\.PL$//; $file =~ s/\.pl$// if ($Config{'osname'} eq 'VMS' or $Config{'osname'} eq 'OS2'); # "case-forgiving" open OUT,">$file" or die "Can't create $file: $!"; print "Extracting $file\n"; chmod 0644, $file; # in the following we generate the type dependent # parts of Types.pm # all the required info is extracted from the @types # array defined above # the guts how this is done is encapsulated in the subroutines # that follow the definition of @types # set up some variables that we will use below my $typeexports = genexports @types; my $ntypesm1 = @types - 1; # number of types - 1 my $typevars = join ', ',gentypevars @types; my $packtypes = join ' ', genpacktypes @types; my $typenames = join ' ', gentypenames @types; print OUT sprintf qq{#line %d "%s"\n}, __LINE__ + 2, 'Basic/Core/Types.pm.PL'; print OUT <<'!NO!SUBS!'; ### Generated from Types.pm.PL automatically - do not modify! ### package PDL::Types; use strict; use warnings; require Exporter; use Carp; !NO!SUBS! print OUT qq{ our \@EXPORT = qw( $typeexports \@pack \%typehash ); }; print OUT <<'!NO!SUBS!'; our @EXPORT_OK = (@EXPORT, qw/types typesrtkeys mapfld typefld ppdefs ppdefs_complex ppdefs_all / ); our %EXPORT_TAGS = ( All=>[@EXPORT,@EXPORT_OK], ); our @ISA = qw( Exporter ); !NO!SUBS! print OUT qq{ # Data types/sizes (bytes) [must be in order of complexity] # Enum our ( $typevars ) = (0..$ntypesm1); # Corresponding pack types our \@pack= qw/$packtypes/; our \@names= qw/$typenames/; }; # generate the typehash output print OUT gentypehashcode @types; print OUT <<'!NO!SUBS!'; # Cross-reference by common names my @HASHES = sort {$a->{numval} <=> $b->{numval}} values %typehash; my @RTKEYS = map $_->{sym}, @HASHES; our %typenames; for my $h (@HASHES) { my $n = $h->{numval}; $typenames{$_} = $n for $n, @$h{qw(sym ioname ctype ppforcetype ppsym identifier)}; } =head1 NAME PDL::Types - define fundamental PDL Datatypes =head1 SYNOPSIS use PDL::Types; $pdl = ushort( 2.0, 3.0 ); print "The actual c type used to store ushort's is '" . $pdl->type->realctype() . "'\n"; The actual c type used to store ushort's is 'unsigned short' =head1 DESCRIPTION Internal module - holds all the PDL Type info. The type info can be accessed easily using the C object returned by the L method. Skip to the end of this document to find out how to change the set of types supported by PDL. =head1 FUNCTIONS A number of functions are available for module writers to get/process type information. These are used in various places (e.g. C, C) to generate the appropriate type loops, etc. =head2 typesrtkeys =for ref Returns an array of keys of typehash sorted in order of type complexity =for example pdl> @typelist = PDL::Types::typesrtkeys; pdl> print @typelist; PDL_B PDL_S PDL_US PDL_L PDL_IND PDL_LL PDL_F PDL_D =cut sub typesrtkeys { @RTKEYS } =head2 ppdefs =for ref Returns an array of pp symbols for all real types. This informs the default C for C functions, making support for complex types require an "opt-in". =for example pdl> print PDL::Types::ppdefs B S U L N Q F D =cut my @PPDEFS = map $_->{ppsym}, grep $_->{real}, @HASHES; sub ppdefs { @PPDEFS } =head2 ppdefs_complex =for ref Returns an array of pp symbols for all complex types. =for example pdl> print PDL::Types::ppdefs_complex G C =cut my @PPDEFS_CPLX = map $_->{ppsym}, grep !$_->{real}, @HASHES; sub ppdefs_complex { @PPDEFS_CPLX } =head2 ppdefs_all =for ref Returns an array of pp symbols for all types including complex. =for example pdl> print PDL::Types::ppdefs_all B S U L N Q F D G C =cut my @PPDEFS_ALL = map $_->{ppsym}, @HASHES; sub ppdefs_all { @PPDEFS_ALL } =head2 typefld =for ref Returns specified field (C<$fld>) for specified type (C<$type>) by querying type hash =for usage PDL::Types::typefld($type,$fld); =for example pdl> print PDL::Types::typefld('PDL_IND',realctype) long =cut sub typefld { my ($type,$fld) = @_; croak "unknown type $type" unless exists $typehash{$type}; croak "unknown field $fld in type $type" unless exists $typehash{$type}->{$fld}; return $typehash{$type}->{$fld}; } =head2 mapfld Map a given source field to the corresponding target field by querying the type hash. This gives you a way to say, "Find the type whose C<$in_key> is equal to C<$value>, and return that type's value for C<$out_key>. For example: # Does byte type use nan? $uses_nan = PDL::Types::mapfld(byte => 'ppforcetype', 'usenan'); # Equivalent: $uses_nan = byte->usenan; # What is the actual C type for the value that we call 'long'? $type_name = PDL::Types::mapfld(long => 'convertfunc', 'realctype'); # Equivalent: $type_name = long->realctype; As you can see, the equivalent examples are much shorter and legible, so you should only use mapfld if you were given the type index (in which case the actual type is not immediately obvious): $type_index = 4; $type_name = PDL::Types::mapfld($type_index => numval, 'realctype'); =cut sub mapfld { my ($type,$src,$trg) = @_; my @keys = grep {$typehash{$_}->{$src} eq $type} typesrtkeys; return @keys > 0 ? $typehash{$keys[0]}->{$trg} : undef; } =head2 typesynonyms =for ref return type related synonym definitions to be included in pdl.h . This routine must be updated to include new types as required. Mostly the automatic updating should take care of the vital things. =cut sub typesynonyms { my $add = join "\n", map {"#define PDL_".typefld($_,'ppsym')." ".typefld($_,'sym')} grep {"PDL_".typefld($_,'ppsym') ne typefld($_,'sym')} typesrtkeys; return "$add\n"; } =head1 PDL::Type OBJECTS This module declares one class - C - objects of this class are returned by the L method of an ndarray. It has several methods, listed below, which provide an easy way to access type information: Additionally, comparison and stringification are overloaded so that you can compare and print type objects, e.g. $nofloat = 1 if $pdl->type < float; die "must be double" if $type != double; For further examples check again the L method. =over 4 =item enum Returns the number representing this datatype (see L). =item symbol Returns one of 'PDL_B', 'PDL_S', 'PDL_US', 'PDL_L', 'PDL_IND', 'PDL_LL', 'PDL_F' or 'PDL_D'. =item ctype Returns the macro used to represent this type in C code (eg 'PDL_Long'). =item ppsym The letter used to represent this type in PP code (eg 'U' for L). =item realctype The actual C type used to store this type. =item shortctype The value returned by C without the 'PDL_' prefix. =item badvalue The special numerical value used to represent bad values for this type. See L for more details. =item isnan Given a string representing a C value, will return a C expression for this type that indicates whether that value is NaN (for complex values, if I is NaN). =item isfinite Given a string representing a C value, will return a C expression for this type that indicates whether that value is finite (for complex values, if I are finite). =item floatsuffix The string appended to floating-point functions for this floating-point type. Dies if called on non-floating-point type. =item orig_badvalue The default special numerical value used to represent bad values for this type. (You can change the value that represents bad values for each type during runtime.) See the L for more details. =item bswap Returns the appropriate C from L for the size of this type, including a no-op for types of size 1. Note this means a one-line construction means you must call the return value: $pdl->type->bswap->($pdl); =back =cut my @CACHED_TYPES = map bless([$_->{numval}, $_], 'PDL::Type'), @HASHES; # return all known types as type objects sub types { @CACHED_TYPES } { package PDL::Type; use Carp; sub new { my ($type,$val) = @_; return $val if "PDL::Type" eq ref $val; if(ref $val and $val->isa('PDL')) { PDL::Core::barf("Can't make a type out of non-scalar ndarray $val!") if $val->getndims != 0; $val = $val->at; } confess "Can't make a type out of non-scalar $val (". (ref $val).")!" if ref $val; confess "Unknown type string '$val' (should be one of ". join(",",map $PDL::Types::typehash{$_}->{ioname}, @names). ")\n" if !defined $PDL::Types::typenames{$val}; $CACHED_TYPES[$PDL::Types::typenames{$val}]; } sub enum { $_[0][0] } *symbol = \&sym; sub realversion { $CACHED_TYPES[$PDL::Types::typenames{ $_[0][1]{realversion} }]; } sub complexversion { $CACHED_TYPES[$PDL::Types::typenames{ $_[0][1]{complexversion} }]; } sub isnan { sprintf $_[0][1]{isnan}, $_[1] } sub isfinite { sprintf $_[0][1]{isfinite}, $_[1] } sub floatsuffix { $_[0][1]{floatsuffix} // 'floatsuffix called on non-float type' } my %bswap_cache; sub bswap { PDL::Core::barf('Usage: $type->bswap with no args') if @_ > 1; return $bswap_cache{$_[0][0]} if $bswap_cache{$_[0][0]}; my $size = PDL::Core::howbig($_[0][0]); return $bswap_cache{$_[0][0]} = sub {} if $size < 2; require PDL::IO::Misc; $bswap_cache{$_[0][0]} = $size == 2 ? \&PDL::bswap2 : $size == 4 ? \&PDL::bswap4 : $size == 8 ? \&PDL::bswap8 : PDL::Core::barf("bswap couldn't find swap function for $_[0][1]{shortctype}"); } !NO!SUBS! foreach my $name ( qw( ctype ppsym convertfunc shortctype sym numval ioname defbval ), @TYPE_VERBATIM ) { print OUT << "EOS"; sub $name { \$_[0][1]{$name}; } EOS } print OUT <<'!NO!SUBS!'; sub badvalue { PDL::_badvalue_int( $_[1], $_[0][0] ); } sub orig_badvalue { PDL::_default_badvalue_int($_[0][0]); } # make life a bit easier use overload ( '""' => sub { lc $_[0]->shortctype }, "eq" => sub { my ($self, $other, $swap) = @_; ("$self" eq $other); }, "cmp" => sub { my ($self, $other, $swap) = @_; $swap ? $other cmp "$self" : "$self" cmp $other; }, "<=>" => sub { $_[2] ? $_[1][0] <=> $_[0][0] : $_[0][0] <=> $_[1][0] }, ); } # package: PDL::Type # Return 1; __END__ =head1 Adding/removing types You can change the types that PDL knows about by editing entries in the definition of the variable C<@types> that appears close to the top of the file F (i.e. the file from which this module was generated). =head2 Format of a type entry Each entry in the C<@types> array is a hash reference. Here is an example taken from the actual code that defines the C type: { identifier => 'US', onecharident => 'U', # only needed if different from identifier pdlctype => 'PDL_Ushort', realctype => 'unsigned short', ppforcetype => 'ushort', usenan => 0, packtype => 'S*', defaultbadval => 'USHRT_MAX', real=>1, integer=>1, unsigned=>1, }, Before we start to explain the fields please take this important message on board: I. This is critical to ensure that PDL's type conversion works correctly. Basically, a less complex type will be converted to a more complex type as required. =head2 Fields in a type entry Each type entry has a number of required and optional entry. A list of all the entries: =over =item * identifier I. A short sequence of upercase letters that identifies this type uniquely. More than three characters is probably overkill. =item * onecharident I. Only required if the C has more than one character. This should be a unique uppercase character that will be used to reference this type in PP macro expressions of the C type. If you don't know what I am talking about read the PP manpage or ask on the mailing list. =item * pdlctype I. The C name that will be used to access this type from C code. =item * realctype I. The C compiler type that is used to implement this type. For portability reasons this one might be platform dependent. =item * ppforcetype I. The type name used in PP signatures to refer to this type. =item * usenan I. Flag that signals if this type has to deal with NaN issues. Generally only required for floating point types. =item * packtype I. The Perl pack type used to pack Perl values into the machine representation for this type. For details see C. =item * integer I. Boolean - is this an integer type? =item * unsigned I. Boolean - is this an unsigned type? =item * real I. Boolean - is this a real (not complex) type? =item * realversion String - the real version of this type (e.g. cdouble -> 'D'). =item * complexversion String - the complex version of this type (e.g. double -> 'C'). =back Also have a look at the entries at the top of F. The syntax is not written into stone yet and might change as the concept matures. =head2 Other things you need to do You need to check modules that do I/O (generally in the F part of the directory tree). In the future we might add fields to type entries to automate this. This requires changes to those IO modules first though. You should also make sure that any type macros in PP files (i.e. C<$TBSULFD...>) are updated to reflect the new type. PDL::PP::Dump has a mode to check for type macros requiring updating. Do something like find . -name \*.pd -exec perl -Mblib=. -M'PDL::PP::Dump=typecheck' {} \; from the PDL root directory I updating F to check for such places. =cut !NO!SUBS! PDL-2.074/Basic/Core/Exporter.pm0000644000175000017500000000405514165665757016204 0ustar osboxesosboxes=head1 NAME PDL::Exporter - PDL export control =head1 DESCRIPTION Implements the standard conventions for import of PDL modules in to the namespace Hopefully will be extended to allow fine control of which namespace is used. =head1 SYNOPSIS use PDL::Exporter; use PDL::MyModule; # Import default function list ':Func' use PDL::MyModule ''; # Import nothing (OO) use PDL::MyModule '...'; # Same behaviour as Exporter =head1 SUMMARY C is a drop-in replacement for the L module. It confers the standard PDL export conventions to your module. Usage is fairly straightforward and best illustrated by an example. The following shows typical usage near the top of a simple PDL module: package PDL::MyMod; use strict; # For Perl 5.6: use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); # For more modern Perls: our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); require PDL::Exporter; @ISA = qw(PDL::Exporter); @EXPORT_OK = qw(inc myfunc); # these will be exported by default %EXPORT_TAGS = (Func=>[@EXPORT_OK], Internal => [qw/internfunc1 internfunc2/], ); # ... body of your module 1; # end of simple module =cut package PDL::Exporter; use strict; use warnings; use Exporter; sub import { my $pkg = shift; return if $pkg eq 'PDL::Exporter'; # Module don't export thyself :) my $callpkg = caller($Exporter::ExportLevel); print "DBG: pkg=$pkg callpkg = $callpkg :@_\n" if($PDL::Exporter::Verbose); push @_, ':Func' unless @_; @_=() if scalar(@_)==1 and $_[0] eq ''; Exporter::export($pkg, $callpkg, @_); } 1; =head1 SEE ALSO L =head1 AUTHOR Copyright (C) Karl Glazebrook (kgb@aaoepp.aao.gov.au). Some docs by Christian Soeller. 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 PDL-2.074/Basic/Core/pdlmagic.c0000644000175000017500000003666414163225406015752 0ustar osboxesosboxes#include "pdlcore.h" /* Variable storing our the pthread ID for the main PDL thread. * This is used to tell if we are in the main pthread, or in one of * the pthreads spawned for PDL processing * This is only used when compiled with pthreads. */ #ifdef PDL_PTHREAD static pthread_t pdl_main_pthreadID; static int done_pdl_main_pthreadID_init = 0; /* deferred error messages are stored here. We can only barf/warn from the main * thread, so worker threads complain here and the complaints are printed out * altogether later */ static char* pdl_pthread_barf_msgs = NULL; static size_t pdl_pthread_barf_msgs_len = 0; static char* pdl_pthread_warn_msgs = NULL; static size_t pdl_pthread_warn_msgs_len = 0; #endif /* Singly linked list */ /* Note that this zeroes ->next!) */ void pdl__magic_add(pdl *it,pdl_magic *mag) { pdl_magic **foo = (pdl_magic **)(&(it->magic)); while(*foo) { foo = &((*foo)->next); } (*foo) = mag; mag->next = NULL; } pdl_error pdl__magic_rm(pdl *it,pdl_magic *mag) { pdl_error PDL_err = {0, NULL, 0}; pdl_magic **foo = (pdl_magic **)(&(it->magic)); int found = 0; while(*foo) { if(*foo == mag) { *foo = (*foo)->next; found = 1; } else{ foo = &((*foo)->next); } } if( !found ){ return pdl_make_error_simple(PDL_EUSERERROR, "PDL:Magic not found: Internal error\n"); } return PDL_err; } void pdl__magic_free(pdl *it) { if (pdl__ismagic(it) && !pdl__magic_isundestroyable(it)) { pdl_magic *foo = (pdl_magic *)(it->magic); while(foo) { pdl_magic *next = foo->next; free(foo); foo = next; } } } /* Test for undestroyability */ int pdl__magic_isundestroyable(pdl *it) { pdl_magic **foo = (pdl_magic **)(&(it->magic)); while(*foo) { if((*foo)->what & PDL_MAGIC_UNDESTROYABLE) {return 1;} foo = &((*foo)->next); } return 0; } /* Call magics */ void *pdl__call_magic(pdl *it,int which) { void *ret = NULL; pdl_magic **foo = (pdl_magic **)(&(it->magic)); while(*foo) { if((*foo)->what & which) { if((*foo)->what & PDL_MAGIC_DELAYED) pdl_add_delayed_magic(*foo); else ret = (void *)((*foo)->vtable->cast(*foo)); /* Cast spell */ } foo = &((*foo)->next); } return ret; } /* XXX FINDS ONLY FIRST */ pdl_magic *pdl__find_magic(pdl *it, int which) { pdl_magic **foo = (pdl_magic **)(&(it->magic)); while(*foo) { if((*foo)->what & which) { return *foo; } foo = &((*foo)->next); } return NULL; } pdl_magic *pdl__print_magic(pdl *it) { pdl_magic **foo = (pdl_magic **)(&(it->magic)); while(*foo) { printf("Magic %p\ttype: ",(void*)(*foo)); if((*foo)->what & PDL_MAGIC_MARKCHANGED) printf("PDL_MAGIC_MARKCHANGED"); else if ((*foo)->what & PDL_MAGIC_MUTATEDPARENT) printf("PDL_MAGIC_MUTATEDPARENT"); else if ((*foo)->what & PDL_MAGIC_THREADING) printf("PDL_MAGIC_THREADING"); else printf("UNKNOWN"); if ((*foo)->what & (PDL_MAGIC_DELAYED|PDL_MAGIC_UNDESTROYABLE)) { printf(" qualifier(s): "); if ((*foo)->what & PDL_MAGIC_DELAYED) printf(" PDL_MAGIC_DELAYED"); if ((*foo)->what & PDL_MAGIC_UNDESTROYABLE) printf(" PDL_MAGIC_UNDESTROYABLE"); } printf("\n"); foo = &((*foo)->next); } return NULL; } int pdl__ismagic(pdl *it) { return (it->magic != 0); } static pdl_magic **delayed=NULL; static PDL_Indx ndelayed = 0; void pdl_add_delayed_magic(pdl_magic *mag) { /* FIXME: Common realloc mistake: 'delayed' nulled but not freed upon failure */ delayed = realloc(delayed,sizeof(*delayed)*++ndelayed); delayed[ndelayed-1] = mag; } void pdl_run_delayed_magic() { PDL_Indx i; pdl_magic **oldd = delayed; /* In case someone makes new delayed stuff */ PDL_Indx nold = ndelayed; delayed = NULL; ndelayed = 0; for(i=0; ivtable->cast(oldd[i]); } free(oldd); } /**************** * * ->bind - magic */ void *svmagic_cast(pdl_magic *mag) { pdl_magic_perlfunc *magp = (pdl_magic_perlfunc *)mag; dSP; PUSHMARK(sp); perl_call_sv(magp->sv, G_DISCARD | G_NOARGS); return NULL; } static pdl_magic_vtable svmagic_vtable = { svmagic_cast, NULL }; pdl_magic *pdl_add_svmagic(pdl *it,SV *func) { AV *av; pdl_magic_perlfunc *ptr = malloc(sizeof(pdl_magic_perlfunc)); if (!ptr) return NULL; ptr->what = PDL_MAGIC_MARKCHANGED | PDL_MAGIC_DELAYED; ptr->vtable = &svmagic_vtable; ptr->sv = newSVsv(func); ptr->pdl = it; ptr->next = NULL; pdl__magic_add(it,(pdl_magic *)ptr); if(it->state & PDL_ANYCHANGED) pdl_add_delayed_magic((pdl_magic *)ptr); /* In order to have our SV destroyed in time for the interpreter, */ /* XXX Work this out not to memleak */ av = perl_get_av("PDL::disposable_svmagics",TRUE); av_push(av,ptr->sv); return (pdl_magic *)ptr; } /**************** * * ->bind - magic */ pdl_trans *pdl_find_mutatedtrans(pdl *it) { if(!it->magic) return 0; return pdl__call_magic(it,PDL_MAGIC_MUTATEDPARENT); } static void *fammutmagic_cast(pdl_magic *mag) { pdl_magic_fammut *magp = (pdl_magic_fammut *)mag; return magp->ftr; } struct pdl_magic_vtable familymutmagic_vtable = { fammutmagic_cast, NULL }; pdl_magic *pdl_add_fammutmagic(pdl *it,pdl_trans *ft) { pdl_magic_fammut *ptr = malloc(sizeof(pdl_magic_fammut)); if (!ptr) return NULL; ptr->what = PDL_MAGIC_MUTATEDPARENT; ptr->vtable = &familymutmagic_vtable; ptr->ftr = ft; ptr->pdl = it; ptr->next = NULL; pdl__magic_add(it,(pdl_magic *)ptr); return (pdl_magic *)ptr; } #ifdef PDL_PTHREAD /************** * * pthreads * */ typedef struct ptarg { pdl_magic_pthread *mag; pdl_error (*func)(pdl_trans *); pdl_trans *t; int no; pdl_error error_return; } ptarg; int pdl_pthreads_enabled(void) {return 1;} static void *pthread_perform(void *vp) { struct ptarg *p = (ptarg *)vp; PDLDEBUG_f(printf("STARTING THREAD %d (%lu)\n",p->no, (long unsigned)pthread_self())); pthread_setspecific(p->mag->key,(void *)&(p->no)); p->error_return = (p->func)(p->t); PDLDEBUG_f(printf("ENDING THREAD %d (%lu)\n",p->no, (long unsigned)pthread_self())); return NULL; } int pdl_magic_thread_nthreads(pdl *it,PDL_Indx *nthdim) { pdl_magic_pthread *ptr = (pdl_magic_pthread *)pdl__find_magic(it, PDL_MAGIC_THREADING); if(!ptr) return 0; *nthdim = ptr->nthdim; return ptr->nthreads; } int pdl_magic_get_thread(pdl *it) { pdl_magic_pthread *ptr = (pdl_magic_pthread *)pdl__find_magic(it, PDL_MAGIC_THREADING); if(!ptr) return -1; int *p = (int*)pthread_getspecific(ptr->key); if(!p) return -1; return *p; } pdl_error pdl_magic_thread_cast(pdl *it,pdl_error (*func)(pdl_trans *),pdl_trans *t, pdl_thread *thread) { pdl_error PDL_err = {0, NULL, 0}; PDL_Indx i; int clearMagic = 0; /* Flag = 1 if we are temporarily creating pthreading magic in the supplied pdl. */ pdl_magic_pthread *ptr = (pdl_magic_pthread *)pdl__find_magic(it, PDL_MAGIC_THREADING); if(!ptr) { /* Magic doesn't exist, create it Probably was deleted before the transformation performed, due to pdl lazy evaluation. */ PDL_RETERROR(PDL_err, pdl_add_threading_magic(it, thread->mag_nth, thread->mag_nthr)); clearMagic = 1; /* Set flag to delete magic later */ /* Try to get magic again */ ptr = (pdl_magic_pthread *)pdl__find_magic(it, PDL_MAGIC_THREADING); if(!ptr) {return pdl_make_error_simple(PDL_EFATAL, "Invalid pdl_magic_thread_cast!");} } pthread_t tp[thread->mag_nthr]; ptarg tparg[thread->mag_nthr]; pthread_key_create(&(ptr->key),NULL); /* Get the pthread ID of this main thread we are in. * Any barf, warn, etc calls in the spawned pthreads can use this * to tell if its a spawned pthread */ pdl_main_pthreadID = pthread_self(); done_pdl_main_pthreadID_init = 1; PDLDEBUG_f(printf("CREATING THREADS, ME: TBD, key: %ld\n", (unsigned long)(ptr->key))); for(i=0; imag_nthr; i++) { tparg[i].mag = ptr; tparg[i].func = func; tparg[i].t = t; tparg[i].no = i; tparg[i].error_return = PDL_err; if (pthread_create(tp+i, NULL, pthread_perform, tparg+i)) { return pdl_make_error_simple(PDL_EFATAL, "Unable to create pthreads!"); } } PDLDEBUG_f(printf("JOINING THREADS, ME: TBD, key: %ld\n", (unsigned long)(ptr->key))); for(i=0; imag_nthr; i++) { pthread_join(tp[i], NULL); } PDLDEBUG_f(printf("FINISHED THREADS, ME: TBD, key: %ld\n", (unsigned long)(ptr->key))); pthread_key_delete((ptr->key)); done_pdl_main_pthreadID_init = 0; /* Remove pthread magic if we created in this function */ if( clearMagic ){ PDL_RETERROR(PDL_err, pdl_add_threading_magic(it, -1, -1)); } #define handle_deferred_errors(type, action) \ do{ \ if(pdl_pthread_##type##_msgs_len != 0) \ { \ pdl_pthread_##type##_msgs_len = 0; \ action; \ free(pdl_pthread_##type##_msgs); \ pdl_pthread_##type##_msgs = NULL; \ } \ } while(0) handle_deferred_errors(warn, pdl_pdl_warn("%s", pdl_pthread_warn_msgs)); handle_deferred_errors(barf, PDL_err = pdl_error_accumulate(PDL_err, pdl_make_error(PDL_EFATAL, "%s", pdl_pthread_barf_msgs))); for(i=0; imag_nthr; i++) { PDL_err = pdl_error_accumulate(PDL_err, tparg[i].error_return); } return PDL_err; } /* Function to remove threading magic (added by pdl_add_threading_magic) */ pdl_error pdl_rm_threading_magic(pdl *it) { pdl_error PDL_err = {0, NULL, 0}; pdl_magic_pthread *ptr = (pdl_magic_pthread *)pdl__find_magic(it, PDL_MAGIC_THREADING); /* Don't do anything if threading magic not found */ if( !ptr) return PDL_err; /* Remove magic */ PDL_RETERROR(PDL_err, pdl__magic_rm(it, (pdl_magic *) ptr)); /* Free magic */ free( ptr ); return PDL_err; } /* Function to add threading magic (i.e. identify which PDL dimension should be pthreaded and how many pthreads to create Note: If nthdim and nthreads = -1 then any pthreading magic is removed */ pdl_error pdl_add_threading_magic(pdl *it,PDL_Indx nthdim,PDL_Indx nthreads) { pdl_error PDL_err = {0, NULL, 0}; pdl_magic_pthread *ptr; /* Remove threading magic if called with parms -1, -1 */ if( (nthdim == -1) && ( nthreads == -1 ) ){ PDL_RETERROR(PDL_err, pdl_rm_threading_magic(it)); return PDL_err; } ptr = malloc(sizeof(pdl_magic_pthread)); if (!ptr) return pdl_make_error_simple(PDL_EFATAL, "Out of memory"); ptr->what = PDL_MAGIC_THREADING; ptr->vtable = NULL; ptr->next = NULL; ptr->nthdim = nthdim; ptr->nthreads = nthreads; pdl__magic_add(it,(pdl_magic *)ptr); return PDL_err; } char pdl_pthread_main_thread() { return !done_pdl_main_pthreadID_init || pthread_equal( pdl_main_pthreadID, pthread_self() ); } // Barf/warn function for deferred barf message handling during pthreading We // can't barf/warn during pthreading, because perl-level code isn't // threadsafe. This routine does nothing if we're in the main thread (allowing // the caller to barf normally, since there are not threading issues then). If // we're in a worker thread, this routine stores the message for main-thread // reporting later int pdl_pthread_barf_or_warn(const char* pat, int iswarn, va_list *args) { char** msgs; size_t* len; /* Don't do anything if we are in the main pthread */ if (pdl_pthread_main_thread()) return 0; if(iswarn) { msgs = &pdl_pthread_warn_msgs; len = &pdl_pthread_warn_msgs_len; } else { msgs = &pdl_pthread_barf_msgs; len = &pdl_pthread_barf_msgs_len; } size_t extralen = vsnprintf(NULL, 0, pat, *args); // add the new complaint to the list pdl_pthread_realloc_vsnprintf(msgs, len, extralen, pat, args, 1); if(iswarn) { /* Return 1, indicating we have handled the warn messages */ return(1); } /* Exit the current pthread. Since this was a barf call, and we should be halting execution */ pthread_exit(NULL); return 0; } void pdl_pthread_realloc_vsnprintf(char **p, size_t *len, size_t extralen, const char *pat, va_list *args, char add_newline) { static pthread_mutex_t mutex = PTHREAD_MUTEX_INITIALIZER; pthread_mutex_lock( &mutex ); /* (For windows, we first #undef realloc so that the system realloc function is used instead of the PerlMem_realloc macro. This currently works fine, though could conceivably require some tweaking in the future if it's found to cause any problem.) */ #ifdef WIN32 #undef realloc #endif /* FIXME: Common realloc mistake: 'msgs' nulled but not freed upon failure */ if (add_newline) extralen += 1; *p = realloc(*p, *len + extralen + 1); /* +1 for '\0' at end */ vsnprintf(*p + *len, extralen + 1, pat, *args); /* update the length-so-far. This does NOT include the trailing '\0' */ *len += extralen; if (add_newline)(*p)[*len] = '\n'; (*p)[*len+1] = '\0'; pthread_mutex_unlock( &mutex ); } void pdl_pthread_free(void *p) { #ifdef WIN32 /* same reasons as above */ #undef free #endif static pthread_mutex_t mutex = PTHREAD_MUTEX_INITIALIZER; pthread_mutex_lock( &mutex ); free(p); pthread_mutex_unlock( &mutex ); } /* copied from git@github.com:git/git.git 2.34-ish thread-util.c */ /* changed GIT_WINDOWS_NATIVE to WIN32 */ #if defined(hpux) || defined(__hpux) || defined(_hpux) # include #endif /* * By doing this in two steps we can at least get * the function to be somewhat coherent, even * with this disgusting nest of #ifdefs. */ #ifndef _SC_NPROCESSORS_ONLN # ifdef _SC_NPROC_ONLN # define _SC_NPROCESSORS_ONLN _SC_NPROC_ONLN # elif defined _SC_CRAY_NCPU # define _SC_NPROCESSORS_ONLN _SC_CRAY_NCPU # endif #endif int pdl_online_cpus(void) { #ifdef WIN32 SYSTEM_INFO info; GetSystemInfo(&info); if ((int)info.dwNumberOfProcessors > 0) return (int)info.dwNumberOfProcessors; #elif defined(hpux) || defined(__hpux) || defined(_hpux) struct pst_dynamic psd; if (!pstat_getdynamic(&psd, sizeof(psd), (size_t)1, 0)) return (int)psd.psd_proc_cnt; #elif defined(HAVE_BSD_SYSCTL) && defined(HW_NCPU) int mib[2]; size_t len; int cpucount; mib[0] = CTL_HW; # ifdef HW_AVAILCPU mib[1] = HW_AVAILCPU; len = sizeof(cpucount); if (!sysctl(mib, 2, &cpucount, &len, NULL, 0)) return cpucount; # endif /* HW_AVAILCPU */ mib[1] = HW_NCPU; len = sizeof(cpucount); if (!sysctl(mib, 2, &cpucount, &len, NULL, 0)) return cpucount; #endif /* defined(HAVE_BSD_SYSCTL) && defined(HW_NCPU) */ #ifdef _SC_NPROCESSORS_ONLN long ncpus; if ((ncpus = (long)sysconf(_SC_NPROCESSORS_ONLN)) > 0) return (int)ncpus; #endif return 1; } #else /* Dummy versions */ pdl_error pdl_add_threading_magic(pdl *it,PDL_Indx nthdim,PDL_Indx nthreads) {pdl_error PDL_err = {0,NULL,0}; return PDL_err;} char pdl_pthread_main_thread() { return 1; } int pdl_magic_get_thread(pdl *it) {return 0;} pdl_error pdl_magic_thread_cast(pdl *it,pdl_error (*func)(pdl_trans *),pdl_trans *t, pdl_thread *thread) {pdl_error PDL_err = {0,NULL,0}; return PDL_err;} int pdl_magic_thread_nthreads(pdl *it,PDL_Indx *nthdim) {return 0;} int pdl_pthreads_enabled() {return 0;} int pdl_pthread_barf_or_warn(const char* pat, int iswarn, va_list *args){ return 0;} int pdl_online_cpus() {return 1;} #endif /*************************** * * Delete magic * */ static void *delete_mmapped_cast(pdl_magic *mag) { pdl_magic_deletedata *magp = (pdl_magic_deletedata *)mag; magp->func(magp->pdl, magp->param); return NULL; } struct pdl_magic_vtable deletedatamagic_vtable = { delete_mmapped_cast, NULL }; pdl_error pdl_add_deletedata_magic(pdl *it, void (*func)(pdl *, Size_t param), Size_t param) { pdl_error PDL_err = {0, NULL, 0}; pdl_magic_deletedata *ptr = malloc(sizeof(pdl_magic_deletedata)); if (!ptr) return pdl_make_error_simple(PDL_EFATAL, "Out of memory"); ptr->what = PDL_MAGIC_DELETEDATA; ptr->vtable = &deletedatamagic_vtable; ptr->pdl = it; ptr->func = func; ptr->param = param; pdl__magic_add(it, (pdl_magic *)ptr); return PDL_err; } PDL-2.074/Basic/Core/Dev.pm0000644000175000017500000003761514172737500015102 0ustar osboxesosboxes=head1 NAME PDL::Core::Dev - PDL development module =head1 DESCRIPTION This module encapsulates most of the stuff useful for PDL development and is often used from within Makefile.PL's. =head1 SYNOPSIS use PDL::Core::Dev; =head1 FUNCTIONS =cut # Stuff used in development/install environment of PDL Makefile.PL's # - not part of PDL itself. package PDL::Core::Dev; use strict; use warnings; use File::Path; use File::Basename; use ExtUtils::Manifest; require Exporter; use Config; eval { require Devel::CheckLib }; our @ISA = qw( Exporter ); our @EXPORT = qw( isbigendian PDL_INCLUDE PDL_TYPEMAP PDL_AUTO_INCLUDE PDL_BOOT PDL_INST_INCLUDE PDL_INST_TYPEMAP pdlpp_postamble_int pdlpp_stdargs_int pdlpp_postamble pdlpp_stdargs write_dummy_make unsupported getcyglib trylink pdlpp_mkgen got_complex_version ); # Installation locations # beware: whereami_any now appends the /Basic or /PDL directory as appropriate # Return library locations sub PDL_INCLUDE { '"-I'.whereami_any().'/Core"' }; sub PDL_TYPEMAP { whereami_any().'/Core/typemap' }; # The INST are here still just in case we want to change something later. *PDL_INST_INCLUDE = \&PDL_INCLUDE; *PDL_INST_TYPEMAP = \&PDL_TYPEMAP; sub PDL_AUTO_INCLUDE { my ($symname) = @_; $symname ||= 'PDL'; return << "EOR"; #include static Core* $symname; /* Structure holds core C functions */ static SV* CoreSV; /* Gets pointer to perl var holding core structure */ EOR } sub PDL_BOOT { my ($symname, $module) = @_; $symname ||= 'PDL'; $module ||= 'The code'; return << "EOR"; perl_require_pv ("PDL/Core.pm"); /* make sure PDL::Core is loaded */ #ifndef aTHX_ #define aTHX_ #endif if (SvTRUE (ERRSV)) Perl_croak(aTHX_ "%s",SvPV_nolen (ERRSV)); if (!(CoreSV = perl_get_sv("PDL::SHARE",FALSE))) /* SV* value */ Perl_croak(aTHX_ "We require the PDL::Core module, which was not found"); if (!($symname = INT2PTR(Core*,SvIV( CoreSV )))) /* Core* value */ Perl_croak(aTHX_ "Got NULL pointer for $symname"); if ($symname->Version != PDL_CORE_VERSION) Perl_croak(aTHX_ "[$symname->Version: \%ld PDL_CORE_VERSION: \%ld XS_VERSION: \%s] $module needs to be recompiled against the newly installed PDL", (long int)$symname->Version, (long int)PDL_CORE_VERSION, XS_VERSION); EOR } use Cwd qw/abs_path/; my $MY_FILE = abs_path(__FILE__); # capture at load-time because EUMM chdirs my $MY_DIR2 = dirname(dirname($MY_FILE)); my $IS_INST = $MY_DIR2 =~ /PDL\W*$/i; sub whereami_any { $MY_DIR2 } # something containing "Core/Dev.pm" # To access PDL's configuration use %PDL::Config. Makefile.PL has been set up # to create this variable so it is available during 'perl Makefile.PL' and # it can be eval-ed during 'make' unless ( %PDL::Config ) { require File::Spec::Functions; my $dir = File::Spec::Functions::catdir($MY_DIR2, $IS_INST ? () : qw(Core)); eval { require "$dir/Config.pm" }; die "Unable to find PDL's configuration info\n [$@]" if $@; } my $inc = $PDL::Config{MALLOCDBG}{include} || ''; my $libs = $PDL::Config{MALLOCDBG}{libs} || ''; =head2 isbigendian =for ref Is the machine big or little endian? =for example print "Your machins is big endian.\n" if isbigendian(); returns 1 if the machine is big endian, 0 if little endian, or dies if neither. It uses the C element of perl's C<%Config> array. =for usage my $retval = isbigendian(); =cut # ' emacs parsing dummy # big/little endian? sub isbigendian { use Config; my $byteorder = $Config{byteorder} || die "ERROR: Unable to find 'byteorder' in perl's Config\n"; return 1 if $byteorder eq "4321"; return 1 if $byteorder eq "87654321"; return 0 if $byteorder eq "1234"; return 0 if $byteorder eq "12345678"; die "ERROR: PDL does not understand your machine's byteorder ($byteorder)\n"; } sub _oneliner { my ($cmd, @flags) = @_; require ExtUtils::MM; my $MM = bless { NAME => 'Fake' }, 'MM'; $MM->oneliner($cmd, \@flags); } # Expects list in format: # [gtest.pd, GTest, PDL::GTest[, PDL::XSPkg] ], [...] # source, prefix,module/package, optional pp_addxs destination # The idea is to support in future several packages in same dir - EUMM # 7.06 supports sub _pp_call_arg { "-MPDL::PP=".join ',', @_ } sub _postamble { my ($w, $internal, $src, $pref, $mod, $callpack, $multi_c) = @_; $callpack //= ''; $w = dirname($w); my ($perlrun, $pmdep, $install, $cdep) = ($internal ? '$(PERLRUNINST)' : "\$(PERL) \"-I$w\"", $src, '', ''); if ($internal) { require File::Spec::Functions; my $top = File::Spec::Functions::abs2rel($w); my $core = File::Spec::Functions::catdir($top, qw(Basic Core)); $pmdep .= join ' ', '', File::Spec::Functions::catfile($top, qw(Basic Gen pm_to_blib)), File::Spec::Functions::catfile($core, qw(pm_to_blib)), ; $cdep .= join ' ', map File::Spec::Functions::catfile($core, $_), qw(pdl.h pdlcore.h pdlthread.h pdlmagic.h); } else { my $oneliner = _oneliner(qq{exit if \$ENV{DESTDIR}; use PDL::Doc; eval { PDL::Doc::add_module(q{$mod}); }}); $install = qq|\ninstall ::\n\t\@echo "Updating PDL documentation database...";\n\t$oneliner\n|; } my @generanda = "$pref.xs"; my @cbase = $multi_c ? map "pp-$_", _pp_list_functions($src, $internal) : (); push @generanda, map "$_.c", @cbase; my @objs = map "$_\$(OBJ_EXT)", $pref, @cbase; my $pp_call_arg = _pp_call_arg($mod, $mod, $pref, $callpack, $multi_c||''); qq| $pref.pm : $pmdep $perlrun \"$pp_call_arg\" $src \$(TOUCH) $pref.pm @generanda : $pref.pm \$(NOECHO) \$(NOOP) @objs : $cdep $install| } sub pdlpp_postamble_int { my $w = whereami_any(); join '', map _postamble($w, 1, @$_[0..3], 1), @_; } # This is the function to be used outside the PDL tree. # same format as pdlpp_postamble_int sub pdlpp_postamble { my $w = whereami_any(); join '', map _postamble($w, 0, @$_), @_; } my %flist_cache; sub _pp_list_functions { require File::Spec::Functions; my ($src, $internal) = @_; my $abs_src = File::Spec::Functions::rel2abs($src); if (!$flist_cache{$abs_src}) { my $w = whereami_any(); my $typespm = File::Spec::Functions::catfile($w, $internal ? qw(Core) : (), qw(Types.pm)); system $^X, "$typespm.PL", $typespm if $internal and !-f $typespm; require $typespm; local $INC{'PDL/Types.pm'} = 1; require ''.File::Spec::Functions::catfile($w, $internal ? qw(Gen) : (), qw(PP.pm)); $flist_cache{$abs_src} = [ PDL::PP::list_functions($src) ]; } @{ $flist_cache{$abs_src} }; } sub _stdargs { my ($w, $internal, $src, $pref, $mod, $callpack, $multi_c) = @_; my @cbase = $pref; push @cbase, map "pp-$_", _pp_list_functions($src, $internal) if $multi_c; my @cfiles = ("$pref.xs", map "$_.c", @cbase); my @objs = map "$_\$(OBJ_EXT)", @cbase; ( NAME => $mod, VERSION_FROM => ($internal ? "$w/Basic/PDL.pm" : $src), TYPEMAPS => [PDL_TYPEMAP()], OBJECT => join(' ', @objs), PM => {"$pref.pm" => "\$(INST_LIBDIR)/$pref.pm"}, MAN3PODS => {"$pref.pm" => "\$(INST_MAN3DIR)/$mod.\$(MAN3EXT)"}, INC => PDL_INCLUDE()." $inc", LIBS => [$libs], clean => {FILES => "$pref.pm @cfiles"}, ($internal ? (NO_MYMETA => 1) : (dist => {PREOP => '$(PERLRUNINST) -MPDL::Core::Dev -e pdlpp_mkgen $(DISTVNAME)' }) ), ); } sub pdlpp_stdargs_int { _stdargs(dirname($MY_DIR2), 1, @{$_[0]}[0..3], 1); } sub pdlpp_stdargs { _stdargs(undef, 0, @{$_[0]}); } # pdlpp_mkgen($dir) # - scans $dir/MANIFEST for all *.pd files and creates corresponding *.pm files # in $dir/GENERATED/ subdir; needed for proper doc rendering at metacpan.org # - it is used in Makefile.PL like: # dist => { PREOP=>'$(PERL) -MPDL::Core::Dev -e pdlpp_mkgen $(DISTVNAME)' } # so all the magic *.pm generation happens during "make dist" # - it is intended to be called as a one-liner: # perl -MPDL::Core::Dev -e pdlpp_mkgen DirName # sub pdlpp_mkgen { require File::Spec::Functions; require File::Copy; my $dir = @_ > 0 ? $_[0] : $ARGV[0]; die "pdlpp_mkgen: unspecified directory" unless defined $dir && -d $dir; my $file = "$dir/MANIFEST"; die "pdlpp_mkgen: non-existing '$file\'" unless -f $file; my @pairs = (); my $manifest = ExtUtils::Manifest::maniread($file); for (grep !/^(t|xt)\// && /\.pd$/ && -f, sort keys %$manifest) { my $content = do { local $/; open my $in, '<', $_; <$in> }; warn("pdlpp_mkgen: unknown module name for '$_' (use proper '=head1 NAME' section)\n"), next if !(my ($name) = $content =~ /=head1\s+NAME\s+(\S+)\s+/sg); push @pairs, [$_, $name]; } my %added = (); my @in = map "-I".File::Spec::Functions::rel2abs($_), @INC, 'inc'; for (@pairs) { my ($pd, $mod) = @$_; (my $prefix = $mod) =~ s|::|/|g; my $basename = (split '/', $prefix)[-1]; my $basefile = "$basename.pm"; my $outfile = File::Spec::Functions::rel2abs("$dir/GENERATED/$prefix.pm"); File::Path::mkpath(dirname($outfile)); my $old_cwd = Cwd::cwd(); chdir dirname($pd); #there is no way to use PDL::PP from perl code, thus calling via system() my $pp_call_arg = _pp_call_arg($mod, $mod, $basename, '', 1); my $rv = system($^X, @in, $pp_call_arg, File::Spec::Functions::abs2rel(basename($pd))); die "pdlpp_mkgen: cannot convert '$pd'\n" unless $rv == 0 && -f $basefile; File::Copy::copy($basefile, $outfile) or die "$outfile: $!"; chdir $old_cwd or die "chdir $old_cwd: $!"; $added{"GENERATED/$prefix.pm"} = "mod=$mod pd=$pd (added by pdlpp_mkgen)"; } if (scalar(keys %added) > 0) { #maniadd works only with this global variable local $ExtUtils::Manifest::MANIFEST = $file; ExtUtils::Manifest::maniadd(\%added); } } sub unsupported { my ($package,$os) = @_; "No support for $package on $os platform yet. Will skip build process"; } sub write_dummy_make { my ($msg) = @_; $msg =~ s#\n*\z#\n#; $msg =~ s#^\s*#\n#gm; print $msg; require ExtUtils::MakeMaker; ExtUtils::MakeMaker::WriteEmptyMakefile(NAME => 'Dummy', DIR => []); } sub getcyglib { my ($lib) = @_; my $lp = `gcc -print-file-name=lib$lib.a`; $lp =~ s|/[^/]+$||; $lp =~ s|^([a-z,A-Z]):|//$1|g; return "-L$lp -l$lib"; } =head2 trylink =for ref a perl configure clone =for example if (trylink 'libGL', '', 'char glBegin(); glBegin();', '-lGL') { $libs = '-lGLU -lGL'; $have_GL = 1; } else { $have_GL = 0; } $maybe = trylink 'libwhatever', $inc, $body, $libs, $cflags, {MakeMaker=>1, Hide=>0, Clean=>1}; Try to link some C-code making up the body of a function with a given set of library specifiers return 1 if successful, 0 otherwise =for usage trylink $infomsg, $include, $progbody, $libs [,$cflags,{OPTIONS}]; Takes 4 + 2 optional arguments. =over 5 =item * an informational message to print (can be empty) =item * any commands to be included at the top of the generated C program (typically something like C<#include "mylib.h">) =item * the body of the program (in function main) =item * library flags to use for linking. Preprocessing by MakeMaker should be performed as needed (see options and example). =item * compilation flags. For example, something like C<-I/usr/local/lib>. Optional argument. Empty if omitted. =item * OPTIONS =over =item MakeMaker Preprocess library strings in the way MakeMaker does things. This is advisable to ensure that your code will actually work after the link specs have been processed by MakeMaker. =item Hide Controls if linking output etc is hidden from the user or not. On by default except within the build of the PDL distribution where the config value set in F prevails. =item Clean Remove temporary files. Enabled by default. You might want to switch it off during debugging. =back =back =cut sub trylink { my $opt = ref $_[$#_] eq 'HASH' ? pop : {}; my ($txt,$inc,$body,$libs,$cflags) = @_; $cflags ||= ''; require File::Spec; require File::Temp; my $cdir = sub { return File::Spec->catdir(@_)}; my $cfile = sub { return File::Spec->catfile(@_)}; use Config; # check if MakeMaker should be used to preprocess the libs for my $key(keys %$opt) {$opt->{lc $key} = $opt->{$key}} my $mmprocess = exists $opt->{makemaker} && $opt->{makemaker}; my $hide = exists $opt->{hide} ? $opt->{hide} : exists $PDL::Config{HIDE_TRYLINK} ? $PDL::Config{HIDE_TRYLINK} : 1; my $clean = exists $opt->{clean} ? $opt->{clean} : 1; if ($mmprocess) { require ExtUtils::MakeMaker; require ExtUtils::Liblist; my $self = new ExtUtils::MakeMaker {DIR => [],'NAME' => 'NONE'}; my @libs = $self->ext($libs, 0); print "processed LIBS: $libs[0]\n" unless $hide; $libs = $libs[0]; # replace by preprocessed libs } print " Trying $txt...\n " unless $txt =~ /^\s*$/; my $HIDE = !$hide ? '' : '>/dev/null 2>&1'; if($^O =~ /mswin32/i) {$HIDE = '>NUL 2>&1'} my $tempd = File::Temp::tempdir(CLEANUP=>1) || die "trylink: could not make temp dir"; my ($tc,$te) = map {&$cfile($tempd,"testfile$_")} ('.c',''); open FILE,">$tc" or die "trylink: couldn't open testfile `$tc' for writing, $!"; my $prog = <<"EOF"; $inc int main(void) { $body return 0; } EOF print FILE $prog; close FILE; # print "test prog:\n$prog\n"; # make sure we can overwrite the executable. shouldn't need this, # but if it fails and HIDE is on, the user will never see the error. open(T, ">$te") or die( "unable to write to test executable `$te'"); close T; print "$Config{cc} $cflags -o $te $tc $libs $HIDE ...\n" unless $hide; my $success = (system("$Config{cc} $cflags -o $te $tc $libs $HIDE") == 0) && -e $te ? 1 : 0; unlink "$te","$tc" if $clean; print $success ? "\t\tYES\n" : "\t\tNO\n" unless $txt =~ /^\s*$/; print $success ? "\t\tSUCCESS\n" : "\t\tFAILED\n" if $txt =~ /^\s*$/ && !$hide; return $success; } =head2 generate_core_flags =for ref prints on C XS text with core flags, for F. =cut my %flags = ( hdrcpy => { set => 1 }, fflows => { FLAG => "DATAFLOW_F" }, bflows => { FLAG => "DATAFLOW_B" }, is_inplace => { FLAG => "INPLACE", postset => 1 }, donttouch => { FLAG => "DONTTOUCHDATA" }, allocated => { }, vaffine => { FLAG => "OPT_VAFFTRANSOK" }, anychgd => { FLAG => "ANYCHANGED" }, dimschgd => { FLAG => "PARENTDIMSCHANGED" }, tracedebug => { set => 1}, ); sub generate_core_flags { # access (read, if set is true then write as well; if postset true then # read first and write new value after that) # to ndarray's state foreach my $name ( sort keys %flags ) { my $flag = "PDL_" . ($flags{$name}{FLAG} || uc($name)); my $with_mode = $flags{$name}{set} || $flags{$name}{postset}; printf <<'EOF', $name, ($with_mode ? ",mode=0" : ''), ($with_mode ? " int mode\n" : ''); int %s(x%s) pdl *x %s CODE: EOF my $set = " if (items>1) setflag(x->state,$flag,mode);\n"; my $ret = " RETVAL = ((x->state & $flag) > 0);\n"; print $set if $flags{$name}{set}; print $ret; print $set if $flags{$name}{postset}; print " OUTPUT:\n RETVAL\n\n"; } # foreach: keys %flags } =head2 got_complex_version =for ref PDL::Core::Dev::got_complex_version($func_name, $num_params) For a given function appearing in C99's C, will return a boolean of whether the system being compiled on has the complex version of that. E.g. for C, will test whether C exists (before 2.069, would only check for C, causing build failures on non-C99 compliant C which mandates long-double versions). =cut my %got_complex_cache; sub got_complex_version { my ($name, $params) = @_; return $got_complex_cache{$name} if defined $got_complex_cache{$name}; my $args = join ',', ('(double complex)1') x $params; $got_complex_cache{$name} = Devel::CheckLib::check_lib( ($Config{gccversion} ? (ccflags => '-O0') : ()), # stop GCC optimising test code away lib => 'm', header => 'complex.h', function => sprintf('double num; num = creal(c%sl(%s)); return 0;', $name, $args), ); } 1; PDL-2.074/Basic/Core/pdlthread.h0000644000175000017500000000510514200134111016110 0ustar osboxesosboxes#ifndef __PDLTHREAD_H #define __PDLTHREAD_H #define PDL_THREAD_MAGICKED 0x0001 #define PDL_THREAD_MAGICK_BUSY 0x0002 #define PDL_THREAD_INITIALIZED 0x0004 #define PDL_LIST_FLAGS_PDLTHREAD(X) \ X(PDL_THREAD_MAGICKED) \ X(PDL_THREAD_MAGICK_BUSY) \ X(PDL_THREAD_INITIALIZED) #define PDL_THR_MAGICNO 0x92314764 #define PDL_THR_SETMAGIC(it) it->magicno = PDL_THR_MAGICNO #define PDL_THR_CLRMAGIC(it) (it)->magicno = PDL_CLEARED_MAGICNO /* XXX To avoid mallocs, these should also have "default" values */ typedef struct pdl_thread { struct pdl_transvtable *transvtable; unsigned int magicno; int gflags; /* Flags about this struct */ PDL_Indx ndims; /* Number of dimensions threaded over */ PDL_Indx nimpl; /* Number of these that are implicit */ PDL_Indx npdls; /* Number of pdls involved */ PDL_Indx nextra; PDL_Indx *inds; /* Indices for each of the dimensions */ PDL_Indx *dims; /* Dimensions of each dimension */ PDL_Indx *offs; /* Offsets for each of the pdls */ PDL_Indx *incs; /* npdls * ndims array of increments. Fast because of constant indices for first loops */ PDL_Indx *realdims; /* realdims for each pdl (e.g., specified by PP signature) */ pdl **pdls; char *flags; /* per pdl flags */ PDL_Indx mag_nth; /* magicked thread dim */ PDL_Indx mag_nthpdl; /* magicked ndarray */ PDL_Indx mag_nthr; /* number of threads */ PDL_Indx mag_skip; /* first pthread to skip if remainder, 0=none */ PDL_Indx mag_stride; /* the base size to stride, without adding 1 if before drop */ /* ** t**** **** **** --k--->thr (zero-based) t=3 (mag_stride) k=2 (mag_skip) offsets=[0,4,8,11,14] t**** **** **** k----->thr (zero-based) t=3 (mag_stride) k=0 (mag_skip) offsets=[0,3,6,9,12] offset=thr*t + MIN(thr,k) // see macro PDL_THR_OFFSET */ } pdl_thread; #define PDL_THR_OFFSET(thr, thread) ((thr)*((thread)->mag_stride) + PDLMIN((thr),(thread)->mag_skip)) #define PDL_THR_INC(incs, npdls, p, d) ((incs)[(d)*(npdls) + (p)]) /* Thread per pdl flags */ #define PDL_THREAD_VAFFINE_OK 0x01 #define PDL_THREAD_TEMP 0x02 #define PDL_TVAFFOK(flag) (flag & PDL_THREAD_VAFFINE_OK) #define PDL_TISTEMP(flag) (flag & PDL_THREAD_TEMP) #define PDL_TREPRINC(pdl,flag,which) (PDL_TVAFFOK(flag) ? \ pdl->vafftrans->incs[which] : pdl->dimincs[which]) #define PDL_TREPROFFS(pdl,flag) (PDL_TVAFFOK(flag) ? pdl->vafftrans->offs : 0) /* __PDLTHREAD_H */ #endif PDL-2.074/Basic/Core/pdlmagic.h0000644000175000017500000000710314160714722015742 0ustar osboxesosboxes#ifndef _pdlmagic_H_ #define _pdlmagic_H_ #define PDL_ISMAGIC(it) ((it)->magic != 0) /* Magic stuff */ struct pdl_magic; /* If no copy, not copied with the pdl */ typedef struct pdl_magic_vtable { void *(*cast)(struct pdl_magic *); /* Cast the spell */ struct pdl_magic *(*copy)(struct pdl_magic *); /* void *(*cast_tr)(struct pdl_magic *,XXX); * int (*nth_tr)(struct pdl_magic *,XXX); */ } pdl_magic_vtable; #define PDL_MAGIC_MARKCHANGED 0x0001 #define PDL_MAGIC_MUTATEDPARENT 0x0002 #define PDL_MAGIC_THREADING 0x0004 #define PDL_MAGIC_DELETEDATA 0x0008 #define PDL_MAGIC_UNDESTROYABLE 0x4000 /* Someone is referring to this */ /* when magic removed, call pdl_destroy */ #define PDL_MAGIC_DELAYED 0x8000 #define PDL_MAGICSTART \ int what; /* when is this magic to be called */ \ pdl_magic_vtable *vtable; \ struct pdl_magic *next; \ pdl *pdl #define PDL_TRMAGICSTART \ int what; /* when is this magic to be called */ \ pdl_magic_vtable *vtable; \ struct pdl_magic *next; \ pdl_trans *tr typedef struct pdl_magic { PDL_MAGICSTART; } pdl_magic; typedef struct pdl_magic_perlfunc { PDL_MAGICSTART; SV *sv; /* sub{} or subname (perl_call_sv) */ } pdl_magic_perlfunc; typedef struct pdl_magic_fammut { PDL_MAGICSTART; pdl_trans *ftr; } pdl_magic_fammut; typedef struct pdl_magic_changetrans { PDL_MAGICSTART; pdl_trans *tr; } pdl_magic_changetrans; typedef struct pdl_magic_deletedata { PDL_MAGICSTART; void (*func)(pdl *p, Size_t param); Size_t param; } pdl_magic_deletedata; #ifdef PDL_PTHREAD /* This is a workaround to a perl CORE "feature" where they define a * macro PTHREAD_CREATE_JOINABLE with the same name as POSIX threads * which works as long as the implementation of POSIX threads also * uses macros. As is, the use of the same name space breaks for * win32 pthreads where the identifiers are enums and not #defines */ #ifdef PTHREAD_CREATE_JOINABLE #undef PTHREAD_CREATE_JOINABLE #endif #include typedef struct pdl_magic_pthread { PDL_MAGICSTART; PDL_Indx nthdim; PDL_Indx nthreads; pthread_key_t key; } pdl_magic_pthread; #endif /* - tr magics */ typedef struct pdl_trmagic { PDL_TRMAGICSTART; } pdl_trmagic; typedef struct pdl_trmagic_family { PDL_TRMAGICSTART; pdl *fprog,*tprog; pdl *fmut,*tmut; } pdl_trmagic_family; /* __ = Don't call from outside pdl if you don't know what you're doing */ void pdl__magic_add(pdl *,pdl_magic *); pdl_error pdl__magic_rm(pdl *,pdl_magic *); void pdl__magic_free(pdl *); int pdl__magic_isundestroyable(pdl *); void *pdl__call_magic(pdl *,int which); int pdl__ismagic(pdl *); pdl_magic *pdl__print_magic(pdl *it); pdl_magic *pdl_add_svmagic(pdl *,SV *); /* A kind of "dowhenidle" system */ void pdl_add_delayed_magic(pdl_magic *); void pdl_run_delayed_magic(); pdl_trans *pdl_find_mutatedtrans(pdl *it); /* Threading magic */ /* Deferred barfing and warning when pthreading */ char pdl_pthread_main_thread(); int pdl_pthread_barf_or_warn(const char* pat, int iswarn, va_list *args); void pdl_pthread_realloc_vsnprintf(char **p, size_t *len, size_t extralen, const char *pat, va_list *args, char add_newline); void pdl_pthread_free(void *p); pdl_error pdl_add_threading_magic(pdl *,PDL_Indx nthdim, PDL_Indx nthreads); int pdl_magic_thread_nthreads(pdl *,PDL_Indx *nthdim); int pdl_magic_get_thread(pdl *); pdl_error pdl_magic_thread_cast(pdl *,pdl_error (*func)(pdl_trans *),pdl_trans *t, pdl_thread *thread); int pdl_pthreads_enabled(void); /* Delete data magic */ pdl_error pdl_add_deletedata_magic(pdl *it,void (*func)(pdl *, Size_t param), Size_t param); #endif /* _pdlmagic_H_ */ PDL-2.074/Basic/Core/pdlsimple.h.PL0000644000175000017500000000513314167116774016500 0ustar osboxesosboxesuse Config; use File::Basename qw(&basename &dirname); require './Types.pm'; # List explicitly here the variables you want Configure to # generate. Metaconfig only looks for shell variables, so you # have to mention them as if they were shell variables, not # %Config entries. Thus you write # $startperl # to ensure Configure will look for $Config{startperl}. # This forces PL files to create target in same directory as PL file. # This is so that make depend always knows where to find PL derivatives. chdir(dirname($0)); my $file; ($file = basename($0)) =~ s/\.PL$//; $file =~ s/\.pl$// if ($Config{'osname'} eq 'VMS' or $Config{'osname'} eq 'OS2'); # "case-forgiving" open OUT,">$file" or die "Can't create $file: $!"; print "Extracting $file (with variable substitutions)\n"; # In this section, perl variables will be expanded during extraction. # You can use $Config{...} to use Configure variables. print OUT sprintf qq{#line %d "%s"\n}, __LINE__ + 2, __FILE__; print OUT <<'EOF'; #include #include #include #ifndef __PDL_H /* These are kept automatically in sync with pdl.h during perl build */ EOF my @methods = qw(symbol ctype ppsym shortctype defbval realctype); sub makeg { map { my $t = $_; [map $t->$_, @methods] } grep $_[0]->($_), PDL::Types::types() } sub makelister { my ($name, $is2, $underscore, @list) = @_; my $suff = $is2 ? '2' : ''; my $arg1 = $is2 ? 'X, X2' : 'X'; my $arg2 = $is2 ? 'X2, ' : ''; $underscore = $underscore ? '_' : ''; ("#define PDL_TYPELIST${suff}_$name$underscore($arg1) \\\n", (map " X($arg2".join(',', @$_).")\\\n", @list), "\n\n"); } my @generics = makeg(sub {1}); print OUT makelister('ALL', 0, 0, @generics); print OUT sprintf qq{#line %d "%s"\n}, __LINE__ + 2, __FILE__; print OUT <<'EOF'; #define X(sym, ...) \ , sym typedef enum { PDL_INVALID=-1 PDL_TYPELIST_ALL(X) } pdl_datatypes; #undef X #define X(sym, ctype, ppsym, shortctype, defbval, realctype, ...) \ typedef realctype ctype; PDL_TYPELIST_ALL(X) #undef X #endif /* Define a simple pdl C data structure which maps onto passed ndarrays for passing with callext(). Note it is up to the user at the perl level to get the datatype right. Anything more sophisticated probably ought to go through PP anyway (which is fairly trivial). */ typedef struct { pdl_datatypes datatype; /* whether byte/int/float etc. */ void *data; /* Generic pointer to the data block */ PDL_Indx nvals; /* Number of data values */ PDL_Indx *dims; /* Array of data dimensions */ PDL_Indx ndims; /* Number of data dimensions */ } pdlsimple; EOF PDL-2.074/Basic/Core/ppport.h0000644000175000017500000046204214160714722015515 0ustar osboxesosboxes#if 0 <<'SKIP'; #endif /* ---------------------------------------------------------------------- ppport.h -- Perl/Pollution/Portability Version 3.14 Automatically created by Devel::PPPort running under perl 5.010000. Do NOT edit this file directly! -- Edit PPPort_pm.PL and the includes in parts/inc/ instead. Use 'perldoc ppport.h' to view the documentation below. ---------------------------------------------------------------------- SKIP =pod =head1 NAME ppport.h - Perl/Pollution/Portability version 3.14 =head1 SYNOPSIS perl ppport.h [options] [source files] Searches current directory for files if no [source files] are given --help show short help --version show version --patch=file write one patch file with changes --copy=suffix write changed copies with suffix --diff=program use diff program and options --compat-version=version provide compatibility with Perl version --cplusplus accept C++ comments --quiet don't output anything except fatal errors --nodiag don't show diagnostics --nohints don't show hints --nochanges don't suggest changes --nofilter don't filter input files --strip strip all script and doc functionality from ppport.h --list-provided list provided API --list-unsupported list unsupported API --api-info=name show Perl API portability information =head1 COMPATIBILITY This version of F is designed to support operation with Perl installations back to 5.003, and has been tested up to 5.10.0. =head1 OPTIONS =head2 --help Display a brief usage summary. =head2 --version Display the version of F. =head2 --patch=I If this option is given, a single patch file will be created if any changes are suggested. This requires a working diff program to be installed on your system. =head2 --copy=I If this option is given, a copy of each file will be saved with the given suffix that contains the suggested changes. This does not require any external programs. Note that this does not automagially add a dot between the original filename and the suffix. If you want the dot, you have to include it in the option argument. If neither C<--patch> or C<--copy> are given, the default is to simply print the diffs for each file. This requires either C or a C program to be installed. =head2 --diff=I Manually set the diff program and options to use. The default is to use C, when installed, and output unified context diffs. =head2 --compat-version=I Tell F to check for compatibility with the given Perl version. The default is to check for compatibility with Perl version 5.003. You can use this option to reduce the output of F if you intend to be backward compatible only down to a certain Perl version. =head2 --cplusplus Usually, F will detect C++ style comments and replace them with C style comments for portability reasons. Using this option instructs F to leave C++ comments untouched. =head2 --quiet Be quiet. Don't print anything except fatal errors. =head2 --nodiag Don't output any diagnostic messages. Only portability alerts will be printed. =head2 --nohints Don't output any hints. Hints often contain useful portability notes. Warnings will still be displayed. =head2 --nochanges Don't suggest any changes. Only give diagnostic output and hints unless these are also deactivated. =head2 --nofilter Don't filter the list of input files. By default, files not looking like source code (i.e. not *.xs, *.c, *.cc, *.cpp or *.h) are skipped. =head2 --strip Strip all script and documentation functionality from F. This reduces the size of F dramatically and may be useful if you want to include F in smaller modules without increasing their distribution size too much. The stripped F will have a C<--unstrip> option that allows you to undo the stripping, but only if an appropriate C module is installed. =head2 --list-provided Lists the API elements for which compatibility is provided by F. Also lists if it must be explicitly requested, if it has dependencies, and if there are hints or warnings for it. =head2 --list-unsupported Lists the API elements that are known not to be supported by F and below which version of Perl they probably won't be available or work. =head2 --api-info=I Show portability information for API elements matching I. If I is surrounded by slashes, it is interpreted as a regular expression. =head1 DESCRIPTION In order for a Perl extension (XS) module to be as portable as possible across differing versions of Perl itself, certain steps need to be taken. =over 4 =item * Including this header is the first major one. This alone will give you access to a large part of the Perl API that hasn't been available in earlier Perl releases. Use perl ppport.h --list-provided to see which API elements are provided by ppport.h. =item * You should avoid using deprecated parts of the API. For example, using global Perl variables without the C prefix is deprecated. Also, some API functions used to have a C prefix. Using this form is also deprecated. You can safely use the supported API, as F will provide wrappers for older Perl versions. =item * If you use one of a few functions or variables that were not present in earlier versions of Perl, and that can't be provided using a macro, you have to explicitly request support for these functions by adding one or more C<#define>s in your source code before the inclusion of F. These functions or variables will be marked C in the list shown by C<--list-provided>. Depending on whether you module has a single or multiple files that use such functions or variables, you want either C or global variants. For a C function or variable (used only in a single source file), use: #define NEED_function #define NEED_variable For a global function or variable (used in multiple source files), use: #define NEED_function_GLOBAL #define NEED_variable_GLOBAL Note that you mustn't have more than one global request for the same function or variable in your project. Function / Variable Static Request Global Request ----------------------------------------------------------------------------------------- PL_signals NEED_PL_signals NEED_PL_signals_GLOBAL eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL grok_number() NEED_grok_number NEED_grok_number_GLOBAL grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL load_module() NEED_load_module NEED_load_module_GLOBAL my_snprintf() NEED_my_snprintf NEED_my_snprintf_GLOBAL my_strlcat() NEED_my_strlcat NEED_my_strlcat_GLOBAL my_strlcpy() NEED_my_strlcpy NEED_my_strlcpy_GLOBAL newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL newSVpvn_flags() NEED_newSVpvn_flags NEED_newSVpvn_flags_GLOBAL newSVpvn_share() NEED_newSVpvn_share NEED_newSVpvn_share_GLOBAL sv_2pv_flags() NEED_sv_2pv_flags NEED_sv_2pv_flags_GLOBAL sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL sv_pvn_force_flags() NEED_sv_pvn_force_flags NEED_sv_pvn_force_flags_GLOBAL sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL vload_module() NEED_vload_module NEED_vload_module_GLOBAL vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL warner() NEED_warner NEED_warner_GLOBAL To avoid namespace conflicts, you can change the namespace of the explicitly exported functions / variables using the C macro. Just C<#define> the macro before including C: #define DPPP_NAMESPACE MyOwnNamespace_ #include "ppport.h" The default namespace is C. =back The good thing is that most of the above can be checked by running F on your source code. See the next section for details. =head1 EXAMPLES To verify whether F is needed for your module, whether you should make any changes to your code, and whether any special defines should be used, F can be run as a Perl script to check your source code. Simply say: perl ppport.h The result will usually be a list of patches suggesting changes that should at least be acceptable, if not necessarily the most efficient solution, or a fix for all possible problems. If you know that your XS module uses features only available in newer Perl releases, if you're aware that it uses C++ comments, and if you want all suggestions as a single patch file, you could use something like this: perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff If you only want your code to be scanned without any suggestions for changes, use: perl ppport.h --nochanges You can specify a different C program or options, using the C<--diff> option: perl ppport.h --diff='diff -C 10' This would output context diffs with 10 lines of context. If you want to create patched copies of your files instead, use: perl ppport.h --copy=.new To display portability information for the C function, use: perl ppport.h --api-info=newSVpvn Since the argument to C<--api-info> can be a regular expression, you can use perl ppport.h --api-info=/_nomg$/ to display portability information for all C<_nomg> functions or perl ppport.h --api-info=/./ to display information for all known API elements. =head1 BUGS If this version of F is causing failure during the compilation of this module, please check if newer versions of either this module or C are available on CPAN before sending a bug report. If F was generated using the latest version of C and is causing failure of this module, please file a bug report using the CPAN Request Tracker at L. Please include the following information: =over 4 =item 1. The complete output from running "perl -V" =item 2. This file. =item 3. The name and version of the module you were trying to build. =item 4. A full log of the build that failed. =item 5. Any other information that you think could be relevant. =back For the latest version of this code, please get the C module from CPAN. =head1 COPYRIGHT Version 3.x, Copyright (c) 2004-2008, Marcus Holland-Moritz. Version 2.x, Copyright (C) 2001, Paul Marquess. Version 1.x, Copyright (C) 1999, Kenneth Albanowski. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO See L. =cut use strict; # Disable broken TRIE-optimization BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if $] >= 5.009004 && $] <= 5.009005 } my $VERSION = 3.14; my %opt = ( quiet => 0, diag => 1, hints => 1, changes => 1, cplusplus => 0, filter => 1, strip => 0, version => 0, ); my($ppport) = $0 =~ /([\w.]+)$/; my $LF = '(?:\r\n|[\r\n])'; # line feed my $HS = "[ \t]"; # horizontal whitespace # Never use C comments in this file! my $ccs = '/'.'*'; my $cce = '*'.'/'; my $rccs = quotemeta $ccs; my $rcce = quotemeta $cce; eval { require Getopt::Long; Getopt::Long::GetOptions(\%opt, qw( help quiet diag! filter! hints! changes! cplusplus strip version patch=s copy=s diff=s compat-version=s list-provided list-unsupported api-info=s )) or usage(); }; if ($@ and grep /^-/, @ARGV) { usage() if "@ARGV" =~ /^--?h(?:elp)?$/; die "Getopt::Long not found. Please don't use any options.\n"; } if ($opt{version}) { print "This is $0 $VERSION.\n"; exit 0; } usage() if $opt{help}; strip() if $opt{strip}; if (exists $opt{'compat-version'}) { my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) }; if ($@) { die "Invalid version number format: '$opt{'compat-version'}'\n"; } die "Only Perl 5 is supported\n" if $r != 5; die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000; $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s; } else { $opt{'compat-version'} = 5; } my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/ ? ( $1 => { ($2 ? ( base => $2 ) : ()), ($3 ? ( todo => $3 ) : ()), (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()), (index($4, 'p') >= 0 ? ( provided => 1 ) : ()), (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()), } ) : die "invalid spec: $_" } qw( AvFILLp|5.004050||p AvFILL||| CLASS|||n CX_CURPAD_SAVE||| CX_CURPAD_SV||| CopFILEAV|5.006000||p CopFILEGV_set|5.006000||p CopFILEGV|5.006000||p CopFILESV|5.006000||p CopFILE_set|5.006000||p CopFILE|5.006000||p CopSTASHPV_set|5.006000||p CopSTASHPV|5.006000||p CopSTASH_eq|5.006000||p CopSTASH_set|5.006000||p CopSTASH|5.006000||p CopyD|5.009002||p Copy||| CvPADLIST||| CvSTASH||| CvWEAKOUTSIDE||| DEFSV|5.004050||p END_EXTERN_C|5.005000||p ENTER||| ERRSV|5.004050||p EXTEND||| EXTERN_C|5.005000||p F0convert|||n FREETMPS||| GIMME_V||5.004000|n GIMME|||n GROK_NUMERIC_RADIX|5.007002||p G_ARRAY||| G_DISCARD||| G_EVAL||| G_NOARGS||| G_SCALAR||| G_VOID||5.004000| GetVars||| GvSV||| Gv_AMupdate||| HEf_SVKEY||5.004000| HeHASH||5.004000| HeKEY||5.004000| HeKLEN||5.004000| HePV||5.004000| HeSVKEY_force||5.004000| HeSVKEY_set||5.004000| HeSVKEY||5.004000| HeUTF8||5.011000| HeVAL||5.004000| HvNAME||| INT2PTR|5.006000||p IN_LOCALE_COMPILETIME|5.007002||p IN_LOCALE_RUNTIME|5.007002||p IN_LOCALE|5.007002||p IN_PERL_COMPILETIME|5.008001||p IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p IS_NUMBER_INFINITY|5.007002||p IS_NUMBER_IN_UV|5.007002||p IS_NUMBER_NAN|5.007003||p IS_NUMBER_NEG|5.007002||p IS_NUMBER_NOT_INT|5.007002||p IVSIZE|5.006000||p IVTYPE|5.006000||p IVdf|5.006000||p LEAVE||| LVRET||| MARK||| MULTICALL||5.011000| MY_CXT_CLONE|5.009002||p MY_CXT_INIT|5.007003||p MY_CXT|5.007003||p MoveD|5.009002||p Move||| NOOP|5.005000||p NUM2PTR|5.006000||p NVTYPE|5.006000||p NVef|5.006001||p NVff|5.006001||p NVgf|5.006001||p Newxc|5.009003||p Newxz|5.009003||p Newx|5.009003||p Nullav||| Nullch||| Nullcv||| Nullhv||| Nullsv||| ORIGMARK||| PAD_BASE_SV||| PAD_CLONE_VARS||| PAD_COMPNAME_FLAGS||| PAD_COMPNAME_GEN_set||| PAD_COMPNAME_GEN||| PAD_COMPNAME_OURSTASH||| PAD_COMPNAME_PV||| PAD_COMPNAME_TYPE||| PAD_RESTORE_LOCAL||| PAD_SAVE_LOCAL||| PAD_SAVE_SETNULLPAD||| PAD_SETSV||| PAD_SET_CUR_NOSAVE||| PAD_SET_CUR||| PAD_SVl||| PAD_SV||| PERL_ABS|5.008001||p PERL_BCDVERSION|5.011000||p PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p PERL_HASH|5.004000||p PERL_INT_MAX|5.004000||p PERL_INT_MIN|5.004000||p PERL_LONG_MAX|5.004000||p PERL_LONG_MIN|5.004000||p PERL_MAGIC_arylen|5.007002||p PERL_MAGIC_backref|5.007002||p PERL_MAGIC_bm|5.007002||p PERL_MAGIC_collxfrm|5.007002||p PERL_MAGIC_dbfile|5.007002||p PERL_MAGIC_dbline|5.007002||p PERL_MAGIC_defelem|5.007002||p PERL_MAGIC_envelem|5.007002||p PERL_MAGIC_env|5.007002||p PERL_MAGIC_ext|5.007002||p PERL_MAGIC_fm|5.007002||p PERL_MAGIC_glob|5.011000||p PERL_MAGIC_isaelem|5.007002||p PERL_MAGIC_isa|5.007002||p PERL_MAGIC_mutex|5.011000||p PERL_MAGIC_nkeys|5.007002||p PERL_MAGIC_overload_elem|5.007002||p PERL_MAGIC_overload_table|5.007002||p PERL_MAGIC_overload|5.007002||p PERL_MAGIC_pos|5.007002||p PERL_MAGIC_qr|5.007002||p PERL_MAGIC_regdata|5.007002||p PERL_MAGIC_regdatum|5.007002||p PERL_MAGIC_regex_global|5.007002||p PERL_MAGIC_shared_scalar|5.007003||p PERL_MAGIC_shared|5.007003||p PERL_MAGIC_sigelem|5.007002||p PERL_MAGIC_sig|5.007002||p PERL_MAGIC_substr|5.007002||p PERL_MAGIC_sv|5.007002||p PERL_MAGIC_taint|5.007002||p PERL_MAGIC_tiedelem|5.007002||p PERL_MAGIC_tiedscalar|5.007002||p PERL_MAGIC_tied|5.007002||p PERL_MAGIC_utf8|5.008001||p PERL_MAGIC_uvar_elem|5.007003||p PERL_MAGIC_uvar|5.007002||p PERL_MAGIC_vec|5.007002||p PERL_MAGIC_vstring|5.008001||p PERL_QUAD_MAX|5.004000||p PERL_QUAD_MIN|5.004000||p PERL_REVISION|5.006000||p PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p PERL_SCAN_DISALLOW_PREFIX|5.007003||p PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p PERL_SCAN_SILENT_ILLDIGIT|5.008001||p PERL_SHORT_MAX|5.004000||p PERL_SHORT_MIN|5.004000||p PERL_SIGNALS_UNSAFE_FLAG|5.008001||p PERL_SUBVERSION|5.006000||p PERL_UCHAR_MAX|5.004000||p PERL_UCHAR_MIN|5.004000||p PERL_UINT_MAX|5.004000||p PERL_UINT_MIN|5.004000||p PERL_ULONG_MAX|5.004000||p PERL_ULONG_MIN|5.004000||p PERL_UNUSED_ARG|5.009003||p PERL_UNUSED_CONTEXT|5.009004||p PERL_UNUSED_DECL|5.007002||p PERL_UNUSED_VAR|5.007002||p PERL_UQUAD_MAX|5.004000||p PERL_UQUAD_MIN|5.004000||p PERL_USE_GCC_BRACE_GROUPS|5.009004||p PERL_USHORT_MAX|5.004000||p PERL_USHORT_MIN|5.004000||p PERL_VERSION|5.006000||p PL_DBsignal|5.005000||p PL_DBsingle|||pn PL_DBsub|||pn PL_DBtrace|||pn PL_Sv|5.005000||p PL_compiling|5.004050||p PL_copline|5.011000||p PL_curcop|5.004050||p PL_curstash|5.004050||p PL_debstash|5.004050||p PL_defgv|5.004050||p PL_diehook|5.004050||p PL_dirty|5.004050||p PL_dowarn|||pn PL_errgv|5.004050||p PL_expect|5.011000||p PL_hexdigit|5.005000||p PL_hints|5.005000||p PL_last_in_gv|||n PL_laststatval|5.005000||p PL_modglobal||5.005000|n PL_na|5.004050||pn PL_no_modify|5.006000||p PL_ofs_sv|||n PL_perl_destruct_level|5.004050||p PL_perldb|5.004050||p PL_ppaddr|5.006000||p PL_rsfp_filters|5.004050||p PL_rsfp|5.004050||p PL_rs|||n PL_signals|5.008001||p PL_stack_base|5.004050||p PL_stack_sp|5.004050||p PL_statcache|5.005000||p PL_stdingv|5.004050||p PL_sv_arenaroot|5.004050||p PL_sv_no|5.004050||pn PL_sv_undef|5.004050||pn PL_sv_yes|5.004050||pn PL_tainted|5.004050||p PL_tainting|5.004050||p POP_MULTICALL||5.011000| POPi|||n POPl|||n POPn|||n POPpbytex||5.007001|n POPpx||5.005030|n POPp|||n POPs|||n PTR2IV|5.006000||p PTR2NV|5.006000||p PTR2UV|5.006000||p PTR2ul|5.007001||p PTRV|5.006000||p PUSHMARK||| PUSH_MULTICALL||5.011000| PUSHi||| PUSHmortal|5.009002||p PUSHn||| PUSHp||| PUSHs||| PUSHu|5.004000||p PUTBACK||| PerlIO_clearerr||5.007003| PerlIO_close||5.007003| PerlIO_context_layers||5.009004| PerlIO_eof||5.007003| PerlIO_error||5.007003| PerlIO_fileno||5.007003| PerlIO_fill||5.007003| PerlIO_flush||5.007003| PerlIO_get_base||5.007003| PerlIO_get_bufsiz||5.007003| PerlIO_get_cnt||5.007003| PerlIO_get_ptr||5.007003| PerlIO_read||5.007003| PerlIO_seek||5.007003| PerlIO_set_cnt||5.007003| PerlIO_set_ptrcnt||5.007003| PerlIO_setlinebuf||5.007003| PerlIO_stderr||5.007003| PerlIO_stdin||5.007003| PerlIO_stdout||5.007003| PerlIO_tell||5.007003| PerlIO_unread||5.007003| PerlIO_write||5.007003| Perl_signbit||5.009005|n PoisonFree|5.009004||p PoisonNew|5.009004||p PoisonWith|5.009004||p Poison|5.008000||p RETVAL|||n Renewc||| Renew||| SAVECLEARSV||| SAVECOMPPAD||| SAVEPADSV||| SAVETMPS||| SAVE_DEFSV|5.004050||p SPAGAIN||| SP||| START_EXTERN_C|5.005000||p START_MY_CXT|5.007003||p STMT_END|||p STMT_START|||p STR_WITH_LEN|5.009003||p ST||| SV_CONST_RETURN|5.009003||p SV_COW_DROP_PV|5.008001||p SV_COW_SHARED_HASH_KEYS|5.009005||p SV_GMAGIC|5.007002||p SV_HAS_TRAILING_NUL|5.009004||p SV_IMMEDIATE_UNREF|5.007001||p SV_MUTABLE_RETURN|5.009003||p SV_NOSTEAL|5.009002||p SV_SMAGIC|5.009003||p SV_UTF8_NO_ENCODING|5.008001||p SVf_UTF8|5.006000||p SVf|5.006000||p SVt_IV||| SVt_NV||| SVt_PVAV||| SVt_PVCV||| SVt_PVHV||| SVt_PVMG||| SVt_PV||| Safefree||| Slab_Alloc||| Slab_Free||| Slab_to_rw||| StructCopy||| SvCUR_set||| SvCUR||| SvEND||| SvGAMAGIC||5.006001| SvGETMAGIC|5.004050||p SvGROW||| SvIOK_UV||5.006000| SvIOK_notUV||5.006000| SvIOK_off||| SvIOK_only_UV||5.006000| SvIOK_only||| SvIOK_on||| SvIOKp||| SvIOK||| SvIVX||| SvIV_nomg|5.009001||p SvIV_set||| SvIVx||| SvIV||| SvIsCOW_shared_hash||5.008003| SvIsCOW||5.008003| SvLEN_set||| SvLEN||| SvLOCK||5.007003| SvMAGIC_set|5.009003||p SvNIOK_off||| SvNIOKp||| SvNIOK||| SvNOK_off||| SvNOK_only||| SvNOK_on||| SvNOKp||| SvNOK||| SvNVX||| SvNV_set||| SvNVx||| SvNV||| SvOK||| SvOOK||| SvPOK_off||| SvPOK_only_UTF8||5.006000| SvPOK_only||| SvPOK_on||| SvPOKp||| SvPOK||| SvPVX_const|5.009003||p SvPVX_mutable|5.009003||p SvPVX||| SvPV_const|5.009003||p SvPV_flags_const_nolen|5.009003||p SvPV_flags_const|5.009003||p SvPV_flags_mutable|5.009003||p SvPV_flags|5.007002||p SvPV_force_flags_mutable|5.009003||p SvPV_force_flags_nolen|5.009003||p SvPV_force_flags|5.007002||p SvPV_force_mutable|5.009003||p SvPV_force_nolen|5.009003||p SvPV_force_nomg_nolen|5.009003||p SvPV_force_nomg|5.007002||p SvPV_force|||p SvPV_mutable|5.009003||p SvPV_nolen_const|5.009003||p SvPV_nolen|5.006000||p SvPV_nomg_const_nolen|5.009003||p SvPV_nomg_const|5.009003||p SvPV_nomg|5.007002||p SvPV_set||| SvPVbyte_force||5.009002| SvPVbyte_nolen||5.006000| SvPVbytex_force||5.006000| SvPVbytex||5.006000| SvPVbyte|5.006000||p SvPVutf8_force||5.006000| SvPVutf8_nolen||5.006000| SvPVutf8x_force||5.006000| SvPVutf8x||5.006000| SvPVutf8||5.006000| SvPVx||| SvPV||| SvREFCNT_dec||| SvREFCNT_inc_NN|5.009004||p SvREFCNT_inc_simple_NN|5.009004||p SvREFCNT_inc_simple_void_NN|5.009004||p SvREFCNT_inc_simple_void|5.009004||p SvREFCNT_inc_simple|5.009004||p SvREFCNT_inc_void_NN|5.009004||p SvREFCNT_inc_void|5.009004||p SvREFCNT_inc|||p SvREFCNT||| SvROK_off||| SvROK_on||| SvROK||| SvRV_set|5.009003||p SvRV||| SvRXOK||5.009005| SvRX||5.009005| SvSETMAGIC||| SvSHARED_HASH|5.009003||p SvSHARE||5.007003| SvSTASH_set|5.009003||p SvSTASH||| SvSetMagicSV_nosteal||5.004000| SvSetMagicSV||5.004000| SvSetSV_nosteal||5.004000| SvSetSV||| SvTAINTED_off||5.004000| SvTAINTED_on||5.004000| SvTAINTED||5.004000| SvTAINT||| SvTRUE||| SvTYPE||| SvUNLOCK||5.007003| SvUOK|5.007001|5.006000|p SvUPGRADE||| SvUTF8_off||5.006000| SvUTF8_on||5.006000| SvUTF8||5.006000| SvUVXx|5.004000||p SvUVX|5.004000||p SvUV_nomg|5.009001||p SvUV_set|5.009003||p SvUVx|5.004000||p SvUV|5.004000||p SvVOK||5.008001| SvVSTRING_mg|5.009004||p THIS|||n UNDERBAR|5.009002||p UTF8_MAXBYTES|5.009002||p UVSIZE|5.006000||p UVTYPE|5.006000||p UVXf|5.007001||p UVof|5.006000||p UVuf|5.006000||p UVxf|5.006000||p WARN_ALL|5.006000||p WARN_AMBIGUOUS|5.006000||p WARN_ASSERTIONS|5.011000||p WARN_BAREWORD|5.006000||p WARN_CLOSED|5.006000||p WARN_CLOSURE|5.006000||p WARN_DEBUGGING|5.006000||p WARN_DEPRECATED|5.006000||p WARN_DIGIT|5.006000||p WARN_EXEC|5.006000||p WARN_EXITING|5.006000||p WARN_GLOB|5.006000||p WARN_INPLACE|5.006000||p WARN_INTERNAL|5.006000||p WARN_IO|5.006000||p WARN_LAYER|5.008000||p WARN_MALLOC|5.006000||p WARN_MISC|5.006000||p WARN_NEWLINE|5.006000||p WARN_NUMERIC|5.006000||p WARN_ONCE|5.006000||p WARN_OVERFLOW|5.006000||p WARN_PACK|5.006000||p WARN_PARENTHESIS|5.006000||p WARN_PIPE|5.006000||p WARN_PORTABLE|5.006000||p WARN_PRECEDENCE|5.006000||p WARN_PRINTF|5.006000||p WARN_PROTOTYPE|5.006000||p WARN_QW|5.006000||p WARN_RECURSION|5.006000||p WARN_REDEFINE|5.006000||p WARN_REGEXP|5.006000||p WARN_RESERVED|5.006000||p WARN_SEMICOLON|5.006000||p WARN_SEVERE|5.006000||p WARN_SIGNAL|5.006000||p WARN_SUBSTR|5.006000||p WARN_SYNTAX|5.006000||p WARN_TAINT|5.006000||p WARN_THREADS|5.008000||p WARN_UNINITIALIZED|5.006000||p WARN_UNOPENED|5.006000||p WARN_UNPACK|5.006000||p WARN_UNTIE|5.006000||p WARN_UTF8|5.006000||p WARN_VOID|5.006000||p XCPT_CATCH|5.009002||p XCPT_RETHROW|5.009002||p XCPT_TRY_END|5.009002||p XCPT_TRY_START|5.009002||p XPUSHi||| XPUSHmortal|5.009002||p XPUSHn||| XPUSHp||| XPUSHs||| XPUSHu|5.004000||p XSRETURN_EMPTY||| XSRETURN_IV||| XSRETURN_NO||| XSRETURN_NV||| XSRETURN_PV||| XSRETURN_UNDEF||| XSRETURN_UV|5.008001||p XSRETURN_YES||| XSRETURN|||p XST_mIV||| XST_mNO||| XST_mNV||| XST_mPV||| XST_mUNDEF||| XST_mUV|5.008001||p XST_mYES||| XS_VERSION_BOOTCHECK||| XS_VERSION||| XSprePUSH|5.006000||p XS||| ZeroD|5.009002||p Zero||| _aMY_CXT|5.007003||p _pMY_CXT|5.007003||p aMY_CXT_|5.007003||p aMY_CXT|5.007003||p aTHXR_|5.011000||p aTHXR|5.011000||p aTHX_|5.006000||p aTHX|5.006000||p add_data|||n addmad||| allocmy||| amagic_call||| amagic_cmp_locale||| amagic_cmp||| amagic_i_ncmp||| amagic_ncmp||| any_dup||| ao||| append_elem||| append_list||| append_madprops||| apply_attrs_my||| apply_attrs_string||5.006001| apply_attrs||| apply||| atfork_lock||5.007003|n atfork_unlock||5.007003|n av_arylen_p||5.009003| av_clear||| av_create_and_push||5.009005| av_create_and_unshift_one||5.009005| av_delete||5.006000| av_exists||5.006000| av_extend||| av_fake||| av_fetch||| av_fill||| av_iter_p||5.011000| av_len||| av_make||| av_pop||| av_push||| av_reify||| av_shift||| av_store||| av_undef||| av_unshift||| ax|||n bad_type||| bind_match||| block_end||| block_gimme||5.004000| block_start||| boolSV|5.004000||p boot_core_PerlIO||| boot_core_UNIVERSAL||| boot_core_mro||| boot_core_xsutils||| bytes_from_utf8||5.007001| bytes_to_uni|||n bytes_to_utf8||5.006001| call_argv|5.006000||p call_atexit||5.006000| call_list||5.004000| call_method|5.006000||p call_pv|5.006000||p call_sv|5.006000||p calloc||5.007002|n cando||| cast_i32||5.006000| cast_iv||5.006000| cast_ulong||5.006000| cast_uv||5.006000| check_type_and_open||| check_uni||| checkcomma||| checkposixcc||| ckWARN|5.006000||p ck_anoncode||| ck_bitop||| ck_concat||| ck_defined||| ck_delete||| ck_die||| ck_each||| ck_eof||| ck_eval||| ck_exec||| ck_exists||| ck_exit||| ck_ftst||| ck_fun||| ck_glob||| ck_grep||| ck_index||| ck_join||| ck_lengthconst||| ck_lfun||| ck_listiob||| ck_match||| ck_method||| ck_null||| ck_open||| ck_readline||| ck_repeat||| ck_require||| ck_retarget||| ck_return||| ck_rfun||| ck_rvconst||| ck_sassign||| ck_select||| ck_shift||| ck_sort||| ck_spair||| ck_split||| ck_subr||| ck_substr||| ck_svconst||| ck_trunc||| ck_unpack||| ckwarn_d||5.009003| ckwarn||5.009003| cl_and|||n cl_anything|||n cl_init_zero|||n cl_init|||n cl_is_anything|||n cl_or|||n clear_placeholders||| closest_cop||| convert||| cop_free||| cr_textfilter||| create_eval_scope||| croak_nocontext|||vn croak|||v csighandler||5.009003|n curmad||| custom_op_desc||5.007003| custom_op_name||5.007003| cv_ckproto_len||| cv_ckproto||| cv_clone||| cv_const_sv||5.004000| cv_dump||| cv_undef||| cx_dump||5.005000| cx_dup||| cxinc||| dAXMARK|5.009003||p dAX|5.007002||p dITEMS|5.007002||p dMARK||| dMULTICALL||5.009003| dMY_CXT_SV|5.007003||p dMY_CXT|5.007003||p dNOOP|5.006000||p dORIGMARK||| dSP||| dTHR|5.004050||p dTHXR|5.011000||p dTHXa|5.006000||p dTHXoa|5.006000||p dTHX|5.006000||p dUNDERBAR|5.009002||p dVAR|5.009003||p dXCPT|5.009002||p dXSARGS||| dXSI32||| dXSTARG|5.006000||p deb_curcv||| deb_nocontext|||vn deb_stack_all||| deb_stack_n||| debop||5.005000| debprofdump||5.005000| debprof||| debstackptrs||5.007003| debstack||5.007003| debug_start_match||| deb||5.007003|v del_sv||| delete_eval_scope||| delimcpy||5.004000| deprecate_old||| deprecate||| despatch_signals||5.007001| destroy_matcher||| die_nocontext|||vn die_where||| die|||v dirp_dup||| div128||| djSP||| do_aexec5||| do_aexec||| do_aspawn||| do_binmode||5.004050| do_chomp||| do_chop||| do_close||| do_dump_pad||| do_eof||| do_exec3||| do_execfree||| do_exec||| do_gv_dump||5.006000| do_gvgv_dump||5.006000| do_hv_dump||5.006000| do_ipcctl||| do_ipcget||| do_join||| do_kv||| do_magic_dump||5.006000| do_msgrcv||| do_msgsnd||| do_oddball||| do_op_dump||5.006000| do_op_xmldump||| do_open9||5.006000| do_openn||5.007001| do_open||5.004000| do_pmop_dump||5.006000| do_pmop_xmldump||| do_print||| do_readline||| do_seek||| do_semop||| do_shmio||| do_smartmatch||| do_spawn_nowait||| do_spawn||| do_sprintf||| do_sv_dump||5.006000| do_sysseek||| do_tell||| do_trans_complex_utf8||| do_trans_complex||| do_trans_count_utf8||| do_trans_count||| do_trans_simple_utf8||| do_trans_simple||| do_trans||| do_vecget||| do_vecset||| do_vop||| docatch||| doeval||| dofile||| dofindlabel||| doform||| doing_taint||5.008001|n dooneliner||| doopen_pm||| doparseform||| dopoptoeval||| dopoptogiven||| dopoptolabel||| dopoptoloop||| dopoptosub_at||| dopoptowhen||| doref||5.009003| dounwind||| dowantarray||| dump_all||5.006000| dump_eval||5.006000| dump_exec_pos||| dump_fds||| dump_form||5.006000| dump_indent||5.006000|v dump_mstats||| dump_packsubs||5.006000| dump_sub||5.006000| dump_sv_child||| dump_trie_interim_list||| dump_trie_interim_table||| dump_trie||| dump_vindent||5.006000| dumpuntil||| dup_attrlist||| emulate_cop_io||| eval_pv|5.006000||p eval_sv|5.006000||p exec_failed||| expect_number||| fbm_compile||5.005000| fbm_instr||5.005000| fd_on_nosuid_fs||| feature_is_enabled||| filter_add||| filter_del||| filter_gets||| filter_read||| find_and_forget_pmops||| find_array_subscript||| find_beginning||| find_byclass||| find_hash_subscript||| find_in_my_stash||| find_runcv||5.008001| find_rundefsvoffset||5.009002| find_script||| find_uninit_var||| first_symbol|||n fold_constants||| forbid_setid||| force_ident||| force_list||| force_next||| force_version||| force_word||| forget_pmop||| form_nocontext|||vn form||5.004000|v fp_dup||| fprintf_nocontext|||vn free_global_struct||| free_tied_hv_pool||| free_tmps||| gen_constant_list||| get_arena||| get_aux_mg||| get_av|5.006000||p get_context||5.006000|n get_cvn_flags||5.009005| get_cv|5.006000||p get_db_sub||| get_debug_opts||| get_hash_seed||| get_hv|5.006000||p get_mstats||| get_no_modify||| get_num||| get_op_descs||5.005000| get_op_names||5.005000| get_opargs||| get_ppaddr||5.006000| get_re_arg||| get_sv|5.006000||p get_vtbl||5.005030| getcwd_sv||5.007002| getenv_len||| glob_2number||| glob_2pv||| glob_assign_glob||| glob_assign_ref||| gp_dup||| gp_free||| gp_ref||| grok_bin|5.007003||p grok_hex|5.007003||p grok_number|5.007002||p grok_numeric_radix|5.007002||p grok_oct|5.007003||p group_end||| gv_AVadd||| gv_HVadd||| gv_IOadd||| gv_SVadd||| gv_autoload4||5.004000| gv_check||| gv_const_sv||5.009003| gv_dump||5.006000| gv_efullname3||5.004000| gv_efullname4||5.006001| gv_efullname||| gv_ename||| gv_fetchfile_flags||5.009005| gv_fetchfile||| gv_fetchmeth_autoload||5.007003| gv_fetchmethod_autoload||5.004000| gv_fetchmethod||| gv_fetchmeth||| gv_fetchpvn_flags||5.009002| gv_fetchpv||| gv_fetchsv||5.009002| gv_fullname3||5.004000| gv_fullname4||5.006001| gv_fullname||| gv_get_super_pkg||| gv_handler||5.007001| gv_init_sv||| gv_init||| gv_name_set||5.009004| gv_stashpvn|5.004000||p gv_stashpvs||5.009003| gv_stashpv||| gv_stashsv||| he_dup||| hek_dup||| hfreeentries||| hsplit||| hv_assert||5.011000| hv_auxinit|||n hv_backreferences_p||| hv_clear_placeholders||5.009001| hv_clear||| hv_common_key_len||5.010000| hv_common||5.010000| hv_copy_hints_hv||| hv_delayfree_ent||5.004000| hv_delete_common||| hv_delete_ent||5.004000| hv_delete||| hv_eiter_p||5.009003| hv_eiter_set||5.009003| hv_exists_ent||5.004000| hv_exists||| hv_fetch_ent||5.004000| hv_fetchs|5.009003||p hv_fetch||| hv_free_ent||5.004000| hv_iterinit||| hv_iterkeysv||5.004000| hv_iterkey||| hv_iternext_flags||5.008000| hv_iternextsv||| hv_iternext||| hv_iterval||| hv_kill_backrefs||| hv_ksplit||5.004000| hv_magic_check|||n hv_magic||| hv_name_set||5.009003| hv_notallowed||| hv_placeholders_get||5.009003| hv_placeholders_p||5.009003| hv_placeholders_set||5.009003| hv_riter_p||5.009003| hv_riter_set||5.009003| hv_scalar||5.009001| hv_store_ent||5.004000| hv_store_flags||5.008000| hv_stores|5.009004||p hv_store||| hv_undef||| ibcmp_locale||5.004000| ibcmp_utf8||5.007003| ibcmp||| incline||| incpush_if_exists||| incpush||| ingroup||| init_argv_symbols||| init_debugger||| init_global_struct||| init_i18nl10n||5.006000| init_i18nl14n||5.006000| init_ids||| init_interp||| init_main_stash||| init_perllib||| init_postdump_symbols||| init_predump_symbols||| init_stacks||5.005000| init_tm||5.007002| instr||| intro_my||| intuit_method||| intuit_more||| invert||| io_close||| isALNUM||| isALPHA||| isDIGIT||| isLOWER||| isSPACE||| isUPPER||| is_an_int||| is_gv_magical_sv||| is_gv_magical||| is_handle_constructor|||n is_list_assignment||| is_lvalue_sub||5.007001| is_uni_alnum_lc||5.006000| is_uni_alnumc_lc||5.006000| is_uni_alnumc||5.006000| is_uni_alnum||5.006000| is_uni_alpha_lc||5.006000| is_uni_alpha||5.006000| is_uni_ascii_lc||5.006000| is_uni_ascii||5.006000| is_uni_cntrl_lc||5.006000| is_uni_cntrl||5.006000| is_uni_digit_lc||5.006000| is_uni_digit||5.006000| is_uni_graph_lc||5.006000| is_uni_graph||5.006000| is_uni_idfirst_lc||5.006000| is_uni_idfirst||5.006000| is_uni_lower_lc||5.006000| is_uni_lower||5.006000| is_uni_print_lc||5.006000| is_uni_print||5.006000| is_uni_punct_lc||5.006000| is_uni_punct||5.006000| is_uni_space_lc||5.006000| is_uni_space||5.006000| is_uni_upper_lc||5.006000| is_uni_upper||5.006000| is_uni_xdigit_lc||5.006000| is_uni_xdigit||5.006000| is_utf8_alnumc||5.006000| is_utf8_alnum||5.006000| is_utf8_alpha||5.006000| is_utf8_ascii||5.006000| is_utf8_char_slow|||n is_utf8_char||5.006000| is_utf8_cntrl||5.006000| is_utf8_common||| is_utf8_digit||5.006000| is_utf8_graph||5.006000| is_utf8_idcont||5.008000| is_utf8_idfirst||5.006000| is_utf8_lower||5.006000| is_utf8_mark||5.006000| is_utf8_print||5.006000| is_utf8_punct||5.006000| is_utf8_space||5.006000| is_utf8_string_loclen||5.009003| is_utf8_string_loc||5.008001| is_utf8_string||5.006001| is_utf8_upper||5.006000| is_utf8_xdigit||5.006000| isa_lookup||| items|||n ix|||n jmaybe||| join_exact||| keyword||| leave_scope||| lex_end||| lex_start||| linklist||| listkids||| list||| load_module_nocontext|||vn load_module|5.006000||pv localize||| looks_like_bool||| looks_like_number||| lop||| mPUSHi|5.009002||p mPUSHn|5.009002||p mPUSHp|5.009002||p mPUSHs|5.011000||p mPUSHu|5.009002||p mXPUSHi|5.009002||p mXPUSHn|5.009002||p mXPUSHp|5.009002||p mXPUSHs|5.011000||p mXPUSHu|5.009002||p mad_free||| madlex||| madparse||| magic_clear_all_env||| magic_clearenv||| magic_clearhint||| magic_clearpack||| magic_clearsig||| magic_dump||5.006000| magic_existspack||| magic_freearylen_p||| magic_freeovrld||| magic_getarylen||| magic_getdefelem||| magic_getnkeys||| magic_getpack||| magic_getpos||| magic_getsig||| magic_getsubstr||| magic_gettaint||| magic_getuvar||| magic_getvec||| magic_get||| magic_killbackrefs||| magic_len||| magic_methcall||| magic_methpack||| magic_nextpack||| magic_regdata_cnt||| magic_regdatum_get||| magic_regdatum_set||| magic_scalarpack||| magic_set_all_env||| magic_setamagic||| magic_setarylen||| magic_setcollxfrm||| magic_setdbline||| magic_setdefelem||| magic_setenv||| magic_sethint||| magic_setisa||| magic_setmglob||| magic_setnkeys||| magic_setpack||| magic_setpos||| magic_setregexp||| magic_setsig||| magic_setsubstr||| magic_settaint||| magic_setutf8||| magic_setuvar||| magic_setvec||| magic_set||| magic_sizepack||| magic_wipepack||| magicname||| make_matcher||| make_trie_failtable||| make_trie||| malloced_size|||n malloc||5.007002|n markstack_grow||| matcher_matches_sv||| measure_struct||| memEQ|5.004000||p memNE|5.004000||p mem_collxfrm||| mess_alloc||| mess_nocontext|||vn mess||5.006000|v method_common||| mfree||5.007002|n mg_clear||| mg_copy||| mg_dup||| mg_find||| mg_free||| mg_get||| mg_length||5.005000| mg_localize||| mg_magical||| mg_set||| mg_size||5.005000| mini_mktime||5.007002| missingterm||| mode_from_discipline||| modkids||| mod||| more_bodies||| more_sv||| moreswitches||| mro_get_linear_isa_c3||| mro_get_linear_isa_dfs||| mro_get_linear_isa||5.009005| mro_isa_changed_in||| mro_meta_dup||| mro_meta_init||| mro_method_changed_in||5.009005| mul128||| mulexp10|||n my_atof2||5.007002| my_atof||5.006000| my_attrs||| my_bcopy|||n my_betoh16|||n my_betoh32|||n my_betoh64|||n my_betohi|||n my_betohl|||n my_betohs|||n my_bzero|||n my_chsize||| my_clearenv||| my_cxt_index||| my_cxt_init||| my_dirfd||5.009005| my_exit_jump||| my_exit||| my_failure_exit||5.004000| my_fflush_all||5.006000| my_fork||5.007003|n my_htobe16|||n my_htobe32|||n my_htobe64|||n my_htobei|||n my_htobel|||n my_htobes|||n my_htole16|||n my_htole32|||n my_htole64|||n my_htolei|||n my_htolel|||n my_htoles|||n my_htonl||| my_kid||| my_letoh16|||n my_letoh32|||n my_letoh64|||n my_letohi|||n my_letohl|||n my_letohs|||n my_lstat||| my_memcmp||5.004000|n my_memset|||n my_ntohl||| my_pclose||5.004000| my_popen_list||5.007001| my_popen||5.004000| my_setenv||| my_snprintf|5.009004||pvn my_socketpair||5.007003|n my_sprintf||5.009003|vn my_stat||| my_strftime||5.007002| my_strlcat|5.009004||pn my_strlcpy|5.009004||pn my_swabn|||n my_swap||| my_unexec||| my_vsnprintf||5.009004|n my||| need_utf8|||n newANONATTRSUB||5.006000| newANONHASH||| newANONLIST||| newANONSUB||| newASSIGNOP||| newATTRSUB||5.006000| newAVREF||| newAV||| newBINOP||| newCONDOP||| newCONSTSUB|5.004050||p newCVREF||| newDEFSVOP||| newFORM||| newFOROP||| newGIVENOP||5.009003| newGIVWHENOP||| newGP||| newGVOP||| newGVREF||| newGVgen||| newHVREF||| newHVhv||5.005000| newHV||| newIO||| newLISTOP||| newLOGOP||| newLOOPEX||| newLOOPOP||| newMADPROP||| newMADsv||| newMYSUB||| newNULLLIST||| newOP||| newPADOP||| newPMOP||| newPROG||| newPVOP||| newRANGE||| newRV_inc|5.004000||p newRV_noinc|5.004000||p newRV||| newSLICEOP||| newSTATEOP||| newSUB||| newSVOP||| newSVREF||| newSV_type||5.009005| newSVhek||5.009003| newSViv||| newSVnv||| newSVpvf_nocontext|||vn newSVpvf||5.004000|v newSVpvn_flags|5.011000||p newSVpvn_share|5.007001||p newSVpvn_utf8|5.011000||p newSVpvn|5.004050||p newSVpvs_flags|5.011000||p newSVpvs_share||5.009003| newSVpvs|5.009003||p newSVpv||| newSVrv||| newSVsv||| newSVuv|5.006000||p newSV||| newTOKEN||| newUNOP||| newWHENOP||5.009003| newWHILEOP||5.009003| newXS_flags||5.009004| newXSproto||5.006000| newXS||5.006000| new_collate||5.006000| new_constant||| new_ctype||5.006000| new_he||| new_logop||| new_numeric||5.006000| new_stackinfo||5.005000| new_version||5.009000| new_warnings_bitfield||| next_symbol||| nextargv||| nextchar||| ninstr||| no_bareword_allowed||| no_fh_allowed||| no_op||| not_a_number||| nothreadhook||5.008000| nuke_stacks||| num_overflow|||n offer_nice_chunk||| oopsAV||| oopsCV||| oopsHV||| op_clear||| op_const_sv||| op_dump||5.006000| op_free||| op_getmad_weak||| op_getmad||| op_null||5.007002| op_refcnt_dec||| op_refcnt_inc||| op_refcnt_lock||5.009002| op_refcnt_unlock||5.009002| op_xmldump||| open_script||| pMY_CXT_|5.007003||p pMY_CXT|5.007003||p pTHX_|5.006000||p pTHX|5.006000||p packWARN|5.007003||p pack_cat||5.007003| pack_rec||| package||| packlist||5.008001| pad_add_anon||| pad_add_name||| pad_alloc||| pad_block_start||| pad_check_dup||| pad_compname_type||| pad_findlex||| pad_findmy||| pad_fixup_inner_anons||| pad_free||| pad_leavemy||| pad_new||| pad_peg|||n pad_push||| pad_reset||| pad_setsv||| pad_sv||5.011000| pad_swipe||| pad_tidy||| pad_undef||| parse_body||| parse_unicode_opts||| parser_dup||| parser_free||| path_is_absolute|||n peep||| pending_Slabs_to_ro||| perl_alloc_using|||n perl_alloc|||n perl_clone_using|||n perl_clone|||n perl_construct|||n perl_destruct||5.007003|n perl_free|||n perl_parse||5.006000|n perl_run|||n pidgone||| pm_description||| pmflag||| pmop_dump||5.006000| pmop_xmldump||| pmruntime||| pmtrans||| pop_scope||| pregcomp||5.009005| pregexec||| pregfree2||5.011000| pregfree||| prepend_elem||| prepend_madprops||| printbuf||| printf_nocontext|||vn process_special_blocks||| ptr_table_clear||5.009005| ptr_table_fetch||5.009005| ptr_table_find|||n ptr_table_free||5.009005| ptr_table_new||5.009005| ptr_table_split||5.009005| ptr_table_store||5.009005| push_scope||| put_byte||| pv_display||5.006000| pv_escape||5.009004| pv_pretty||5.009004| pv_uni_display||5.007003| qerror||| qsortsvu||| re_compile||5.009005| re_croak2||| re_dup_guts||| re_intuit_start||5.009005| re_intuit_string||5.006000| readpipe_override||| realloc||5.007002|n reentrant_free||| reentrant_init||| reentrant_retry|||vn reentrant_size||| ref_array_or_hash||| refcounted_he_chain_2hv||| refcounted_he_fetch||| refcounted_he_free||| refcounted_he_new||| refcounted_he_value||| refkids||| refto||| ref||5.011000| reg_check_named_buff_matched||| reg_named_buff_all||5.009005| reg_named_buff_exists||5.009005| reg_named_buff_fetch||5.009005| reg_named_buff_firstkey||5.009005| reg_named_buff_iter||| reg_named_buff_nextkey||5.009005| reg_named_buff_scalar||5.009005| reg_named_buff||| reg_namedseq||| reg_node||| reg_numbered_buff_fetch||| reg_numbered_buff_length||| reg_numbered_buff_store||| reg_qr_package||| reg_recode||| reg_scan_name||| reg_skipcomment||| reg_stringify||5.009005| reg_temp_copy||| reganode||| regatom||| regbranch||| regclass_swash||5.009004| regclass||| regcppop||| regcppush||| regcurly|||n regdump_extflags||| regdump||5.005000| regdupe_internal||| regexec_flags||5.005000| regfree_internal||5.009005| reghop3|||n reghop4|||n reghopmaybe3|||n reginclass||| reginitcolors||5.006000| reginsert||| regmatch||| regnext||5.005000| regpiece||| regpposixcc||| regprop||| regrepeat||| regtail_study||| regtail||| regtry||| reguni||| regwhite|||n reg||| repeatcpy||| report_evil_fh||| report_uninit||| require_pv||5.006000| require_tie_mod||| restore_magic||| rninstr||| rsignal_restore||| rsignal_save||| rsignal_state||5.004000| rsignal||5.004000| run_body||| run_user_filter||| runops_debug||5.005000| runops_standard||5.005000| rvpv_dup||| rxres_free||| rxres_restore||| rxres_save||| safesyscalloc||5.006000|n safesysfree||5.006000|n safesysmalloc||5.006000|n safesysrealloc||5.006000|n same_dirent||| save_I16||5.004000| save_I32||| save_I8||5.006000| save_aelem||5.004050| save_alloc||5.006000| save_aptr||| save_ary||| save_bool||5.008001| save_clearsv||| save_delete||| save_destructor_x||5.006000| save_destructor||5.006000| save_freeop||| save_freepv||| save_freesv||| save_generic_pvref||5.006001| save_generic_svref||5.005030| save_gp||5.004000| save_hash||| save_hek_flags|||n save_helem||5.004050| save_hptr||| save_int||| save_item||| save_iv||5.005000| save_lines||| save_list||| save_long||| save_magic||| save_mortalizesv||5.007001| save_nogv||| save_op||| save_padsv||5.007001| save_pptr||| save_re_context||5.006000| save_scalar_at||| save_scalar||| save_set_svflags||5.009000| save_shared_pvref||5.007003| save_sptr||| save_svref||| save_vptr||5.006000| savepvn||| savepvs||5.009003| savepv||| savesharedpvn||5.009005| savesharedpv||5.007003| savestack_grow_cnt||5.008001| savestack_grow||| savesvpv||5.009002| sawparens||| scalar_mod_type|||n scalarboolean||| scalarkids||| scalarseq||| scalarvoid||| scalar||| scan_bin||5.006000| scan_commit||| scan_const||| scan_formline||| scan_heredoc||| scan_hex||| scan_ident||| scan_inputsymbol||| scan_num||5.007001| scan_oct||| scan_pat||| scan_str||| scan_subst||| scan_trans||| scan_version||5.009001| scan_vstring||5.009005| scan_word||| scope||| screaminstr||5.005000| seed||5.008001| sequence_num||| sequence_tail||| sequence||| set_context||5.006000|n set_numeric_local||5.006000| set_numeric_radix||5.006000| set_numeric_standard||5.006000| setdefout||| setenv_getix||| share_hek_flags||| share_hek||5.004000| si_dup||| sighandler|||n simplify_sort||| skipspace0||| skipspace1||| skipspace2||| skipspace||| softref2xv||| sortcv_stacked||| sortcv_xsub||| sortcv||| sortsv_flags||5.009003| sortsv||5.007003| space_join_names_mortal||| ss_dup||| stack_grow||| start_force||| start_glob||| start_subparse||5.004000| stashpv_hvname_match||5.011000| stdize_locale||| strEQ||| strGE||| strGT||| strLE||| strLT||| strNE||| str_to_version||5.006000| strip_return||| strnEQ||| strnNE||| study_chunk||| sub_crush_depth||| sublex_done||| sublex_push||| sublex_start||| sv_2bool||| sv_2cv||| sv_2io||| sv_2iuv_common||| sv_2iuv_non_preserve||| sv_2iv_flags||5.009001| sv_2iv||| sv_2mortal||| sv_2num||| sv_2nv||| sv_2pv_flags|5.007002||p sv_2pv_nolen|5.006000||p sv_2pvbyte_nolen|5.006000||p sv_2pvbyte|5.006000||p sv_2pvutf8_nolen||5.006000| sv_2pvutf8||5.006000| sv_2pv||| sv_2uv_flags||5.009001| sv_2uv|5.004000||p sv_add_arena||| sv_add_backref||| sv_backoff||| sv_bless||| sv_cat_decode||5.008001| sv_catpv_mg|5.004050||p sv_catpvf_mg_nocontext|||pvn sv_catpvf_mg|5.006000|5.004000|pv sv_catpvf_nocontext|||vn sv_catpvf||5.004000|v sv_catpvn_flags||5.007002| sv_catpvn_mg|5.004050||p sv_catpvn_nomg|5.007002||p sv_catpvn||| sv_catpvs|5.009003||p sv_catpv||| sv_catsv_flags||5.007002| sv_catsv_mg|5.004050||p sv_catsv_nomg|5.007002||p sv_catsv||| sv_catxmlpvn||| sv_catxmlsv||| sv_chop||| sv_clean_all||| sv_clean_objs||| sv_clear||| sv_cmp_locale||5.004000| sv_cmp||| sv_collxfrm||| sv_compile_2op||5.008001| sv_copypv||5.007003| sv_dec||| sv_del_backref||| sv_derived_from||5.004000| sv_destroyable||5.010000| sv_does||5.009004| sv_dump||| sv_dup||| sv_eq||| sv_exp_grow||| sv_force_normal_flags||5.007001| sv_force_normal||5.006000| sv_free2||| sv_free_arenas||| sv_free||| sv_gets||5.004000| sv_grow||| sv_i_ncmp||| sv_inc||| sv_insert||| sv_isa||| sv_isobject||| sv_iv||5.005000| sv_kill_backrefs||| sv_len_utf8||5.006000| sv_len||| sv_magic_portable|5.011000|5.004000|p sv_magicext||5.007003| sv_magic||| sv_mortalcopy||| sv_ncmp||| sv_newmortal||| sv_newref||| sv_nolocking||5.007003| sv_nosharing||5.007003| sv_nounlocking||| sv_nv||5.005000| sv_peek||5.005000| sv_pos_b2u_midway||| sv_pos_b2u||5.006000| sv_pos_u2b_cached||| sv_pos_u2b_forwards|||n sv_pos_u2b_midway|||n sv_pos_u2b||5.006000| sv_pvbyten_force||5.006000| sv_pvbyten||5.006000| sv_pvbyte||5.006000| sv_pvn_force_flags|5.007002||p sv_pvn_force||| sv_pvn_nomg|5.007003|5.005000|p sv_pvn||5.005000| sv_pvutf8n_force||5.006000| sv_pvutf8n||5.006000| sv_pvutf8||5.006000| sv_pv||5.006000| sv_recode_to_utf8||5.007003| sv_reftype||| sv_release_COW||| sv_replace||| sv_report_used||| sv_reset||| sv_rvweaken||5.006000| sv_setiv_mg|5.004050||p sv_setiv||| sv_setnv_mg|5.006000||p sv_setnv||| sv_setpv_mg|5.004050||p sv_setpvf_mg_nocontext|||pvn sv_setpvf_mg|5.006000|5.004000|pv sv_setpvf_nocontext|||vn sv_setpvf||5.004000|v sv_setpviv_mg||5.008001| sv_setpviv||5.008001| sv_setpvn_mg|5.004050||p sv_setpvn||| sv_setpvs|5.009004||p sv_setpv||| sv_setref_iv||| sv_setref_nv||| sv_setref_pvn||| sv_setref_pv||| sv_setref_uv||5.007001| sv_setsv_cow||| sv_setsv_flags||5.007002| sv_setsv_mg|5.004050||p sv_setsv_nomg|5.007002||p sv_setsv||| sv_setuv_mg|5.004050||p sv_setuv|5.004000||p sv_tainted||5.004000| sv_taint||5.004000| sv_true||5.005000| sv_unglob||| sv_uni_display||5.007003| sv_unmagic||| sv_unref_flags||5.007001| sv_unref||| sv_untaint||5.004000| sv_upgrade||| sv_usepvn_flags||5.009004| sv_usepvn_mg|5.004050||p sv_usepvn||| sv_utf8_decode||5.006000| sv_utf8_downgrade||5.006000| sv_utf8_encode||5.006000| sv_utf8_upgrade_flags||5.007002| sv_utf8_upgrade||5.007001| sv_uv|5.005000||p sv_vcatpvf_mg|5.006000|5.004000|p sv_vcatpvfn||5.004000| sv_vcatpvf|5.006000|5.004000|p sv_vsetpvf_mg|5.006000|5.004000|p sv_vsetpvfn||5.004000| sv_vsetpvf|5.006000|5.004000|p sv_xmlpeek||| svtype||| swallow_bom||| swap_match_buff||| swash_fetch||5.007002| swash_get||| swash_init||5.006000| sys_init3||5.010000|n sys_init||5.010000|n sys_intern_clear||| sys_intern_dup||| sys_intern_init||| sys_term||5.010000|n taint_env||| taint_proper||| tmps_grow||5.006000| toLOWER||| toUPPER||| to_byte_substr||| to_uni_fold||5.007003| to_uni_lower_lc||5.006000| to_uni_lower||5.007003| to_uni_title_lc||5.006000| to_uni_title||5.007003| to_uni_upper_lc||5.006000| to_uni_upper||5.007003| to_utf8_case||5.007003| to_utf8_fold||5.007003| to_utf8_lower||5.007003| to_utf8_substr||| to_utf8_title||5.007003| to_utf8_upper||5.007003| token_free||| token_getmad||| tokenize_use||| tokeq||| tokereport||| too_few_arguments||| too_many_arguments||| uiv_2buf|||n unlnk||| unpack_rec||| unpack_str||5.007003| unpackstring||5.008001| unshare_hek_or_pvn||| unshare_hek||| unsharepvn||5.004000| unwind_handler_stack||| update_debugger_info||| upg_version||5.009005| usage||| utf16_to_utf8_reversed||5.006001| utf16_to_utf8||5.006001| utf8_distance||5.006000| utf8_hop||5.006000| utf8_length||5.007001| utf8_mg_pos_cache_update||| utf8_to_bytes||5.006001| utf8_to_uvchr||5.007001| utf8_to_uvuni||5.007001| utf8n_to_uvchr||| utf8n_to_uvuni||5.007001| utilize||| uvchr_to_utf8_flags||5.007003| uvchr_to_utf8||| uvuni_to_utf8_flags||5.007003| uvuni_to_utf8||5.007001| validate_suid||| varname||| vcmp||5.009000| vcroak||5.006000| vdeb||5.007003| vdie_common||| vdie_croak_common||| vdie||| vform||5.006000| visit||| vivify_defelem||| vivify_ref||| vload_module|5.006000||p vmess||5.006000| vnewSVpvf|5.006000|5.004000|p vnormal||5.009002| vnumify||5.009000| vstringify||5.009000| vverify||5.009003| vwarner||5.006000| vwarn||5.006000| wait4pid||| warn_nocontext|||vn warner_nocontext|||vn warner|5.006000|5.004000|pv warn|||v watch||| whichsig||| write_no_mem||| write_to_stderr||| xmldump_all||| xmldump_attr||| xmldump_eval||| xmldump_form||| xmldump_indent|||v xmldump_packsubs||| xmldump_sub||| xmldump_vindent||| yyerror||| yylex||| yyparse||| yywarn||| ); if (exists $opt{'list-unsupported'}) { my $f; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $API{$f}{todo}; print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n"; } exit 0; } # Scan for possible replacement candidates my(%replace, %need, %hints, %warnings, %depends); my $replace = 0; my($hint, $define, $function); sub find_api { my $code = shift; $code =~ s{ / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) | "[^"\\]*(?:\\.[^"\\]*)*" | '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx; grep { exists $API{$_} } $code =~ /(\w+)/mg; } while () { if ($hint) { my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings; if (m{^\s*\*\s(.*?)\s*$}) { for (@{$hint->[1]}) { $h->{$_} ||= ''; # suppress warning with older perls $h->{$_} .= "$1\n"; } } else { undef $hint } } $hint = [$1, [split /,?\s+/, $2]] if m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$}; if ($define) { if ($define->[1] =~ /\\$/) { $define->[1] .= $_; } else { if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) { my @n = find_api($define->[1]); push @{$depends{$define->[0]}}, @n if @n } undef $define; } } $define = [$1, $2] if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(.*)}; if ($function) { if (/^}/) { if (exists $API{$function->[0]}) { my @n = find_api($function->[1]); push @{$depends{$function->[0]}}, @n if @n } undef $function; } else { $function->[1] .= $_; } } $function = [$1, ''] if m{^DPPP_\(my_(\w+)\)}; $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$}; $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)}; $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce}; $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$}; if (m{^\s*$rccs\s+(\w+)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) { push @{$depends{$1}}, map { s/\s+//g; $_ } split /,/, $2; } $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)}; } for (values %depends) { my %s; $_ = [sort grep !$s{$_}++, @$_]; } if (exists $opt{'api-info'}) { my $f; my $count = 0; my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$"; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $f =~ /$match/; print "\n=== $f ===\n\n"; my $info = 0; if ($API{$f}{base} || $API{$f}{todo}) { my $base = format_version($API{$f}{base} || $API{$f}{todo}); print "Supported at least starting from perl-$base.\n"; $info++; } if ($API{$f}{provided}) { my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003"; print "Support by $ppport provided back to perl-$todo.\n"; print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f}; print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f}; print "\n$hints{$f}" if exists $hints{$f}; print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f}; $info++; } print "No portability information available.\n" unless $info; $count++; } $count or print "Found no API matching '$opt{'api-info'}'."; print "\n"; exit 0; } if (exists $opt{'list-provided'}) { my $f; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $API{$f}{provided}; my @flags; push @flags, 'explicit' if exists $need{$f}; push @flags, 'depend' if exists $depends{$f}; push @flags, 'hint' if exists $hints{$f}; push @flags, 'warning' if exists $warnings{$f}; my $flags = @flags ? ' ['.join(', ', @flags).']' : ''; print "$f$flags\n"; } exit 0; } my @files; my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc ); my $srcext = join '|', map { quotemeta $_ } @srcext; if (@ARGV) { my %seen; for (@ARGV) { if (-e) { if (-f) { push @files, $_ unless $seen{$_}++; } else { warn "'$_' is not a file.\n" } } else { my @new = grep { -f } glob $_ or warn "'$_' does not exist.\n"; push @files, grep { !$seen{$_}++ } @new; } } } else { eval { require File::Find; File::Find::find(sub { $File::Find::name =~ /($srcext)$/i and push @files, $File::Find::name; }, '.'); }; if ($@) { @files = map { glob "*$_" } @srcext; } } if (!@ARGV || $opt{filter}) { my(@in, @out); my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files; for (@files) { my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/($srcext)$/i; push @{ $out ? \@out : \@in }, $_; } if (@ARGV && @out) { warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out); } @files = @in; } die "No input files given!\n" unless @files; my(%files, %global, %revreplace); %revreplace = reverse %replace; my $filename; my $patch_opened = 0; for $filename (@files) { unless (open IN, "<$filename") { warn "Unable to read from $filename: $!\n"; next; } info("Scanning $filename ..."); my $c = do { local $/; }; close IN; my %file = (orig => $c, changes => 0); # Temporarily remove C/XS comments and strings from the code my @ccom; $c =~ s{ ( ^$HS*\#$HS*include\b[^\r\n]+\b(?:\Q$ppport\E|XSUB\.h)\b[^\r\n]* | ^$HS*\#$HS*(?:define|elif|if(?:def)?)\b[^\r\n]* ) | ( ^$HS*\#[^\r\n]* | "[^"\\]*(?:\\.[^"\\]*)*" | '[^'\\]*(?:\\.[^'\\]*)*' | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]* ) ) }{ defined $2 and push @ccom, $2; defined $1 ? $1 : "$ccs$#ccom$cce" }mgsex; $file{ccom} = \@ccom; $file{code} = $c; $file{has_inc_ppport} = $c =~ /^$HS*#$HS*include[^\r\n]+\b\Q$ppport\E\b/m; my $func; for $func (keys %API) { my $match = $func; $match .= "|$revreplace{$func}" if exists $revreplace{$func}; if ($c =~ /\b(?:Perl_)?($match)\b/) { $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func}; $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/; if (exists $API{$func}{provided}) { $file{uses_provided}{$func}++; if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) { $file{uses}{$func}++; my @deps = rec_depend($func); if (@deps) { $file{uses_deps}{$func} = \@deps; for (@deps) { $file{uses}{$_} = 0 unless exists $file{uses}{$_}; } } for ($func, @deps) { $file{needs}{$_} = 'static' if exists $need{$_}; } } } if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) { if ($c =~ /\b$func\b/) { $file{uses_todo}{$func}++; } } } } while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) { if (exists $need{$2}) { $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++; } else { warning("Possibly wrong #define $1 in $filename") } } for (qw(uses needs uses_todo needed_global needed_static)) { for $func (keys %{$file{$_}}) { push @{$global{$_}{$func}}, $filename; } } $files{$filename} = \%file; } # Globally resolve NEED_'s my $need; for $need (keys %{$global{needs}}) { if (@{$global{needs}{$need}} > 1) { my @targets = @{$global{needs}{$need}}; my @t = grep $files{$_}{needed_global}{$need}, @targets; @targets = @t if @t; @t = grep /\.xs$/i, @targets; @targets = @t if @t; my $target = shift @targets; $files{$target}{needs}{$need} = 'global'; for (@{$global{needs}{$need}}) { $files{$_}{needs}{$need} = 'extern' if $_ ne $target; } } } for $filename (@files) { exists $files{$filename} or next; info("=== Analyzing $filename ==="); my %file = %{$files{$filename}}; my $func; my $c = $file{code}; my $warnings = 0; for $func (sort keys %{$file{uses_Perl}}) { if ($API{$func}{varargs}) { unless ($API{$func}{nothxarg}) { my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))} { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge); if ($changes) { warning("Doesn't pass interpreter argument aTHX to Perl_$func"); $file{changes} += $changes; } } } else { warning("Uses Perl_$func instead of $func"); $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*} {$func$1(}g); } } for $func (sort keys %{$file{uses_replace}}) { warning("Uses $func instead of $replace{$func}"); $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); } for $func (sort keys %{$file{uses_provided}}) { if ($file{uses}{$func}) { if (exists $file{uses_deps}{$func}) { diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}})); } else { diag("Uses $func"); } } $warnings += hint($func); } unless ($opt{quiet}) { for $func (sort keys %{$file{uses_todo}}) { print "*** WARNING: Uses $func, which may not be portable below perl ", format_version($API{$func}{todo}), ", even with '$ppport'\n"; $warnings++; } } for $func (sort keys %{$file{needed_static}}) { my $message = ''; if (not exists $file{uses}{$func}) { $message = "No need to define NEED_$func if $func is never used"; } elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') { $message = "No need to define NEED_$func when already needed globally"; } if ($message) { diag($message); $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg); } } for $func (sort keys %{$file{needed_global}}) { my $message = ''; if (not exists $global{uses}{$func}) { $message = "No need to define NEED_${func}_GLOBAL if $func is never used"; } elsif (exists $file{needs}{$func}) { if ($file{needs}{$func} eq 'extern') { $message = "No need to define NEED_${func}_GLOBAL when already needed globally"; } elsif ($file{needs}{$func} eq 'static') { $message = "No need to define NEED_${func}_GLOBAL when only used in this file"; } } if ($message) { diag($message); $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg); } } $file{needs_inc_ppport} = keys %{$file{uses}}; if ($file{needs_inc_ppport}) { my $pp = ''; for $func (sort keys %{$file{needs}}) { my $type = $file{needs}{$func}; next if $type eq 'extern'; my $suffix = $type eq 'global' ? '_GLOBAL' : ''; unless (exists $file{"needed_$type"}{$func}) { if ($type eq 'global') { diag("Files [@{$global{needs}{$func}}] need $func, adding global request"); } else { diag("File needs $func, adding static request"); } $pp .= "#define NEED_$func$suffix\n"; } } if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) { $pp = ''; $file{changes}++; } unless ($file{has_inc_ppport}) { diag("Needs to include '$ppport'"); $pp .= qq(#include "$ppport"\n) } if ($pp) { $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms) || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m) || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m) || ($c =~ s/^/$pp/); } } else { if ($file{has_inc_ppport}) { diag("No need to include '$ppport'"); $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m); } } # put back in our C comments my $ix; my $cppc = 0; my @ccom = @{$file{ccom}}; for $ix (0 .. $#ccom) { if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) { $cppc++; $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/; } else { $c =~ s/$rccs$ix$rcce/$ccom[$ix]/; } } if ($cppc) { my $s = $cppc != 1 ? 's' : ''; warning("Uses $cppc C++ style comment$s, which is not portable"); } my $s = $warnings != 1 ? 's' : ''; my $warn = $warnings ? " ($warnings warning$s)" : ''; info("Analysis completed$warn"); if ($file{changes}) { if (exists $opt{copy}) { my $newfile = "$filename$opt{copy}"; if (-e $newfile) { error("'$newfile' already exists, refusing to write copy of '$filename'"); } else { local *F; if (open F, ">$newfile") { info("Writing copy of '$filename' with changes to '$newfile'"); print F $c; close F; } else { error("Cannot open '$newfile' for writing: $!"); } } } elsif (exists $opt{patch} || $opt{changes}) { if (exists $opt{patch}) { unless ($patch_opened) { if (open PATCH, ">$opt{patch}") { $patch_opened = 1; } else { error("Cannot open '$opt{patch}' for writing: $!"); delete $opt{patch}; $opt{changes} = 1; goto fallback; } } mydiff(\*PATCH, $filename, $c); } else { fallback: info("Suggested changes:"); mydiff(\*STDOUT, $filename, $c); } } else { my $s = $file{changes} == 1 ? '' : 's'; info("$file{changes} potentially required change$s detected"); } } else { info("Looks good"); } } close PATCH if $patch_opened; exit 0; sub try_use { eval "use @_;"; return $@ eq '' } sub mydiff { local *F = shift; my($file, $str) = @_; my $diff; if (exists $opt{diff}) { $diff = run_diff($opt{diff}, $file, $str); } if (!defined $diff and try_use('Text::Diff')) { $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' }); $diff = <
$tmp") { print F $str; close F; if (open F, "$prog $file $tmp |") { while () { s/\Q$tmp\E/$file.patched/; $diff .= $_; } close F; unlink $tmp; return $diff; } unlink $tmp; } else { error("Cannot open '$tmp' for writing: $!"); } return undef; } sub rec_depend { my($func, $seen) = @_; return () unless exists $depends{$func}; $seen = {%{$seen||{}}}; return () if $seen->{$func}++; my %s; grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}}; } sub parse_version { my $ver = shift; if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { return ($1, $2, $3); } elsif ($ver !~ /^\d+\.[\d_]+$/) { die "cannot parse version '$ver'\n"; } $ver =~ s/_//g; $ver =~ s/$/000000/; my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; $v = int $v; $s = int $s; if ($r < 5 || ($r == 5 && $v < 6)) { if ($s % 10) { die "cannot parse version '$ver'\n"; } } return ($r, $v, $s); } sub format_version { my $ver = shift; $ver =~ s/$/000000/; my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; $v = int $v; $s = int $s; if ($r < 5 || ($r == 5 && $v < 6)) { if ($s % 10) { die "invalid version '$ver'\n"; } $s /= 10; $ver = sprintf "%d.%03d", $r, $v; $s > 0 and $ver .= sprintf "_%02d", $s; return $ver; } return sprintf "%d.%d.%d", $r, $v, $s; } sub info { $opt{quiet} and return; print @_, "\n"; } sub diag { $opt{quiet} and return; $opt{diag} and print @_, "\n"; } sub warning { $opt{quiet} and return; print "*** ", @_, "\n"; } sub error { print "*** ERROR: ", @_, "\n"; } my %given_hints; my %given_warnings; sub hint { $opt{quiet} and return; my $func = shift; my $rv = 0; if (exists $warnings{$func} && !$given_warnings{$func}++) { my $warn = $warnings{$func}; $warn =~ s!^!*** !mg; print "*** WARNING: $func\n", $warn; $rv++; } if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) { my $hint = $hints{$func}; $hint =~ s/^/ /mg; print " --- hint for $func ---\n", $hint; } $rv; } sub usage { my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms; my %M = ( 'I' => '*' ); $usage =~ s/^\s*perl\s+\S+/$^X $0/; $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g; print < }; my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms; $copy =~ s/^(?=\S+)/ /gms; $self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms; $self =~ s/^SKIP.*(?=^__DATA__)/SKIP if (\@ARGV && \$ARGV[0] eq '--unstrip') { eval { require Devel::PPPort }; \$@ and die "Cannot require Devel::PPPort, please install.\\n"; if (\$Devel::PPPort::VERSION < $VERSION) { die "$0 was originally generated with Devel::PPPort $VERSION.\\n" . "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n" . "Please install a newer version, or --unstrip will not work.\\n"; } Devel::PPPort::WriteFile(\$0); exit 0; } print <$0" or die "cannot strip $0: $!\n"; print OUT "$pl$c\n"; exit 0; } __DATA__ */ #ifndef _P_P_PORTABILITY_H_ #define _P_P_PORTABILITY_H_ #ifndef DPPP_NAMESPACE # define DPPP_NAMESPACE DPPP_ #endif #define DPPP_CAT2(x,y) CAT2(x,y) #define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name) #ifndef PERL_REVISION # if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION)) # define PERL_PATCHLEVEL_H_IMPLICIT # include # endif # if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL))) # include # endif # ifndef PERL_REVISION # define PERL_REVISION (5) /* Replace: 1 */ # define PERL_VERSION PATCHLEVEL # define PERL_SUBVERSION SUBVERSION /* Replace PERL_PATCHLEVEL with PERL_VERSION */ /* Replace: 0 */ # endif #endif #define _dpppDEC2BCD(dec) ((((dec)/100)<<8)|((((dec)%100)/10)<<4)|((dec)%10)) #define PERL_BCDVERSION ((_dpppDEC2BCD(PERL_REVISION)<<24)|(_dpppDEC2BCD(PERL_VERSION)<<12)|_dpppDEC2BCD(PERL_SUBVERSION)) /* It is very unlikely that anyone will try to use this with Perl 6 (or greater), but who knows. */ #if PERL_REVISION != 5 # error ppport.h only works with Perl version 5 #endif /* PERL_REVISION != 5 */ #ifdef I_LIMITS # include #endif #ifndef PERL_UCHAR_MIN # define PERL_UCHAR_MIN ((unsigned char)0) #endif #ifndef PERL_UCHAR_MAX # ifdef UCHAR_MAX # define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX) # else # ifdef MAXUCHAR # define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR) # else # define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0) # endif # endif #endif #ifndef PERL_USHORT_MIN # define PERL_USHORT_MIN ((unsigned short)0) #endif #ifndef PERL_USHORT_MAX # ifdef USHORT_MAX # define PERL_USHORT_MAX ((unsigned short)USHORT_MAX) # else # ifdef MAXUSHORT # define PERL_USHORT_MAX ((unsigned short)MAXUSHORT) # else # ifdef USHRT_MAX # define PERL_USHORT_MAX ((unsigned short)USHRT_MAX) # else # define PERL_USHORT_MAX ((unsigned short)~(unsigned)0) # endif # endif # endif #endif #ifndef PERL_SHORT_MAX # ifdef SHORT_MAX # define PERL_SHORT_MAX ((short)SHORT_MAX) # else # ifdef MAXSHORT /* Often used in */ # define PERL_SHORT_MAX ((short)MAXSHORT) # else # ifdef SHRT_MAX # define PERL_SHORT_MAX ((short)SHRT_MAX) # else # define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1)) # endif # endif # endif #endif #ifndef PERL_SHORT_MIN # ifdef SHORT_MIN # define PERL_SHORT_MIN ((short)SHORT_MIN) # else # ifdef MINSHORT # define PERL_SHORT_MIN ((short)MINSHORT) # else # ifdef SHRT_MIN # define PERL_SHORT_MIN ((short)SHRT_MIN) # else # define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3)) # endif # endif # endif #endif #ifndef PERL_UINT_MAX # ifdef UINT_MAX # define PERL_UINT_MAX ((unsigned int)UINT_MAX) # else # ifdef MAXUINT # define PERL_UINT_MAX ((unsigned int)MAXUINT) # else # define PERL_UINT_MAX (~(unsigned int)0) # endif # endif #endif #ifndef PERL_UINT_MIN # define PERL_UINT_MIN ((unsigned int)0) #endif #ifndef PERL_INT_MAX # ifdef INT_MAX # define PERL_INT_MAX ((int)INT_MAX) # else # ifdef MAXINT /* Often used in */ # define PERL_INT_MAX ((int)MAXINT) # else # define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1)) # endif # endif #endif #ifndef PERL_INT_MIN # ifdef INT_MIN # define PERL_INT_MIN ((int)INT_MIN) # else # ifdef MININT # define PERL_INT_MIN ((int)MININT) # else # define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3)) # endif # endif #endif #ifndef PERL_ULONG_MAX # ifdef ULONG_MAX # define PERL_ULONG_MAX ((unsigned long)ULONG_MAX) # else # ifdef MAXULONG # define PERL_ULONG_MAX ((unsigned long)MAXULONG) # else # define PERL_ULONG_MAX (~(unsigned long)0) # endif # endif #endif #ifndef PERL_ULONG_MIN # define PERL_ULONG_MIN ((unsigned long)0L) #endif #ifndef PERL_LONG_MAX # ifdef LONG_MAX # define PERL_LONG_MAX ((long)LONG_MAX) # else # ifdef MAXLONG # define PERL_LONG_MAX ((long)MAXLONG) # else # define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1)) # endif # endif #endif #ifndef PERL_LONG_MIN # ifdef LONG_MIN # define PERL_LONG_MIN ((long)LONG_MIN) # else # ifdef MINLONG # define PERL_LONG_MIN ((long)MINLONG) # else # define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3)) # endif # endif #endif #if defined(HAS_QUAD) && (defined(convex) || defined(uts)) # ifndef PERL_UQUAD_MAX # ifdef ULONGLONG_MAX # define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX) # else # ifdef MAXULONGLONG # define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG) # else # define PERL_UQUAD_MAX (~(unsigned long long)0) # endif # endif # endif # ifndef PERL_UQUAD_MIN # define PERL_UQUAD_MIN ((unsigned long long)0L) # endif # ifndef PERL_QUAD_MAX # ifdef LONGLONG_MAX # define PERL_QUAD_MAX ((long long)LONGLONG_MAX) # else # ifdef MAXLONGLONG # define PERL_QUAD_MAX ((long long)MAXLONGLONG) # else # define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1)) # endif # endif # endif # ifndef PERL_QUAD_MIN # ifdef LONGLONG_MIN # define PERL_QUAD_MIN ((long long)LONGLONG_MIN) # else # ifdef MINLONGLONG # define PERL_QUAD_MIN ((long long)MINLONGLONG) # else # define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3)) # endif # endif # endif #endif /* This is based on code from 5.003 perl.h */ #ifdef HAS_QUAD # ifdef cray #ifndef IVTYPE # define IVTYPE int #endif #ifndef IV_MIN # define IV_MIN PERL_INT_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_INT_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_UINT_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_UINT_MAX #endif # ifdef INTSIZE #ifndef IVSIZE # define IVSIZE INTSIZE #endif # endif # else # if defined(convex) || defined(uts) #ifndef IVTYPE # define IVTYPE long long #endif #ifndef IV_MIN # define IV_MIN PERL_QUAD_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_QUAD_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_UQUAD_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_UQUAD_MAX #endif # ifdef LONGLONGSIZE #ifndef IVSIZE # define IVSIZE LONGLONGSIZE #endif # endif # else #ifndef IVTYPE # define IVTYPE long #endif #ifndef IV_MIN # define IV_MIN PERL_LONG_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_LONG_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_ULONG_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_ULONG_MAX #endif # ifdef LONGSIZE #ifndef IVSIZE # define IVSIZE LONGSIZE #endif # endif # endif # endif #ifndef IVSIZE # define IVSIZE 8 #endif #ifndef PERL_QUAD_MIN # define PERL_QUAD_MIN IV_MIN #endif #ifndef PERL_QUAD_MAX # define PERL_QUAD_MAX IV_MAX #endif #ifndef PERL_UQUAD_MIN # define PERL_UQUAD_MIN UV_MIN #endif #ifndef PERL_UQUAD_MAX # define PERL_UQUAD_MAX UV_MAX #endif #else #ifndef IVTYPE # define IVTYPE long #endif #ifndef IV_MIN # define IV_MIN PERL_LONG_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_LONG_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_ULONG_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_ULONG_MAX #endif #endif #ifndef IVSIZE # ifdef LONGSIZE # define IVSIZE LONGSIZE # else # define IVSIZE 4 /* A bold guess, but the best we can make. */ # endif #endif #ifndef UVTYPE # define UVTYPE unsigned IVTYPE #endif #ifndef UVSIZE # define UVSIZE IVSIZE #endif #ifndef sv_setuv # define sv_setuv(sv, uv) \ STMT_START { \ UV TeMpUv = uv; \ if (TeMpUv <= IV_MAX) \ sv_setiv(sv, TeMpUv); \ else \ sv_setnv(sv, (double)TeMpUv); \ } STMT_END #endif #ifndef newSVuv # define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv)) #endif #ifndef sv_2uv # define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv))) #endif #ifndef SvUVX # define SvUVX(sv) ((UV)SvIVX(sv)) #endif #ifndef SvUVXx # define SvUVXx(sv) SvUVX(sv) #endif #ifndef SvUV # define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv)) #endif #ifndef SvUVx # define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv)) #endif /* Hint: sv_uv * Always use the SvUVx() macro instead of sv_uv(). */ #ifndef sv_uv # define sv_uv(sv) SvUVx(sv) #endif #if !defined(SvUOK) && defined(SvIOK_UV) # define SvUOK(sv) SvIOK_UV(sv) #endif #ifndef XST_mUV # define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) ) #endif #ifndef XSRETURN_UV # define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END #endif #ifndef PUSHu # define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END #endif #ifndef XPUSHu # define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END #endif #ifdef HAS_MEMCMP #ifndef memNE # define memNE(s1,s2,l) (memcmp(s1,s2,l)) #endif #ifndef memEQ # define memEQ(s1,s2,l) (!memcmp(s1,s2,l)) #endif #else #ifndef memNE # define memNE(s1,s2,l) (bcmp(s1,s2,l)) #endif #ifndef memEQ # define memEQ(s1,s2,l) (!bcmp(s1,s2,l)) #endif #endif #ifndef MoveD # define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t)) #endif #ifndef CopyD # define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) #endif #ifdef HAS_MEMSET #ifndef ZeroD # define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t)) #endif #else #ifndef ZeroD # define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)), d) #endif #endif #ifndef PoisonWith # define PoisonWith(d,n,t,b) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t)) #endif #ifndef PoisonNew # define PoisonNew(d,n,t) PoisonWith(d,n,t,0xAB) #endif #ifndef PoisonFree # define PoisonFree(d,n,t) PoisonWith(d,n,t,0xEF) #endif #ifndef Poison # define Poison(d,n,t) PoisonFree(d,n,t) #endif #ifndef Newx # define Newx(v,n,t) New(0,v,n,t) #endif #ifndef Newxc # define Newxc(v,n,t,c) Newc(0,v,n,t,c) #endif #ifndef Newxz # define Newxz(v,n,t) Newz(0,v,n,t) #endif #ifndef PERL_UNUSED_DECL # ifdef HASATTRIBUTE # if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) # define PERL_UNUSED_DECL # else # define PERL_UNUSED_DECL __attribute__((unused)) # endif # else # define PERL_UNUSED_DECL # endif #endif #ifndef PERL_UNUSED_ARG # if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */ # include # define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) # else # define PERL_UNUSED_ARG(x) ((void)x) # endif #endif #ifndef PERL_UNUSED_VAR # define PERL_UNUSED_VAR(x) ((void)x) #endif #ifndef PERL_UNUSED_CONTEXT # ifdef USE_ITHREADS # define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl) # else # define PERL_UNUSED_CONTEXT # endif #endif #ifndef NOOP # define NOOP /*EMPTY*/(void)0 #endif #ifndef dNOOP # define dNOOP extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL #endif #ifndef NVTYPE # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) # define NVTYPE long double # else # define NVTYPE double # endif typedef NVTYPE NV; #endif #ifndef INT2PTR # if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) # define PTRV UV # define INT2PTR(any,d) (any)(d) # else # if PTRSIZE == LONGSIZE # define PTRV unsigned long # else # define PTRV unsigned # endif # define INT2PTR(any,d) (any)(PTRV)(d) # endif # define NUM2PTR(any,d) (any)(PTRV)(d) # define PTR2IV(p) INT2PTR(IV,p) # define PTR2UV(p) INT2PTR(UV,p) # define PTR2NV(p) NUM2PTR(NV,p) # if PTRSIZE == LONGSIZE # define PTR2ul(p) (unsigned long)(p) # else # define PTR2ul(p) INT2PTR(unsigned long,p) # endif #endif /* !INT2PTR */ #undef START_EXTERN_C #undef END_EXTERN_C #undef EXTERN_C #ifdef __cplusplus # define START_EXTERN_C extern "C" { # define END_EXTERN_C } # define EXTERN_C extern "C" #else # define START_EXTERN_C # define END_EXTERN_C # define EXTERN_C extern #endif #if defined(PERL_GCC_PEDANTIC) # ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN # define PERL_GCC_BRACE_GROUPS_FORBIDDEN # endif #endif #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) # ifndef PERL_USE_GCC_BRACE_GROUPS # define PERL_USE_GCC_BRACE_GROUPS # endif #endif #undef STMT_START #undef STMT_END #ifdef PERL_USE_GCC_BRACE_GROUPS # define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */ # define STMT_END ) #else # if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) # define STMT_START if (1) # define STMT_END else (void)0 # else # define STMT_START do # define STMT_END while (0) # endif #endif #ifndef boolSV # define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) #endif /* DEFSV appears first in 5.004_56 */ #ifndef DEFSV # define DEFSV GvSV(PL_defgv) #endif #ifndef SAVE_DEFSV # define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) #endif /* Older perls (<=5.003) lack AvFILLp */ #ifndef AvFILLp # define AvFILLp AvFILL #endif #ifndef ERRSV # define ERRSV get_sv("@",FALSE) #endif /* Hint: gv_stashpvn * This function's backport doesn't support the length parameter, but * rather ignores it. Portability can only be ensured if the length * parameter is used for speed reasons, but the length can always be * correctly computed from the string argument. */ #ifndef gv_stashpvn # define gv_stashpvn(str,len,create) gv_stashpv(str,create) #endif /* Replace: 1 */ #ifndef get_cv # define get_cv perl_get_cv #endif #ifndef get_sv # define get_sv perl_get_sv #endif #ifndef get_av # define get_av perl_get_av #endif #ifndef get_hv # define get_hv perl_get_hv #endif /* Replace: 0 */ #ifndef dUNDERBAR # define dUNDERBAR dNOOP #endif #ifndef UNDERBAR # define UNDERBAR DEFSV #endif #ifndef dAX # define dAX I32 ax = MARK - PL_stack_base + 1 #endif #ifndef dITEMS # define dITEMS I32 items = SP - MARK #endif #ifndef dXSTARG # define dXSTARG SV * targ = sv_newmortal() #endif #ifndef dAXMARK # define dAXMARK I32 ax = POPMARK; \ register SV ** const mark = PL_stack_base + ax++ #endif #ifndef XSprePUSH # define XSprePUSH (sp = PL_stack_base + ax - 1) #endif #if (PERL_BCDVERSION < 0x5005000) # undef XSRETURN # define XSRETURN(off) \ STMT_START { \ PL_stack_sp = PL_stack_base + ax + ((off) - 1); \ return; \ } STMT_END #endif #ifndef PERL_ABS # define PERL_ABS(x) ((x) < 0 ? -(x) : (x)) #endif #ifndef dVAR # define dVAR dNOOP #endif #ifndef SVf # define SVf "_" #endif #ifndef UTF8_MAXBYTES # define UTF8_MAXBYTES UTF8_MAXLEN #endif #ifndef PERL_HASH # define PERL_HASH(hash,str,len) \ STMT_START { \ const char *s_PeRlHaSh = str; \ I32 i_PeRlHaSh = len; \ U32 hash_PeRlHaSh = 0; \ while (i_PeRlHaSh--) \ hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \ (hash) = hash_PeRlHaSh; \ } STMT_END #endif #ifndef PERL_SIGNALS_UNSAFE_FLAG #define PERL_SIGNALS_UNSAFE_FLAG 0x0001 #if (PERL_BCDVERSION < 0x5008000) # define D_PPP_PERL_SIGNALS_INIT PERL_SIGNALS_UNSAFE_FLAG #else # define D_PPP_PERL_SIGNALS_INIT 0 #endif #if defined(NEED_PL_signals) static U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; #elif defined(NEED_PL_signals_GLOBAL) U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; #else extern U32 DPPP_(my_PL_signals); #endif #define PL_signals DPPP_(my_PL_signals) #endif /* Hint: PL_ppaddr * Calling an op via PL_ppaddr requires passing a context argument * for threaded builds. Since the context argument is different for * 5.005 perls, you can use aTHXR (supplied by ppport.h), which will * automatically be defined as the correct argument. */ #if (PERL_BCDVERSION <= 0x5005005) /* Replace: 1 */ # define PL_ppaddr ppaddr # define PL_no_modify no_modify /* Replace: 0 */ #endif #if (PERL_BCDVERSION <= 0x5004005) /* Replace: 1 */ # define PL_DBsignal DBsignal # define PL_DBsingle DBsingle # define PL_DBsub DBsub # define PL_DBtrace DBtrace # define PL_Sv Sv # define PL_compiling compiling # define PL_copline copline # define PL_curcop curcop # define PL_curstash curstash # define PL_debstash debstash # define PL_defgv defgv # define PL_diehook diehook # define PL_dirty dirty # define PL_dowarn dowarn # define PL_errgv errgv # define PL_expect expect # define PL_hexdigit hexdigit # define PL_hints hints # define PL_laststatval laststatval # define PL_na na # define PL_perl_destruct_level perl_destruct_level # define PL_perldb perldb # define PL_rsfp_filters rsfp_filters # define PL_rsfp rsfp # define PL_stack_base stack_base # define PL_stack_sp stack_sp # define PL_statcache statcache # define PL_stdingv stdingv # define PL_sv_arenaroot sv_arenaroot # define PL_sv_no sv_no # define PL_sv_undef sv_undef # define PL_sv_yes sv_yes # define PL_tainted tainted # define PL_tainting tainting /* Replace: 0 */ #endif /* Warning: PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters * Do not use this variable. It is internal to the perl parser * and may change or even be removed in the future. Note that * as of perl 5.9.5 you cannot assign to this variable anymore. */ /* TODO: cannot assign to these vars; is it worth fixing? */ #if (PERL_BCDVERSION >= 0x5009005) # define PL_expect (PL_parser ? PL_parser->expect : 0) # define PL_copline (PL_parser ? PL_parser->copline : 0) # define PL_rsfp (PL_parser ? PL_parser->rsfp : (PerlIO *) 0) # define PL_rsfp_filters (PL_parser ? PL_parser->rsfp_filters : (AV *) 0) #endif #ifndef dTHR # define dTHR dNOOP #endif #ifndef dTHX # define dTHX dNOOP #endif #ifndef dTHXa # define dTHXa(x) dNOOP #endif #ifndef pTHX # define pTHX void #endif #ifndef pTHX_ # define pTHX_ #endif #ifndef aTHX # define aTHX #endif #ifndef aTHX_ # define aTHX_ #endif #if (PERL_BCDVERSION < 0x5006000) # ifdef USE_THREADS # define aTHXR thr # define aTHXR_ thr, # else # define aTHXR # define aTHXR_ # endif # define dTHXR dTHR #else # define aTHXR aTHX # define aTHXR_ aTHX_ # define dTHXR dTHX #endif #ifndef dTHXoa # define dTHXoa(x) dTHXa(x) #endif #ifndef mPUSHs # define mPUSHs(s) PUSHs(sv_2mortal(s)) #endif #ifndef PUSHmortal # define PUSHmortal PUSHs(sv_newmortal()) #endif #ifndef mPUSHp # define mPUSHp(p,l) sv_setpvn(PUSHmortal, (p), (l)) #endif #ifndef mPUSHn # define mPUSHn(n) sv_setnv(PUSHmortal, (NV)(n)) #endif #ifndef mPUSHi # define mPUSHi(i) sv_setiv(PUSHmortal, (IV)(i)) #endif #ifndef mPUSHu # define mPUSHu(u) sv_setuv(PUSHmortal, (UV)(u)) #endif #ifndef mXPUSHs # define mXPUSHs(s) XPUSHs(sv_2mortal(s)) #endif #ifndef XPUSHmortal # define XPUSHmortal XPUSHs(sv_newmortal()) #endif #ifndef mXPUSHp # define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn(PUSHmortal, (p), (l)); } STMT_END #endif #ifndef mXPUSHn # define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv(PUSHmortal, (NV)(n)); } STMT_END #endif #ifndef mXPUSHi # define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv(PUSHmortal, (IV)(i)); } STMT_END #endif #ifndef mXPUSHu # define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv(PUSHmortal, (UV)(u)); } STMT_END #endif /* Replace: 1 */ #ifndef call_sv # define call_sv perl_call_sv #endif #ifndef call_pv # define call_pv perl_call_pv #endif #ifndef call_argv # define call_argv perl_call_argv #endif #ifndef call_method # define call_method perl_call_method #endif #ifndef eval_sv # define eval_sv perl_eval_sv #endif #ifndef PERL_LOADMOD_DENY # define PERL_LOADMOD_DENY 0x1 #endif #ifndef PERL_LOADMOD_NOIMPORT # define PERL_LOADMOD_NOIMPORT 0x2 #endif #ifndef PERL_LOADMOD_IMPORT_OPS # define PERL_LOADMOD_IMPORT_OPS 0x4 #endif /* Replace: 0 */ /* Replace perl_eval_pv with eval_pv */ #ifndef eval_pv #if defined(NEED_eval_pv) static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); static #else extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); #endif #ifdef eval_pv # undef eval_pv #endif #define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b) #define Perl_eval_pv DPPP_(my_eval_pv) #if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL) SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error) { dSP; SV* sv = newSVpv(p, 0); PUSHMARK(sp); eval_sv(sv, G_SCALAR); SvREFCNT_dec(sv); SPAGAIN; sv = POPs; PUTBACK; if (croak_on_error && SvTRUE(GvSV(errgv))) croak(SvPVx(GvSV(errgv), na)); return sv; } #endif #endif #ifndef vload_module #if defined(NEED_vload_module) static void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); static #else extern void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); #endif #ifdef vload_module # undef vload_module #endif #define vload_module(a,b,c,d) DPPP_(my_vload_module)(aTHX_ a,b,c,d) #define Perl_vload_module DPPP_(my_vload_module) #if defined(NEED_vload_module) || defined(NEED_vload_module_GLOBAL) void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args) { dTHR; dVAR; OP *veop, *imop; OP * const modname = newSVOP(OP_CONST, 0, name); /* 5.005 has a somewhat hacky force_normal that doesn't croak on SvREADONLY() if PL_compling is true. Current perls take care in ck_require() to correctly turn off SvREADONLY before calling force_normal_flags(). This seems a better fix than fudging PL_compling */ SvREADONLY_off(((SVOP*)modname)->op_sv); modname->op_private |= OPpCONST_BARE; if (ver) { veop = newSVOP(OP_CONST, 0, ver); } else veop = NULL; if (flags & PERL_LOADMOD_NOIMPORT) { imop = sawparens(newNULLLIST()); } else if (flags & PERL_LOADMOD_IMPORT_OPS) { imop = va_arg(*args, OP*); } else { SV *sv; imop = NULL; sv = va_arg(*args, SV*); while (sv) { imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); sv = va_arg(*args, SV*); } } { const line_t ocopline = PL_copline; COP * const ocurcop = PL_curcop; const int oexpect = PL_expect; #if (PERL_BCDVERSION >= 0x5004000) utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), veop, modname, imop); #else utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), modname, imop); #endif PL_expect = oexpect; PL_copline = ocopline; PL_curcop = ocurcop; } } #endif #endif #ifndef load_module #if defined(NEED_load_module) static void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); static #else extern void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); #endif #ifdef load_module # undef load_module #endif #define load_module DPPP_(my_load_module) #define Perl_load_module DPPP_(my_load_module) #if defined(NEED_load_module) || defined(NEED_load_module_GLOBAL) void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...) { va_list args; va_start(args, ver); vload_module(flags, name, ver, &args); va_end(args); } #endif #endif #ifndef newRV_inc # define newRV_inc(sv) newRV(sv) /* Replace */ #endif #ifndef newRV_noinc #if defined(NEED_newRV_noinc) static SV * DPPP_(my_newRV_noinc)(SV *sv); static #else extern SV * DPPP_(my_newRV_noinc)(SV *sv); #endif #ifdef newRV_noinc # undef newRV_noinc #endif #define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a) #define Perl_newRV_noinc DPPP_(my_newRV_noinc) #if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL) SV * DPPP_(my_newRV_noinc)(SV *sv) { SV *rv = (SV *)newRV(sv); SvREFCNT_dec(sv); return rv; } #endif #endif /* Hint: newCONSTSUB * Returns a CV* as of perl-5.7.1. This return value is not supported * by Devel::PPPort. */ /* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ #if (PERL_BCDVERSION < 0x5004063) && (PERL_BCDVERSION != 0x5004005) #if defined(NEED_newCONSTSUB) static void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); static #else extern void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); #endif #ifdef newCONSTSUB # undef newCONSTSUB #endif #define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c) #define Perl_newCONSTSUB DPPP_(my_newCONSTSUB) #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv) { U32 oldhints = PL_hints; HV *old_cop_stash = PL_curcop->cop_stash; HV *old_curstash = PL_curstash; line_t oldline = PL_curcop->cop_line; PL_curcop->cop_line = PL_copline; PL_hints &= ~HINT_BLOCK_SCOPE; if (stash) PL_curstash = PL_curcop->cop_stash = stash; newSUB( #if (PERL_BCDVERSION < 0x5003022) start_subparse(), #elif (PERL_BCDVERSION == 0x5003022) start_subparse(0), #else /* 5.003_23 onwards */ start_subparse(FALSE, 0), #endif newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)), newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) ); PL_hints = oldhints; PL_curcop->cop_stash = old_cop_stash; PL_curstash = old_curstash; PL_curcop->cop_line = oldline; } #endif #endif /* * Boilerplate macros for initializing and accessing interpreter-local * data from C. All statics in extensions should be reworked to use * this, if you want to make the extension thread-safe. See ext/re/re.xs * for an example of the use of these macros. * * Code that uses these macros is responsible for the following: * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" * 2. Declare a typedef named my_cxt_t that is a structure that contains * all the data that needs to be interpreter-local. * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. * 4. Use the MY_CXT_INIT macro such that it is called exactly once * (typically put in the BOOT: section). * 5. Use the members of the my_cxt_t structure everywhere as * MY_CXT.member. * 6. Use the dMY_CXT macro (a declaration) in all the functions that * access MY_CXT. */ #if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) #ifndef START_MY_CXT /* This must appear in all extensions that define a my_cxt_t structure, * right after the definition (i.e. at file scope). The non-threads * case below uses it to declare the data as static. */ #define START_MY_CXT #if (PERL_BCDVERSION < 0x5004068) /* Fetches the SV that keeps the per-interpreter data. */ #define dMY_CXT_SV \ SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE) #else /* >= perl5.004_68 */ #define dMY_CXT_SV \ SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ sizeof(MY_CXT_KEY)-1, TRUE) #endif /* < perl5.004_68 */ /* This declaration should be used within all functions that use the * interpreter-local data. */ #define dMY_CXT \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) /* Creates and zeroes the per-interpreter data. * (We allocate my_cxtp in a Perl SV so that it will be released when * the interpreter goes away.) */ #define MY_CXT_INIT \ dMY_CXT_SV; \ /* newSV() allocates one more than needed */ \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ Zero(my_cxtp, 1, my_cxt_t); \ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) /* This macro must be used to access members of the my_cxt_t structure. * e.g. MYCXT.some_data */ #define MY_CXT (*my_cxtp) /* Judicious use of these macros can reduce the number of times dMY_CXT * is used. Use is similar to pTHX, aTHX etc. */ #define pMY_CXT my_cxt_t *my_cxtp #define pMY_CXT_ pMY_CXT, #define _pMY_CXT ,pMY_CXT #define aMY_CXT my_cxtp #define aMY_CXT_ aMY_CXT, #define _aMY_CXT ,aMY_CXT #endif /* START_MY_CXT */ #ifndef MY_CXT_CLONE /* Clones the per-interpreter data. */ #define MY_CXT_CLONE \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) #endif #else /* single interpreter */ #ifndef START_MY_CXT #define START_MY_CXT static my_cxt_t my_cxt; #define dMY_CXT_SV dNOOP #define dMY_CXT dNOOP #define MY_CXT_INIT NOOP #define MY_CXT my_cxt #define pMY_CXT void #define pMY_CXT_ #define _pMY_CXT #define aMY_CXT #define aMY_CXT_ #define _aMY_CXT #endif /* START_MY_CXT */ #ifndef MY_CXT_CLONE #define MY_CXT_CLONE NOOP #endif #endif #ifndef IVdf # if IVSIZE == LONGSIZE # define IVdf "ld" # define UVuf "lu" # define UVof "lo" # define UVxf "lx" # define UVXf "lX" # else # if IVSIZE == INTSIZE # define IVdf "d" # define UVuf "u" # define UVof "o" # define UVxf "x" # define UVXf "X" # endif # endif #endif #ifndef NVef # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ defined(PERL_PRIfldbl) && (PERL_BCDVERSION != 0x5006000) /* Not very likely, but let's try anyway. */ # define NVef PERL_PRIeldbl # define NVff PERL_PRIfldbl # define NVgf PERL_PRIgldbl # else # define NVef "e" # define NVff "f" # define NVgf "g" # endif #endif #ifndef SvREFCNT_inc # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ if (_sv) \ (SvREFCNT(_sv))++; \ _sv; \ }) # else # define SvREFCNT_inc(sv) \ ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL) # endif #endif #ifndef SvREFCNT_inc_simple # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc_simple(sv) \ ({ \ if (sv) \ (SvREFCNT(sv))++; \ (SV *)(sv); \ }) # else # define SvREFCNT_inc_simple(sv) \ ((sv) ? (SvREFCNT(sv)++,(SV*)(sv)) : NULL) # endif #endif #ifndef SvREFCNT_inc_NN # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc_NN(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ SvREFCNT(_sv)++; \ _sv; \ }) # else # define SvREFCNT_inc_NN(sv) \ (PL_Sv=(SV*)(sv),++(SvREFCNT(PL_Sv)),PL_Sv) # endif #endif #ifndef SvREFCNT_inc_void # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc_void(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ if (_sv) \ (void)(SvREFCNT(_sv)++); \ }) # else # define SvREFCNT_inc_void(sv) \ (void)((PL_Sv=(SV*)(sv)) ? ++(SvREFCNT(PL_Sv)) : 0) # endif #endif #ifndef SvREFCNT_inc_simple_void # define SvREFCNT_inc_simple_void(sv) STMT_START { if (sv) SvREFCNT(sv)++; } STMT_END #endif #ifndef SvREFCNT_inc_simple_NN # define SvREFCNT_inc_simple_NN(sv) (++SvREFCNT(sv), (SV*)(sv)) #endif #ifndef SvREFCNT_inc_void_NN # define SvREFCNT_inc_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) #endif #ifndef SvREFCNT_inc_simple_void_NN # define SvREFCNT_inc_simple_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) #endif #ifndef newSVpvn # define newSVpvn(data,len) ((data) \ ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \ : newSV(0)) #endif #ifndef newSVpvn_utf8 # define newSVpvn_utf8(s, len, u) newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) #endif #ifndef SVf_UTF8 # define SVf_UTF8 0 #endif #ifndef newSVpvn_flags #if defined(NEED_newSVpvn_flags) static SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char * s, STRLEN len, U32 flags); static #else extern SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char * s, STRLEN len, U32 flags); #endif #ifdef newSVpvn_flags # undef newSVpvn_flags #endif #define newSVpvn_flags(a,b,c) DPPP_(my_newSVpvn_flags)(aTHX_ a,b,c) #define Perl_newSVpvn_flags DPPP_(my_newSVpvn_flags) #if defined(NEED_newSVpvn_flags) || defined(NEED_newSVpvn_flags_GLOBAL) SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags) { SV *sv = newSVpvn(s, len); SvFLAGS(sv) |= (flags & SVf_UTF8); return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv; } #endif #endif /* Backwards compatibility stuff... :-( */ #if !defined(NEED_sv_2pv_flags) && defined(NEED_sv_2pv_nolen) # define NEED_sv_2pv_flags #endif #if !defined(NEED_sv_2pv_flags_GLOBAL) && defined(NEED_sv_2pv_nolen_GLOBAL) # define NEED_sv_2pv_flags_GLOBAL #endif /* Hint: sv_2pv_nolen * Use the SvPV_nolen() or SvPV_nolen_const() macros instead of sv_2pv_nolen(). */ #ifndef sv_2pv_nolen # define sv_2pv_nolen(sv) SvPV_nolen(sv) #endif #ifdef SvPVbyte /* Hint: SvPVbyte * Does not work in perl-5.6.1, ppport.h implements a version * borrowed from perl-5.7.3. */ #if (PERL_BCDVERSION < 0x5007000) #if defined(NEED_sv_2pvbyte) static char * DPPP_(my_sv_2pvbyte)(pTHX_ SV * sv, STRLEN * lp); static #else extern char * DPPP_(my_sv_2pvbyte)(pTHX_ SV * sv, STRLEN * lp); #endif #ifdef sv_2pvbyte # undef sv_2pvbyte #endif #define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b) #define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte) #if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL) char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp) { sv_utf8_downgrade(sv,0); return SvPV(sv,*lp); } #endif /* Hint: sv_2pvbyte * Use the SvPVbyte() macro instead of sv_2pvbyte(). */ #undef SvPVbyte #define SvPVbyte(sv, lp) \ ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp)) #endif #else # define SvPVbyte SvPV # define sv_2pvbyte sv_2pv #endif #ifndef sv_2pvbyte_nolen # define sv_2pvbyte_nolen(sv) sv_2pv_nolen(sv) #endif /* Hint: sv_pvn * Always use the SvPV() macro instead of sv_pvn(). */ /* Hint: sv_pvn_force * Always use the SvPV_force() macro instead of sv_pvn_force(). */ /* If these are undefined, they're not handled by the core anyway */ #ifndef SV_IMMEDIATE_UNREF # define SV_IMMEDIATE_UNREF 0 #endif #ifndef SV_GMAGIC # define SV_GMAGIC 0 #endif #ifndef SV_COW_DROP_PV # define SV_COW_DROP_PV 0 #endif #ifndef SV_UTF8_NO_ENCODING # define SV_UTF8_NO_ENCODING 0 #endif #ifndef SV_NOSTEAL # define SV_NOSTEAL 0 #endif #ifndef SV_CONST_RETURN # define SV_CONST_RETURN 0 #endif #ifndef SV_MUTABLE_RETURN # define SV_MUTABLE_RETURN 0 #endif #ifndef SV_SMAGIC # define SV_SMAGIC 0 #endif #ifndef SV_HAS_TRAILING_NUL # define SV_HAS_TRAILING_NUL 0 #endif #ifndef SV_COW_SHARED_HASH_KEYS # define SV_COW_SHARED_HASH_KEYS 0 #endif #if (PERL_BCDVERSION < 0x5007002) #if defined(NEED_sv_2pv_flags) static char * DPPP_(my_sv_2pv_flags)(pTHX_ SV * sv, STRLEN * lp, I32 flags); static #else extern char * DPPP_(my_sv_2pv_flags)(pTHX_ SV * sv, STRLEN * lp, I32 flags); #endif #ifdef sv_2pv_flags # undef sv_2pv_flags #endif #define sv_2pv_flags(a,b,c) DPPP_(my_sv_2pv_flags)(aTHX_ a,b,c) #define Perl_sv_2pv_flags DPPP_(my_sv_2pv_flags) #if defined(NEED_sv_2pv_flags) || defined(NEED_sv_2pv_flags_GLOBAL) char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) { STRLEN n_a = (STRLEN) flags; return sv_2pv(sv, lp ? lp : &n_a); } #endif #if defined(NEED_sv_pvn_force_flags) static char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV * sv, STRLEN * lp, I32 flags); static #else extern char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV * sv, STRLEN * lp, I32 flags); #endif #ifdef sv_pvn_force_flags # undef sv_pvn_force_flags #endif #define sv_pvn_force_flags(a,b,c) DPPP_(my_sv_pvn_force_flags)(aTHX_ a,b,c) #define Perl_sv_pvn_force_flags DPPP_(my_sv_pvn_force_flags) #if defined(NEED_sv_pvn_force_flags) || defined(NEED_sv_pvn_force_flags_GLOBAL) char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) { STRLEN n_a = (STRLEN) flags; return sv_pvn_force(sv, lp ? lp : &n_a); } #endif #endif #if (PERL_BCDVERSION < 0x5008008) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009003) ) # define DPPP_SVPV_NOLEN_LP_ARG &PL_na #else # define DPPP_SVPV_NOLEN_LP_ARG 0 #endif #ifndef SvPV_const # define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_mutable # define SvPV_mutable(sv, lp) SvPV_flags_mutable(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_flags # define SvPV_flags(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags)) #endif #ifndef SvPV_flags_const # define SvPV_flags_const(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \ (const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN)) #endif #ifndef SvPV_flags_const_nolen # define SvPV_flags_const_nolen(sv, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX_const(sv) : \ (const char*) sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags|SV_CONST_RETURN)) #endif #ifndef SvPV_flags_mutable # define SvPV_flags_mutable(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \ sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) #endif #ifndef SvPV_force # define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_force_nolen # define SvPV_force_nolen(sv) SvPV_force_flags_nolen(sv, SV_GMAGIC) #endif #ifndef SvPV_force_mutable # define SvPV_force_mutable(sv, lp) SvPV_force_flags_mutable(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_force_nomg # define SvPV_force_nomg(sv, lp) SvPV_force_flags(sv, lp, 0) #endif #ifndef SvPV_force_nomg_nolen # define SvPV_force_nomg_nolen(sv) SvPV_force_flags_nolen(sv, 0) #endif #ifndef SvPV_force_flags # define SvPV_force_flags(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags)) #endif #ifndef SvPV_force_flags_nolen # define SvPV_force_flags_nolen(sv, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? SvPVX(sv) : sv_pvn_force_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags)) #endif #ifndef SvPV_force_flags_mutable # define SvPV_force_flags_mutable(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \ : sv_pvn_force_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) #endif #ifndef SvPV_nolen # define SvPV_nolen(sv) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC)) #endif #ifndef SvPV_nolen_const # define SvPV_nolen_const(sv) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX_const(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC|SV_CONST_RETURN)) #endif #ifndef SvPV_nomg # define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0) #endif #ifndef SvPV_nomg_const # define SvPV_nomg_const(sv, lp) SvPV_flags_const(sv, lp, 0) #endif #ifndef SvPV_nomg_const_nolen # define SvPV_nomg_const_nolen(sv) SvPV_flags_const_nolen(sv, 0) #endif #ifndef SvMAGIC_set # define SvMAGIC_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END #endif #if (PERL_BCDVERSION < 0x5009003) #ifndef SvPVX_const # define SvPVX_const(sv) ((const char*) (0 + SvPVX(sv))) #endif #ifndef SvPVX_mutable # define SvPVX_mutable(sv) (0 + SvPVX(sv)) #endif #ifndef SvRV_set # define SvRV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ (((XRV*) SvANY(sv))->xrv_rv = (val)); } STMT_END #endif #else #ifndef SvPVX_const # define SvPVX_const(sv) ((const char*)((sv)->sv_u.svu_pv)) #endif #ifndef SvPVX_mutable # define SvPVX_mutable(sv) ((sv)->sv_u.svu_pv) #endif #ifndef SvRV_set # define SvRV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ ((sv)->sv_u.svu_rv = (val)); } STMT_END #endif #endif #ifndef SvSTASH_set # define SvSTASH_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END #endif #if (PERL_BCDVERSION < 0x5004000) #ifndef SvUV_set # define SvUV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ (((XPVIV*) SvANY(sv))->xiv_iv = (IV) (val)); } STMT_END #endif #else #ifndef SvUV_set # define SvUV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ (((XPVUV*) SvANY(sv))->xuv_uv = (val)); } STMT_END #endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(vnewSVpvf) #if defined(NEED_vnewSVpvf) static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args); static #else extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args); #endif #ifdef vnewSVpvf # undef vnewSVpvf #endif #define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b) #define Perl_vnewSVpvf DPPP_(my_vnewSVpvf) #if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL) SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args) { register SV *sv = newSV(0); sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); return sv; } #endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf) # define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf) # define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg) #if defined(NEED_sv_catpvf_mg) static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...); static #else extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...); #endif #define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg) #if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL) void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...) { va_list args; va_start(args, pat); sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #ifdef PERL_IMPLICIT_CONTEXT #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg_nocontext) #if defined(NEED_sv_catpvf_mg_nocontext) static void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...); static #else extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...); #endif #define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) #define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) #if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL) void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...) { dTHX; va_list args; va_start(args, pat); sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #endif /* sv_catpvf_mg depends on sv_catpvf_mg_nocontext */ #ifndef sv_catpvf_mg # ifdef PERL_IMPLICIT_CONTEXT # define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext # else # define sv_catpvf_mg Perl_sv_catpvf_mg # endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf_mg) # define sv_vcatpvf_mg(sv, pat, args) \ STMT_START { \ sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ SvSETMAGIC(sv); \ } STMT_END #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg) #if defined(NEED_sv_setpvf_mg) static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...); static #else extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...); #endif #define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg) #if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL) void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...) { va_list args; va_start(args, pat); sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #ifdef PERL_IMPLICIT_CONTEXT #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg_nocontext) #if defined(NEED_sv_setpvf_mg_nocontext) static void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...); static #else extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...); #endif #define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) #define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) #if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL) void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...) { dTHX; va_list args; va_start(args, pat); sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #endif /* sv_setpvf_mg depends on sv_setpvf_mg_nocontext */ #ifndef sv_setpvf_mg # ifdef PERL_IMPLICIT_CONTEXT # define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext # else # define sv_setpvf_mg Perl_sv_setpvf_mg # endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf_mg) # define sv_vsetpvf_mg(sv, pat, args) \ STMT_START { \ sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ SvSETMAGIC(sv); \ } STMT_END #endif #ifndef newSVpvn_share #if defined(NEED_newSVpvn_share) static SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); static #else extern SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); #endif #ifdef newSVpvn_share # undef newSVpvn_share #endif #define newSVpvn_share(a,b,c) DPPP_(my_newSVpvn_share)(aTHX_ a,b,c) #define Perl_newSVpvn_share DPPP_(my_newSVpvn_share) #if defined(NEED_newSVpvn_share) || defined(NEED_newSVpvn_share_GLOBAL) SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash) { SV *sv; if (len < 0) len = -len; if (!hash) PERL_HASH(hash, (char*) src, len); sv = newSVpvn((char *) src, len); sv_upgrade(sv, SVt_PVIV); SvIVX(sv) = hash; SvREADONLY_on(sv); SvPOK_on(sv); return sv; } #endif #endif #ifndef SvSHARED_HASH # define SvSHARED_HASH(sv) (0 + SvUVX(sv)) #endif #ifndef WARN_ALL # define WARN_ALL 0 #endif #ifndef WARN_CLOSURE # define WARN_CLOSURE 1 #endif #ifndef WARN_DEPRECATED # define WARN_DEPRECATED 2 #endif #ifndef WARN_EXITING # define WARN_EXITING 3 #endif #ifndef WARN_GLOB # define WARN_GLOB 4 #endif #ifndef WARN_IO # define WARN_IO 5 #endif #ifndef WARN_CLOSED # define WARN_CLOSED 6 #endif #ifndef WARN_EXEC # define WARN_EXEC 7 #endif #ifndef WARN_LAYER # define WARN_LAYER 8 #endif #ifndef WARN_NEWLINE # define WARN_NEWLINE 9 #endif #ifndef WARN_PIPE # define WARN_PIPE 10 #endif #ifndef WARN_UNOPENED # define WARN_UNOPENED 11 #endif #ifndef WARN_MISC # define WARN_MISC 12 #endif #ifndef WARN_NUMERIC # define WARN_NUMERIC 13 #endif #ifndef WARN_ONCE # define WARN_ONCE 14 #endif #ifndef WARN_OVERFLOW # define WARN_OVERFLOW 15 #endif #ifndef WARN_PACK # define WARN_PACK 16 #endif #ifndef WARN_PORTABLE # define WARN_PORTABLE 17 #endif #ifndef WARN_RECURSION # define WARN_RECURSION 18 #endif #ifndef WARN_REDEFINE # define WARN_REDEFINE 19 #endif #ifndef WARN_REGEXP # define WARN_REGEXP 20 #endif #ifndef WARN_SEVERE # define WARN_SEVERE 21 #endif #ifndef WARN_DEBUGGING # define WARN_DEBUGGING 22 #endif #ifndef WARN_INPLACE # define WARN_INPLACE 23 #endif #ifndef WARN_INTERNAL # define WARN_INTERNAL 24 #endif #ifndef WARN_MALLOC # define WARN_MALLOC 25 #endif #ifndef WARN_SIGNAL # define WARN_SIGNAL 26 #endif #ifndef WARN_SUBSTR # define WARN_SUBSTR 27 #endif #ifndef WARN_SYNTAX # define WARN_SYNTAX 28 #endif #ifndef WARN_AMBIGUOUS # define WARN_AMBIGUOUS 29 #endif #ifndef WARN_BAREWORD # define WARN_BAREWORD 30 #endif #ifndef WARN_DIGIT # define WARN_DIGIT 31 #endif #ifndef WARN_PARENTHESIS # define WARN_PARENTHESIS 32 #endif #ifndef WARN_PRECEDENCE # define WARN_PRECEDENCE 33 #endif #ifndef WARN_PRINTF # define WARN_PRINTF 34 #endif #ifndef WARN_PROTOTYPE # define WARN_PROTOTYPE 35 #endif #ifndef WARN_QW # define WARN_QW 36 #endif #ifndef WARN_RESERVED # define WARN_RESERVED 37 #endif #ifndef WARN_SEMICOLON # define WARN_SEMICOLON 38 #endif #ifndef WARN_TAINT # define WARN_TAINT 39 #endif #ifndef WARN_THREADS # define WARN_THREADS 40 #endif #ifndef WARN_UNINITIALIZED # define WARN_UNINITIALIZED 41 #endif #ifndef WARN_UNPACK # define WARN_UNPACK 42 #endif #ifndef WARN_UNTIE # define WARN_UNTIE 43 #endif #ifndef WARN_UTF8 # define WARN_UTF8 44 #endif #ifndef WARN_VOID # define WARN_VOID 45 #endif #ifndef WARN_ASSERTIONS # define WARN_ASSERTIONS 46 #endif #ifndef packWARN # define packWARN(a) (a) #endif #ifndef ckWARN # ifdef G_WARN_ON # define ckWARN(a) (PL_dowarn & G_WARN_ON) # else # define ckWARN(a) PL_dowarn # endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(warner) #if defined(NEED_warner) static void DPPP_(my_warner)(U32 err, const char *pat, ...); static #else extern void DPPP_(my_warner)(U32 err, const char *pat, ...); #endif #define Perl_warner DPPP_(my_warner) #if defined(NEED_warner) || defined(NEED_warner_GLOBAL) void DPPP_(my_warner)(U32 err, const char *pat, ...) { SV *sv; va_list args; PERL_UNUSED_ARG(err); va_start(args, pat); sv = vnewSVpvf(pat, &args); va_end(args); sv_2mortal(sv); warn("%s", SvPV_nolen(sv)); } #define warner Perl_warner #define Perl_warner_nocontext Perl_warner #endif #endif /* concatenating with "" ensures that only literal strings are accepted as argument * note that STR_WITH_LEN() can't be used as argument to macros or functions that * under some configurations might be macros */ #ifndef STR_WITH_LEN # define STR_WITH_LEN(s) (s ""), (sizeof(s)-1) #endif #ifndef newSVpvs # define newSVpvs(str) newSVpvn(str "", sizeof(str) - 1) #endif #ifndef newSVpvs_flags # define newSVpvs_flags(str, flags) newSVpvn_flags(str "", sizeof(str) - 1, flags) #endif #ifndef sv_catpvs # define sv_catpvs(sv, str) sv_catpvn(sv, str "", sizeof(str) - 1) #endif #ifndef sv_setpvs # define sv_setpvs(sv, str) sv_setpvn(sv, str "", sizeof(str) - 1) #endif #ifndef hv_fetchs # define hv_fetchs(hv, key, lval) hv_fetch(hv, key "", sizeof(key) - 1, lval) #endif #ifndef hv_stores # define hv_stores(hv, key, val) hv_store(hv, key "", sizeof(key) - 1, val, 0) #endif #ifndef SvGETMAGIC # define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END #endif #ifndef PERL_MAGIC_sv # define PERL_MAGIC_sv '\0' #endif #ifndef PERL_MAGIC_overload # define PERL_MAGIC_overload 'A' #endif #ifndef PERL_MAGIC_overload_elem # define PERL_MAGIC_overload_elem 'a' #endif #ifndef PERL_MAGIC_overload_table # define PERL_MAGIC_overload_table 'c' #endif #ifndef PERL_MAGIC_bm # define PERL_MAGIC_bm 'B' #endif #ifndef PERL_MAGIC_regdata # define PERL_MAGIC_regdata 'D' #endif #ifndef PERL_MAGIC_regdatum # define PERL_MAGIC_regdatum 'd' #endif #ifndef PERL_MAGIC_env # define PERL_MAGIC_env 'E' #endif #ifndef PERL_MAGIC_envelem # define PERL_MAGIC_envelem 'e' #endif #ifndef PERL_MAGIC_fm # define PERL_MAGIC_fm 'f' #endif #ifndef PERL_MAGIC_regex_global # define PERL_MAGIC_regex_global 'g' #endif #ifndef PERL_MAGIC_isa # define PERL_MAGIC_isa 'I' #endif #ifndef PERL_MAGIC_isaelem # define PERL_MAGIC_isaelem 'i' #endif #ifndef PERL_MAGIC_nkeys # define PERL_MAGIC_nkeys 'k' #endif #ifndef PERL_MAGIC_dbfile # define PERL_MAGIC_dbfile 'L' #endif #ifndef PERL_MAGIC_dbline # define PERL_MAGIC_dbline 'l' #endif #ifndef PERL_MAGIC_mutex # define PERL_MAGIC_mutex 'm' #endif #ifndef PERL_MAGIC_shared # define PERL_MAGIC_shared 'N' #endif #ifndef PERL_MAGIC_shared_scalar # define PERL_MAGIC_shared_scalar 'n' #endif #ifndef PERL_MAGIC_collxfrm # define PERL_MAGIC_collxfrm 'o' #endif #ifndef PERL_MAGIC_tied # define PERL_MAGIC_tied 'P' #endif #ifndef PERL_MAGIC_tiedelem # define PERL_MAGIC_tiedelem 'p' #endif #ifndef PERL_MAGIC_tiedscalar # define PERL_MAGIC_tiedscalar 'q' #endif #ifndef PERL_MAGIC_qr # define PERL_MAGIC_qr 'r' #endif #ifndef PERL_MAGIC_sig # define PERL_MAGIC_sig 'S' #endif #ifndef PERL_MAGIC_sigelem # define PERL_MAGIC_sigelem 's' #endif #ifndef PERL_MAGIC_taint # define PERL_MAGIC_taint 't' #endif #ifndef PERL_MAGIC_uvar # define PERL_MAGIC_uvar 'U' #endif #ifndef PERL_MAGIC_uvar_elem # define PERL_MAGIC_uvar_elem 'u' #endif #ifndef PERL_MAGIC_vstring # define PERL_MAGIC_vstring 'V' #endif #ifndef PERL_MAGIC_vec # define PERL_MAGIC_vec 'v' #endif #ifndef PERL_MAGIC_utf8 # define PERL_MAGIC_utf8 'w' #endif #ifndef PERL_MAGIC_substr # define PERL_MAGIC_substr 'x' #endif #ifndef PERL_MAGIC_defelem # define PERL_MAGIC_defelem 'y' #endif #ifndef PERL_MAGIC_glob # define PERL_MAGIC_glob '*' #endif #ifndef PERL_MAGIC_arylen # define PERL_MAGIC_arylen '#' #endif #ifndef PERL_MAGIC_pos # define PERL_MAGIC_pos '.' #endif #ifndef PERL_MAGIC_backref # define PERL_MAGIC_backref '<' #endif #ifndef PERL_MAGIC_ext # define PERL_MAGIC_ext '~' #endif /* That's the best we can do... */ #ifndef sv_catpvn_nomg # define sv_catpvn_nomg sv_catpvn #endif #ifndef sv_catsv_nomg # define sv_catsv_nomg sv_catsv #endif #ifndef sv_setsv_nomg # define sv_setsv_nomg sv_setsv #endif #ifndef sv_pvn_nomg # define sv_pvn_nomg sv_pvn #endif #ifndef SvIV_nomg # define SvIV_nomg SvIV #endif #ifndef SvUV_nomg # define SvUV_nomg SvUV #endif #ifndef sv_catpv_mg # define sv_catpv_mg(sv, ptr) \ STMT_START { \ SV *TeMpSv = sv; \ sv_catpv(TeMpSv,ptr); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_catpvn_mg # define sv_catpvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_catpvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_catsv_mg # define sv_catsv_mg(dsv, ssv) \ STMT_START { \ SV *TeMpSv = dsv; \ sv_catsv(TeMpSv,ssv); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setiv_mg # define sv_setiv_mg(sv, i) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setiv(TeMpSv,i); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setnv_mg # define sv_setnv_mg(sv, num) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setnv(TeMpSv,num); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setpv_mg # define sv_setpv_mg(sv, ptr) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setpv(TeMpSv,ptr); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setpvn_mg # define sv_setpvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setpvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setsv_mg # define sv_setsv_mg(dsv, ssv) \ STMT_START { \ SV *TeMpSv = dsv; \ sv_setsv(TeMpSv,ssv); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setuv_mg # define sv_setuv_mg(sv, i) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setuv(TeMpSv,i); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_usepvn_mg # define sv_usepvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_usepvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef SvVSTRING_mg # define SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL) #endif /* Hint: sv_magic_portable * This is a compatibility function that is only available with * Devel::PPPort. It is NOT in the perl core. * Its purpose is to mimic the 5.8.0 behaviour of sv_magic() when * it is being passed a name pointer with namlen == 0. In that * case, perl 5.8.0 and later store the pointer, not a copy of it. * The compatibility can be provided back to perl 5.004. With * earlier versions, the code will not compile. */ #if (PERL_BCDVERSION < 0x5004000) /* code that uses sv_magic_portable will not compile */ #elif (PERL_BCDVERSION < 0x5008000) # define sv_magic_portable(sv, obj, how, name, namlen) \ STMT_START { \ SV *SvMp_sv = (sv); \ char *SvMp_name = (char *) (name); \ I32 SvMp_namlen = (namlen); \ if (SvMp_name && SvMp_namlen == 0) \ { \ MAGIC *mg; \ sv_magic(SvMp_sv, obj, how, 0, 0); \ mg = SvMAGIC(SvMp_sv); \ mg->mg_len = -42; /* XXX: this is the tricky part */ \ mg->mg_ptr = SvMp_name; \ } \ else \ { \ sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \ } \ } STMT_END #else # define sv_magic_portable(a, b, c, d, e) sv_magic(a, b, c, d, e) #endif #ifdef USE_ITHREADS #ifndef CopFILE # define CopFILE(c) ((c)->cop_file) #endif #ifndef CopFILEGV # define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv) #endif #ifndef CopFILE_set # define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) #endif #ifndef CopFILESV # define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) #endif #ifndef CopFILEAV # define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) #endif #ifndef CopSTASHPV # define CopSTASHPV(c) ((c)->cop_stashpv) #endif #ifndef CopSTASHPV_set # define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) #endif #ifndef CopSTASH # define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) #endif #ifndef CopSTASH_set # define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch) #endif #ifndef CopSTASH_eq # define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \ || (CopSTASHPV(c) && HvNAME(hv) \ && strEQ(CopSTASHPV(c), HvNAME(hv))))) #endif #else #ifndef CopFILEGV # define CopFILEGV(c) ((c)->cop_filegv) #endif #ifndef CopFILEGV_set # define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) #endif #ifndef CopFILE_set # define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) #endif #ifndef CopFILESV # define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv) #endif #ifndef CopFILEAV # define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav) #endif #ifndef CopFILE # define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch) #endif #ifndef CopSTASH # define CopSTASH(c) ((c)->cop_stash) #endif #ifndef CopSTASH_set # define CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) #endif #ifndef CopSTASHPV # define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) #endif #ifndef CopSTASHPV_set # define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) #endif #ifndef CopSTASH_eq # define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) #endif #endif /* USE_ITHREADS */ #ifndef IN_PERL_COMPILETIME # define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) #endif #ifndef IN_LOCALE_RUNTIME # define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE) #endif #ifndef IN_LOCALE_COMPILETIME # define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE) #endif #ifndef IN_LOCALE # define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) #endif #ifndef IS_NUMBER_IN_UV # define IS_NUMBER_IN_UV 0x01 #endif #ifndef IS_NUMBER_GREATER_THAN_UV_MAX # define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 #endif #ifndef IS_NUMBER_NOT_INT # define IS_NUMBER_NOT_INT 0x04 #endif #ifndef IS_NUMBER_NEG # define IS_NUMBER_NEG 0x08 #endif #ifndef IS_NUMBER_INFINITY # define IS_NUMBER_INFINITY 0x10 #endif #ifndef IS_NUMBER_NAN # define IS_NUMBER_NAN 0x20 #endif #ifndef GROK_NUMERIC_RADIX # define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) #endif #ifndef PERL_SCAN_GREATER_THAN_UV_MAX # define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 #endif #ifndef PERL_SCAN_SILENT_ILLDIGIT # define PERL_SCAN_SILENT_ILLDIGIT 0x04 #endif #ifndef PERL_SCAN_ALLOW_UNDERSCORES # define PERL_SCAN_ALLOW_UNDERSCORES 0x01 #endif #ifndef PERL_SCAN_DISALLOW_PREFIX # define PERL_SCAN_DISALLOW_PREFIX 0x02 #endif #ifndef grok_numeric_radix #if defined(NEED_grok_numeric_radix) static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); static #else extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); #endif #ifdef grok_numeric_radix # undef grok_numeric_radix #endif #define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b) #define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix) #if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL) bool DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send) { #ifdef USE_LOCALE_NUMERIC #ifdef PL_numeric_radix_sv if (PL_numeric_radix_sv && IN_LOCALE) { STRLEN len; char* radix = SvPV(PL_numeric_radix_sv, len); if (*sp + len <= send && memEQ(*sp, radix, len)) { *sp += len; return TRUE; } } #else /* older perls don't have PL_numeric_radix_sv so the radix * must manually be requested from locale.h */ #include dTHR; /* needed for older threaded perls */ struct lconv *lc = localeconv(); char *radix = lc->decimal_point; if (radix && IN_LOCALE) { STRLEN len = strlen(radix); if (*sp + len <= send && memEQ(*sp, radix, len)) { *sp += len; return TRUE; } } #endif #endif /* USE_LOCALE_NUMERIC */ /* always try "." if numeric radix didn't match because * we may have data from different locales mixed */ if (*sp < send && **sp == '.') { ++*sp; return TRUE; } return FALSE; } #endif #endif #ifndef grok_number #if defined(NEED_grok_number) static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); static #else extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); #endif #ifdef grok_number # undef grok_number #endif #define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c) #define Perl_grok_number DPPP_(my_grok_number) #if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL) int DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep) { const char *s = pv; const char *send = pv + len; const UV max_div_10 = UV_MAX / 10; const char max_mod_10 = UV_MAX % 10; int numtype = 0; int sawinf = 0; int sawnan = 0; while (s < send && isSPACE(*s)) s++; if (s == send) { return 0; } else if (*s == '-') { s++; numtype = IS_NUMBER_NEG; } else if (*s == '+') s++; if (s == send) return 0; /* next must be digit or the radix separator or beginning of infinity */ if (isDIGIT(*s)) { /* UVs are at least 32 bits, so the first 9 decimal digits cannot overflow. */ UV value = *s - '0'; /* This construction seems to be more optimiser friendly. (without it gcc does the isDIGIT test and the *s - '0' separately) With it gcc on arm is managing 6 instructions (6 cycles) per digit. In theory the optimiser could deduce how far to unroll the loop before checking for overflow. */ if (++s < send) { int digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { /* Now got 9 digits, so need to check each time for overflow. */ digit = *s - '0'; while (digit >= 0 && digit <= 9 && (value < max_div_10 || (value == max_div_10 && digit <= max_mod_10))) { value = value * 10 + digit; if (++s < send) digit = *s - '0'; else break; } if (digit >= 0 && digit <= 9 && (s < send)) { /* value overflowed. skip the remaining digits, don't worry about setting *valuep. */ do { s++; } while (s < send && isDIGIT(*s)); numtype |= IS_NUMBER_GREATER_THAN_UV_MAX; goto skip_value; } } } } } } } } } } } } } } } } } } numtype |= IS_NUMBER_IN_UV; if (valuep) *valuep = value; skip_value: if (GROK_NUMERIC_RADIX(&s, send)) { numtype |= IS_NUMBER_NOT_INT; while (s < send && isDIGIT(*s)) /* optional digits after the radix */ s++; } } else if (GROK_NUMERIC_RADIX(&s, send)) { numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */ /* no digits before the radix means we need digits after it */ if (s < send && isDIGIT(*s)) { do { s++; } while (s < send && isDIGIT(*s)); if (valuep) { /* integer approximation is valid - it's 0. */ *valuep = 0; } } else return 0; } else if (*s == 'I' || *s == 'i') { s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; if (s == send || (*s != 'F' && *s != 'f')) return 0; s++; if (s < send && (*s == 'I' || *s == 'i')) { s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; if (s == send || (*s != 'I' && *s != 'i')) return 0; s++; if (s == send || (*s != 'T' && *s != 't')) return 0; s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0; s++; } sawinf = 1; } else if (*s == 'N' || *s == 'n') { /* XXX TODO: There are signaling NaNs and quiet NaNs. */ s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; sawnan = 1; } else return 0; if (sawinf) { numtype &= IS_NUMBER_NEG; /* Keep track of sign */ numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; } else if (sawnan) { numtype &= IS_NUMBER_NEG; /* Keep track of sign */ numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; } else if (s < send) { /* we can have an optional exponent part */ if (*s == 'e' || *s == 'E') { /* The only flag we keep is sign. Blow away any "it's UV" */ numtype &= IS_NUMBER_NEG; numtype |= IS_NUMBER_NOT_INT; s++; if (s < send && (*s == '-' || *s == '+')) s++; if (s < send && isDIGIT(*s)) { do { s++; } while (s < send && isDIGIT(*s)); } else return 0; } } while (s < send && isSPACE(*s)) s++; if (s >= send) return numtype; if (len == 10 && memEQ(pv, "0 but true", 10)) { if (valuep) *valuep = 0; return IS_NUMBER_IN_UV; } return 0; } #endif #endif /* * The grok_* routines have been modified to use warn() instead of * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit, * which is why the stack variable has been renamed to 'xdigit'. */ #ifndef grok_bin #if defined(NEED_grok_bin) static UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #ifdef grok_bin # undef grok_bin #endif #define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d) #define Perl_grok_bin DPPP_(my_grok_bin) #if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL) UV DPPP_(my_grok_bin)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_2 = UV_MAX / 2; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { /* strip off leading b or 0b. for compatibility silently suffer "b" and "0b" as valid binary numbers. */ if (len >= 1) { if (s[0] == 'b') { s++; len--; } else if (len >= 2 && s[0] == '0' && s[1] == 'b') { s+=2; len-=2; } } } for (; len-- && *s; s++) { char bit = *s; if (bit == '0' || bit == '1') { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. With gcc seems to be much straighter code than old scan_bin. */ redo: if (!overflowed) { if (value <= max_div_2) { value = (value << 1) | (bit - '0'); continue; } /* Bah. We're just overflowed. */ warn("Integer overflow in binary number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 2.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount. */ value_nv += (NV)(bit - '0'); continue; } if (bit == '_' && len && allow_underscores && (bit = s[1]) && (bit == '0' || bit == '1')) { --len; ++s; goto redo; } if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal binary digit '%c' ignored", *s); break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Binary number > 0b11111111111111111111111111111111 non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #ifndef grok_hex #if defined(NEED_grok_hex) static UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #ifdef grok_hex # undef grok_hex #endif #define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d) #define Perl_grok_hex DPPP_(my_grok_hex) #if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL) UV DPPP_(my_grok_hex)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_16 = UV_MAX / 16; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; const char *xdigit; if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { /* strip off leading x or 0x. for compatibility silently suffer "x" and "0x" as valid hex numbers. */ if (len >= 1) { if (s[0] == 'x') { s++; len--; } else if (len >= 2 && s[0] == '0' && s[1] == 'x') { s+=2; len-=2; } } } for (; len-- && *s; s++) { xdigit = strchr((char *) PL_hexdigit, *s); if (xdigit) { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. With gcc seems to be much straighter code than old scan_hex. */ redo: if (!overflowed) { if (value <= max_div_16) { value = (value << 4) | ((xdigit - PL_hexdigit) & 15); continue; } warn("Integer overflow in hexadecimal number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 16.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount of 16-tuples. */ value_nv += (NV)((xdigit - PL_hexdigit) & 15); continue; } if (*s == '_' && len && allow_underscores && s[1] && (xdigit = strchr((char *) PL_hexdigit, s[1]))) { --len; ++s; goto redo; } if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal hexadecimal digit '%c' ignored", *s); break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Hexadecimal number > 0xffffffff non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #ifndef grok_oct #if defined(NEED_grok_oct) static UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #ifdef grok_oct # undef grok_oct #endif #define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d) #define Perl_grok_oct DPPP_(my_grok_oct) #if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL) UV DPPP_(my_grok_oct)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_8 = UV_MAX / 8; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; for (; len-- && *s; s++) { /* gcc 2.95 optimiser not smart enough to figure that this subtraction out front allows slicker code. */ int digit = *s - '0'; if (digit >= 0 && digit <= 7) { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. */ redo: if (!overflowed) { if (value <= max_div_8) { value = (value << 3) | digit; continue; } /* Bah. We're just overflowed. */ warn("Integer overflow in octal number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 8.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount of 8-tuples. */ value_nv += (NV)digit; continue; } if (digit == ('_' - '0') && len && allow_underscores && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) { --len; ++s; goto redo; } /* Allow \octal to work the DWIM way (that is, stop scanning * as soon as non-octal characters are seen, complain only iff * someone seems to want to use the digits eight and nine). */ if (digit == 8 || digit == 9) { if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal octal digit '%c' ignored", *s); } break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Octal number > 037777777777 non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #if !defined(my_snprintf) #if defined(NEED_my_snprintf) static int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); static #else extern int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); #endif #define my_snprintf DPPP_(my_my_snprintf) #define Perl_my_snprintf DPPP_(my_my_snprintf) #if defined(NEED_my_snprintf) || defined(NEED_my_snprintf_GLOBAL) int DPPP_(my_my_snprintf)(char *buffer, const Size_t len, const char *format, ...) { dTHX; int retval; va_list ap; va_start(ap, format); #ifdef HAS_VSNPRINTF retval = vsnprintf(buffer, len, format, ap); #else retval = vsprintf(buffer, format, ap); #endif va_end(ap); if (retval >= (int)len) Perl_croak(aTHX_ "panic: my_snprintf buffer overflow"); return retval; } #endif #endif #ifdef NO_XSLOCKS # ifdef dJMPENV # define dXCPT dJMPENV; int rEtV = 0 # define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0) # define XCPT_TRY_END JMPENV_POP; # define XCPT_CATCH if (rEtV != 0) # define XCPT_RETHROW JMPENV_JUMP(rEtV) # else # define dXCPT Sigjmp_buf oldTOP; int rEtV = 0 # define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0) # define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf); # define XCPT_CATCH if (rEtV != 0) # define XCPT_RETHROW Siglongjmp(top_env, rEtV) # endif #endif #if !defined(my_strlcat) #if defined(NEED_my_strlcat) static Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); static #else extern Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); #endif #define my_strlcat DPPP_(my_my_strlcat) #define Perl_my_strlcat DPPP_(my_my_strlcat) #if defined(NEED_my_strlcat) || defined(NEED_my_strlcat_GLOBAL) Size_t DPPP_(my_my_strlcat)(char *dst, const char *src, Size_t size) { Size_t used, length, copy; used = strlen(dst); length = strlen(src); if (size > 0 && used < size - 1) { copy = (length >= size - used) ? size - used - 1 : length; memcpy(dst + used, src, copy); dst[used + copy] = '\0'; } return used + length; } #endif #endif #if !defined(my_strlcpy) #if defined(NEED_my_strlcpy) static Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); static #else extern Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); #endif #define my_strlcpy DPPP_(my_my_strlcpy) #define Perl_my_strlcpy DPPP_(my_my_strlcpy) #if defined(NEED_my_strlcpy) || defined(NEED_my_strlcpy_GLOBAL) Size_t DPPP_(my_my_strlcpy)(char *dst, const char *src, Size_t size) { Size_t length, copy; length = strlen(src); if (size > 0) { copy = (length >= size) ? size - 1 : length; memcpy(dst, src, copy); dst[copy] = '\0'; } return length; } #endif #endif #endif /* _P_P_PORTABILITY_H_ */ /* End of File ppport.h */ PDL-2.074/Basic/Core/pdlthread.c0000644000175000017500000005461314200151254016122 0ustar osboxesosboxes/* XXX NOTE THAT IT IS NOT SAFE TO USE ->pdls MEMBER OUTSIDE INITTHREADSTRUCT! */ #include "pdl.h" /* Data structure declarations */ #include "pdlcore.h" /* Core declarations */ #define MAX2(a,b) if((b)>(a)) a=b; /**** Convenience routines for moving around collections **** of indices and PDL pointers. ****/ static pdl **copy_pdl_array (pdl **from, int size) { pdl **to; Newx (to, size, pdl*); return (pdl **) CopyD (from, to, size, pdl*); } /******* * pdl_get_threaddims - get the pthread-specific threading dims from a PDL * Input: thread structure * Outputs: see above (returned by function) */ PDL_Indx *pdl_get_threaddims(pdl_thread *thread) { /* The non-multithreaded case: return just the usual value */ if (!(thread->gflags & PDL_THREAD_MAGICKED)) return thread->dims; int thr = pdl_magic_get_thread(thread->pdls[thread->mag_nthpdl]); if (thr < 0) return NULL; return thread->dims + thr * thread->ndims; } /******* * pdl_get_threadoffsp - get the pthread-specific offset arrays from a PDL * Input: thread structure * Outputs: Pointer to pthread-specific offset array (returned by function) */ PDL_Indx *pdl_get_threadoffsp(pdl_thread *thread) { /* The non-multithreaded case: return just the usual offsets */ if (!(thread->gflags & PDL_THREAD_MAGICKED)) return thread->offs; int thr = pdl_magic_get_thread(thread->pdls[thread->mag_nthpdl]); if (thr < 0) return NULL; return thread->offs + thr * thread->npdls; } /* Function to get the pthread-specific offset, indexes and pthread number for the supplied thread structure Input: thread structure Outputs: Pointer to pthread-specific offset array (returned by function) Pointer to pthread-specific index array (ind Pointer supplied and modified by function) Pointer to pthread-specific dims array (dims Pointer supplied and modified by function) Pthread index for the current pthread ( thr supplied and modified by function) */ PDL_Indx* pdl_get_threadoffsp_int(pdl_thread *thread, int *pthr, PDL_Indx **inds, PDL_Indx **dims) { if(thread->gflags & PDL_THREAD_MAGICKED) { int thr = pdl_magic_get_thread(thread->pdls[thread->mag_nthpdl]); if (thr < 0) return NULL; *pthr = thr; *inds = thread->inds + thr * thread->ndims; *dims = thread->dims + thr * thread->ndims; return thread->offs + thr * thread->npdls; } *pthr = 0; /* The non-multithreaded case: return just the usual offsets */ *dims = thread->dims; *inds = thread->inds; return thread->offs; } void pdl_freethreadstruct(pdl_thread *thread) { PDLDEBUG_f(printf("freethreadstruct(%p, %p %p %p %p %p %p)\n", (void*)thread, (void*)(thread->inds), (void*)(thread->dims), (void*)(thread->offs), (void*)(thread->incs), (void*)(thread->flags), (void*)(thread->pdls))); if(!thread->inds) {return;} Safefree(thread->inds); Safefree(thread->dims); Safefree(thread->offs); Safefree(thread->incs); Safefree(thread->flags); Safefree(thread->pdls); pdl_clearthreadstruct(thread); } void pdl_clearthreadstruct(pdl_thread *it) { PDLDEBUG_f(printf("clearthreadstruct(%p)\n", (void*)it)); it->transvtable = 0;it->inds = 0;it->dims = 0; it->ndims = it->nimpl = it->npdls = 0; it->offs = 0; it->pdls = 0;it->incs = 0; it->realdims=0; it->flags=0; it->gflags=0; /* unsets PDL_THREAD_INITIALIZED among others */ PDL_THR_CLRMAGIC(it); } pdl_error pdl_find_max_pthread( pdl **pdls, int npdls, PDL_Indx* realdims, PDL_Indx* creating, int target_pthread, int *p_maxPthread, /* Maximum achievable pthread */ int *p_maxPthreadDim, /* Threaded dim number that has the max num pthreads */ int *p_maxPthreadPDL /* PDL that has the max (or right at the target) num pthreads */ ) { pdl_error PDL_err = {0, NULL, 0}; PDL_Indx j, k, t; /* Build int arrays of threaded dim numbers and sizes for each pdl */ PDL_Indx max_remainder = 0; PDL_Indx nthreadedDims[npdls]; PDL_Indx *threadedDims[npdls]; PDL_Indx *threadedDimSizes[npdls]; for(j=0; jndims); if (!threadedDims[j]) return pdl_make_error_simple(PDL_EFATAL, "Out of Memory\n"); threadedDimSizes[j] = (PDL_Indx*) malloc(sizeof(PDL_Indx) * pdls[j]->ndims); if (!threadedDimSizes[j]) return pdl_make_error_simple(PDL_EFATAL, "Out of Memory\n"); } for(j=0; jndims; t++, k++ ){ threadedDimSizes[j][k] = pdls[j]->dims[t]; threadedDims[j][k] = t; } nthreadedDims[j] = pdls[j]->ndims - realdims[j]; } /* Go through each threaded dim and find best match */ *p_maxPthread = 0; for(j=0; j *p_maxPthread && this_remainder > max_remainder ){ max_remainder = this_remainder; *p_maxPthread = PDLMIN(target_pthread, this_dim); *p_maxPthreadPDL = j; *p_maxPthreadDim = threadedDims[j][k]; } } /* Don't go any further if target pthread achieved */ if( *p_maxPthread == target_pthread ) break; } PDLDEBUG_f(pdl_dump_threading_info( npdls, creating, target_pthread, nthreadedDims, threadedDims, threadedDimSizes, *p_maxPthreadPDL, *p_maxPthreadDim, *p_maxPthread )); /* Free the stuff we allocated */ for(j=0; jmagic && (pdl_magic_thread_nthreads(pdls[j],&nthrd))) { PDL_RETERROR(PDL_err, pdl_add_threading_magic(pdls[j], -1, -1)); } } if( noPthreadFlag ) return PDL_err; /* Don't go further if the current pdl function isn't thread-safe */ /* Find the largest nvals */ for(j=0; jnvals > largest_nvals ){ largest_nvals = pdls[j]->nvals; } } /* See if the largest nvals is above the auto_pthread threadshold */ largest_nvals = largest_nvals>>20; /* Convert to MBytes */ /* Don't do anything if we are lower than the threshold */ if( largest_nvals < pdl_autopthread_size ) return PDL_err; PDL_RETERROR(PDL_err, pdl_find_max_pthread( pdls, npdls, realdims, creating, target_pthread, &maxPthread, &maxPthreadDim, &maxPthreadPDL )); /* Add threading magic */ if( maxPthread > 1 ){ PDL_RETERROR(PDL_err, pdl_add_threading_magic(pdls[maxPthreadPDL], maxPthreadDim, maxPthread)); pdl_autopthread_actual = maxPthread; /* Set the global variable indicating actual number of pthreads */ pdl_autopthread_dim = maxPthreadDim; } return PDL_err; } pdl_error pdl_dim_checks( pdl_transvtable *vtable, pdl **pdls, pdl_thread *pdlthread, PDL_Indx *creating, PDL_Indx *ind_sizes ) { pdl_error PDL_err = {0, NULL, 0}; PDL_Indx i, j, ind_id; PDLDEBUG_f(printf("pdl_dim_checks %p:\n", ind_sizes); printf(" ind_sizes: "); pdl_print_iarr(ind_sizes, vtable->ninds);printf("\n")); for (i=0; inpdls; i++) { PDL_Indx ninds = vtable->par_realdims[i]; PDLDEBUG_f(printf("pdl_dim_checks pdl %"IND_FLAG" (creating=%"IND_FLAG" ninds=%"IND_FLAG"): ", i, creating[i], ninds)); pdl *pdl = pdls[i]; PDL_Indx ndims = pdl->ndims; PDLDEBUG_f(pdl_dump(pdl)); if (creating[i]) { PDL_Indx dims[PDLMAX(ninds+1, 1)]; for (j=0; jpar_flags[i] & PDL_PARAM_ISTEMP) dims[ninds] = 1; PDL_RETERROR(PDL_err, pdl_thread_create_parameter( pdlthread,i,dims, vtable->par_flags[i] & PDL_PARAM_ISTEMP )); } else { PDL_Indx *dims = pdl->dims; if (pdl->state & PDL_NOMYDIMS) return pdl_make_error(PDL_EUSERERROR, "Error in %s: input parameter '%s' is null\n", vtable->name, vtable->par_names[i] ); if (ninds > 0 && ndims < ninds) { /* Dimensional promotion when number of dims is less than required: */ for (j=0; j j && ind_sizes[ind_id] == 1)) ind_sizes[ind_id] = dims[j]; else if (ndims > j && ind_sizes[ind_id] != dims[j] && dims[j] != 1) return pdl_make_error(PDL_EUSERERROR, "Error in %s: parameter '%s' index %s size %"IND_FLAG", but ndarray dim has size %"IND_FLAG"\n", vtable->name, vtable->par_names[i], vtable->ind_names[ind_id], ind_sizes[ind_id], dims[j] ); } if (vtable->par_flags[i] & PDL_PARAM_ISPHYS) PDL_RETERROR(PDL_err, pdl_make_physical(pdl)); } } for (i=0; inpdls; i++) { PDL_Indx ninds = vtable->par_realdims[i]; short flags = vtable->par_flags[i]; if (!ninds || !(flags & PDL_PARAM_ISPHYS)) continue; pdl *pdl = pdls[i]; PDL_Indx *dims = pdl->dims; for (j=0; j 1 && ind_sizes[ind_id] != dims[j]) return pdl_make_error(PDL_EUSERERROR, "Error in %s: [phys] parameter '%s' index '%s' size %"IND_FLAG", but ndarray dim has size %"IND_FLAG"\n", vtable->name, vtable->par_names[i], vtable->ind_names[ind_id], ind_sizes[ind_id], dims[j] ); } } PDLDEBUG_f(printf("pdl_dim_checks after:\n"); printf(" ind_sizes: "); pdl_print_iarr(ind_sizes, vtable->ninds); printf("\n")); return PDL_err; } /* The assumptions this function makes: * pdls is dynamic and may go away -> copied * realdims is static and is NOT copied and NOT freed!!! * creating is only used inside this routine. * vtable is assumed static. * usevaffine is assumed static. (uses if exists) * * Only the first thread-magicked pdl is taken into account. * * noPthreadFlag is a flag to indicate the pdl thread is not pthreading safe * (i.e. don't attempt to create multiple posix threads to execute) */ pdl_error pdl_initthreadstruct(int nobl, pdl **pdls,PDL_Indx *realdims,PDL_Indx *creating,PDL_Indx npdls, pdl_transvtable *vtable,pdl_thread *thread, PDL_Indx *ind_sizes, PDL_Indx *inc_sizes, char *flags, int noPthreadFlag ) { pdl_error PDL_err = {0, NULL, 0}; PDL_Indx i, j; PDL_Indx ndims=0; PDL_Indx nth; /* Index to dimensions */ PDL_Indx mx, nids, nimpl, nthid; PDL_Indx mydim; PDL_Indx nthr = 0; PDL_Indx nthrd; PDLDEBUG_f(printf("initthreadstruct(%p)\n", (void*)thread)); char already_alloced = (thread->magicno == PDL_THR_MAGICNO && thread->gflags & PDL_THREAD_INITIALIZED); PDL_Indx already_nthr = already_alloced ? thread->mag_nthr : -1; PDL_Indx already_ndims = already_alloced ? thread->ndims : -1; PDL_THR_SETMAGIC(thread); thread->gflags = 0; thread->npdls = npdls; thread->realdims = realdims; thread->transvtable = vtable; /* Accumulate the maximum number of thread dims across the collection of PDLs */ nids=mx=0; for(j=0; jnthreadids); MAX2(mx,pdls[j]->threadids[0] - realdims[j]); } ndims += thread->nimpl = nimpl = mx; PDL_RETERROR(PDL_err, pdl_autopthreadmagic(pdls, npdls, realdims, creating, noPthreadFlag)); thread->mag_nth = -1; thread->mag_nthpdl = -1; thread->mag_nthr = -1; PDL_Indx nthreadids[nids]; for(j=0; jmagic && (nthr = pdl_magic_thread_nthreads(pdls[j],&nthrd))) { thread->mag_nthpdl = j; thread->mag_nth = nthrd - realdims[j]; thread->mag_nthr = nthr; if(thread->mag_nth < 0) { return pdl_croak_param(vtable,j,"Cannot magick non-threaded dims \n\t"); } } for(i=0; inthreadids <= nids ? pdls[j]->threadids[i+1] - pdls[j]->threadids[i] : 0); } } if(nthr) { thread->gflags |= PDL_THREAD_MAGICKED; } ndims += thread->nextra = PDLMAX(0, nobl - ndims); /* If too few, add enough implicit dims */ thread->ndims = ndims; thread->nimpl = nimpl; PDL_Indx nthr1 = PDLMAX(nthr, 1); if (!already_alloced || already_nthr != nthr1 || ndims != already_ndims) { if (already_alloced) { Safefree(thread->inds); Safefree(thread->dims); Safefree(thread->offs); } Newxz(thread->inds, ndims * nthr1, PDL_Indx); /* Create space for pthread-specific inds (i.e. copy for each pthread)*/ if(thread->inds == NULL) return pdl_make_error_simple(PDL_EFATAL, "Failed to allocate memory for thread->inds in pdlthread.c"); Newxz(thread->dims, ndims * nthr1, PDL_Indx); if(thread->dims == NULL) return pdl_make_error_simple(PDL_EFATAL, "Failed to allocate memory for thread->dims in pdlthread.c"); Newxz(thread->offs, npdls * nthr1, PDL_Indx); /* Create space for pthread-specific offs */ if(thread->offs == NULL) return pdl_make_error_simple(PDL_EFATAL, "Failed to allocate memory for thread->offs in pdlthread.c"); } for(nth=0; nthdims[nth]=1; // all start size 1 if (!already_alloced) { thread->pdls = copy_pdl_array(pdls,npdls); Newxz(thread->incs, ndims * npdls, PDL_Indx); if(thread->incs == NULL) return pdl_make_error_simple(PDL_EFATAL, "Failed to allocate memory for thread->incs in pdlthread.c"); Newxz(thread->flags, npdls, char); if(thread->flags == NULL) return pdl_make_error_simple(PDL_EFATAL, "Failed to allocate memory for thread->flags in pdlthread.c"); } /* populate the per_pdl_flags */ for (i=0;iflags[i] |= PDL_THREAD_VAFFINE_OK; if (vtable && vtable->par_flags[i] & PDL_PARAM_ISTEMP) thread->flags[i] |= PDL_THREAD_TEMP; } flags = thread->flags; /* shortcut for the remainder */ /* Make implicit inds */ for(nth=0; nththreadids[0]- // If we're off the end of the current PDLs dimlist, realdims[j] <= nth) // then just skip it. continue; if(pdls[j]->dims[nth+realdims[j]] != 1) { // If the current dim in the current PDL is not 1, if(thread->dims[nth] != 1) { // ... and the current planned size isn't 1, if(thread->dims[nth] != pdls[j]->dims[nth+realdims[j]]) { // ... then check to make sure they're the same. char buf0[BUFSIZ]; buf0[0] = '\0'; pdl_thread_mismatch_msg( buf0, pdls, thread, nth, j, nimpl, realdims, creating ); return pdl_croak_param(vtable,j,"%s\n..",buf0); } /* If we're still here, they're the same -- OK! */ } else { // current planned size is 1 -- mod it to match this PDL thread->dims[nth] = pdls[j]->dims[nth+realdims[j]]; } PDL_THR_INC(thread->incs, npdls, j, nth) = // Update the corresponding data stride PDL_TREPRINC(pdls[j],flags[j],nth+realdims[j]);// from the PDL or from its vafftrans if relevant. } } } /* Go through everything again and make the real things */ for(nthid=0; nthidincs, npdls, j, nth) = pdls[j]->dimincs[pdls[j]->ndims-1]; if(creating[j]) continue; if(pdls[j]->nthreadids < nthid) continue; if(pdls[j]->threadids[nthid+1]- pdls[j]->threadids[nthid] <= i) continue; mydim = i+pdls[j]->threadids[nthid]; if(pdls[j]->dims[mydim] != 1) { if(thread->dims[nth] != 1) { if(thread->dims[nth] != pdls[j]->dims[mydim]) { return pdl_croak_param(vtable,j,"Mismatched Implicit thread dimension %d: should be %d, is %d", i, thread->dims[nth], pdls[j]->dims[i+realdims[j]]); } } else { thread->dims[nth] = pdls[j]->dims[mydim]; } PDL_THR_INC(thread->incs, npdls, j, nth) = PDL_TREPRINC(pdls[j],flags[j],mydim); } } nth++; } } /* If threading, make the true offsets and dims.. */ thread->mag_skip = 0; thread->mag_stride = 0; if(nthr > 0) { int n1 = thread->dims[thread->mag_nth] / nthr; int n2 = thread->dims[thread->mag_nth] % nthr; thread->mag_stride = n1; if(n2) { n1++; thread->mag_skip = n2; } thread->dims[thread->mag_nth] = n1; for(i=1; idims[j + i*ndims] = thread->dims[j]; if (n2) for(i=n2; idims[thread->mag_nth + i*ndims]--; } if (ind_sizes) PDL_RETERROR(PDL_err, pdl_dim_checks(vtable, pdls, thread, creating, ind_sizes)); if (inc_sizes) for (i=0; inpdls; i++) { pdl *pdl = pdls[i]; for (j=0; jpar_realdims[i]; j++) inc_sizes[PDL_INC_ID(vtable,i,j)] = (pdl->ndims <= j || pdl->dims[j] <= 1) ? 0 : (vtable->par_flags[i] & PDL_PARAM_ISPHYS) ? pdl->dimincs[j] : PDL_REPRINC(pdl,j); } thread->gflags |= PDL_THREAD_INITIALIZED; PDLDEBUG_f(pdl_dump_thread(thread)); return PDL_err; } pdl_error pdl_thread_create_parameter(pdl_thread *thread, PDL_Indx j,PDL_Indx *dims, int temp) { pdl_error PDL_err = {0, NULL, 0}; PDL_Indx i; PDL_Indx td = temp ? 0 : thread->nimpl; if(!temp && thread->nimpl != thread->ndims - thread->nextra) { return pdl_croak_param(thread->transvtable,j, "Trying to create parameter while explicitly threading.\ See the manual for why this is impossible"); } if (!thread->pdls[j] && !(thread->pdls[j] = pdl_pdlnew())) return pdl_make_error_simple(PDL_EFATAL, "Error in pdlnew"); PDL_RETERROR(PDL_err, pdl_reallocdims(thread->pdls[j], thread->realdims[j] + td + (temp ? 1 : 0))); for(i=0; irealdims[j] + (temp ? 1 : 0); i++) thread->pdls[j]->dims[i] = dims[i]; if (!temp) for(i=0; inimpl; i++) thread->pdls[j]->dims[i+thread->realdims[j]] = (i == thread->mag_nth && thread->mag_nthr > 0) ? PDL_THR_OFFSET(thread->mag_nthr, thread) : thread->dims[i]; thread->pdls[j]->threadids[0] = td + thread->realdims[j]; pdl_resize_defaultincs(thread->pdls[j]); for(i=0; inimpl; i++) { PDL_THR_INC(thread->incs, thread->npdls, j, i) = temp ? 0 : PDL_REPRINC(thread->pdls[j],i+thread->realdims[j]); } return PDL_err; } int pdl_startthreadloop(pdl_thread *thread,pdl_error (*func)(pdl_trans *), pdl_trans *t, pdl_error *error_ret) { PDL_Indx j, npdls = thread->npdls; PDL_Indx *offsp; int thr; PDL_Indx *inds, *dims; if( (thread->gflags & (PDL_THREAD_MAGICKED | PDL_THREAD_MAGICK_BUSY)) == PDL_THREAD_MAGICKED ) { /* If no function supplied (i.e. being called from PDL::thread_over), don't run in parallel */ if(!func) { thread->gflags &= ~PDL_THREAD_MAGICKED; /* Cancel thread_magicked */ } else{ thread->gflags |= PDL_THREAD_MAGICK_BUSY; /* Do the threadloop magically (i.e. in parallel) */ for(j=0; jvtable->par_flags[j] & PDL_PARAM_ISTEMP)) continue; pdl *it = thread->pdls[j]; it->dims[it->ndims-1] = thread->mag_nthr; pdl_resize_defaultincs(it); pdl_error PDL_err = pdl_make_physical(it); if (PDL_err.error) { *error_ret = PDL_err; return 1; } } pdl_error PDL_err = pdl_magic_thread_cast(thread->pdls[thread->mag_nthpdl], func,t, thread); if (PDL_err.error) { *error_ret = PDL_err; return 1; } thread->gflags &= ~PDL_THREAD_MAGICK_BUSY; return 1; /* DON'T DO THREADLOOP AGAIN */ } } offsp = pdl_get_threadoffsp_int(thread,&thr, &inds, &dims); if (!offsp) return -1; for(j=0; jpdls[j],thread->flags[j]); } if (thr) for(j=0; jflags[j]) ? thr * thread->pdls[j]->dimincs[thread->pdls[j]->ndims-1] : PDL_THR_OFFSET(thr, thread) * PDL_THR_INC(thread->incs, thread->npdls, j, thread->mag_nth); return 0; } /* nth is how many dims are done inside the threadloop itself */ /* inds is how far along each non-threadloop dim we are */ int pdl_iterthreadloop(pdl_thread *thread,PDL_Indx nth) { PDL_Indx i,j; int another_threadloop = 0; PDL_Indx *offsp; int thr; PDL_Indx *inds, *dims; offsp = pdl_get_threadoffsp_int(thread,&thr, &inds, &dims); if (!offsp) return -1; for(i=nth; indims; i++) { inds[i] ++; if( inds[i] >= dims[i]) inds[i] = 0; else { another_threadloop = 1; break; } } if (another_threadloop) for(j=0; jnpdls; j++) { offsp[j] = PDL_TREPROFFS(thread->pdls[j],thread->flags[j]); if (thr) offsp[j] += PDL_TISTEMP(thread->flags[j]) ? thr * thread->pdls[j]->dimincs[thread->pdls[j]->ndims-1] : PDL_THR_OFFSET(thr, thread) * PDL_THR_INC(thread->incs, thread->npdls, j, thread->mag_nth); for(i=nth; indims; i++) { offsp[j] += PDL_THR_INC(thread->incs, thread->npdls, j, i) * inds[i]; } } return another_threadloop; } PDL-2.074/Basic/Core/pdlaffine.c0000644000175000017500000003017214172737500016111 0ustar osboxesosboxes#include "pdl.h" #define PDL_IN_CORE #include "pdlcore.h" #define PDL_ALL_GENTYPES { PDL_SB, PDL_B, PDL_S, PDL_US, PDL_L, PDL_UL, PDL_IND, PDL_ULL, PDL_LL, PDL_F, PDL_D, PDL_LD, PDL_CF, PDL_CD, PDL_CLD, -1 } /* generated from: pp_def( 'affineinternal', HandleBad => 1, AffinePriv => 1, P2Child => 1, ReadDataFuncName => "pdl_readdata_affineinternal", WriteBackDataFuncName => "pdl_writebackdata_affineinternal", EquivCPOffsCode => ' if ($PDL(CHILD)->state & $PDL(PARENT)->state & PDL_ALLOCATED) { PDL_Indx i, poffs=$PRIV(offs), nd; for(i=0; i<$PDL(CHILD)->nvals; i++) { $EQUIVCPOFFS(i,poffs); for(nd=0; nd<$PDL(CHILD)->ndims; nd++) { poffs += $PRIV(incs[nd]); if( (nd<$PDL(CHILD)->ndims-1 && (i+1)%$PDL(CHILD)->dimincs[nd+1]) || nd == $PDL(CHILD)->ndims-1) break; poffs -= $PRIV(incs[nd]) * $PDL(CHILD)->dims[nd]; } } }', Doc => undef, # 'internal', ); */ #define COPYDATA(ctype, from_id, to_id) \ PDL_DECLARE_PARAMETER_BADVAL(ctype, (trans->vtable->per_pdl_flags[to_id]), to_pdl, (trans->pdls[to_id])) \ PDL_DECLARE_PARAMETER_BADVAL(ctype, (trans->vtable->per_pdl_flags[from_id]), from_pdl, (trans->pdls[from_id])) \ PDL_Indx i, poffs=trans->offs, nd; \ for (i=0; ipdls[to_id]->nvals ; i++) { \ to_pdl_physdatap[i] = (trans->bvalflag && from_pdl_physdatap[poffs] == from_pdl_badval) \ ? to_pdl_badval : from_pdl_physdatap[poffs]; \ for (nd=0; ndpdls[to_id]->ndims ; nd++) { \ poffs += trans->incs[nd]; \ if ((ndpdls[to_id]->ndims -1 && \ (i+1)%trans->pdls[to_id]->dimincs[nd+1]) || \ nd == trans->pdls[to_id]->ndims -1) \ break; \ poffs -= trans->incs[nd] * trans->pdls[to_id]->dims[nd]; \ } \ } pdl_error pdl_readdata_affine(pdl_trans *trans) { pdl_error PDL_err = {0, NULL, 0}; if (!(trans->pdls[0]->state & trans->pdls[1]->state & PDL_ALLOCATED)) return PDL_err; #define X(sym, ctype, ...) COPYDATA(ctype, 0, 1) PDL_GENERICSWITCH(PDL_TYPELIST2_ALL, trans->__datatype, X, return pdl_make_error(PDL_EUSERERROR, "Not a known data type code=%d", trans->__datatype)) #undef X return PDL_err; } pdl_error pdl_writebackdata_affine(pdl_trans *trans) { pdl_error PDL_err = {0, NULL, 0}; if (!(trans->pdls[0]->state & trans->pdls[1]->state & PDL_ALLOCATED)) return PDL_err; #define X(sym, ctype, ...) COPYDATA(ctype, 1, 0) PDL_GENERICSWITCH(PDL_TYPELIST2_ALL, trans->__datatype, X, return pdl_make_error(PDL_EUSERERROR, "Not a known data type code=%d", trans->__datatype)) #undef X return PDL_err; } /* generated from: pp_def( 'affine', P2Child => 1, TwoWay => 1, AffinePriv => 1, GlobalNew => 'affine_new', OtherPars => 'PDL_Indx offspar; PDL_Indx dims[]; PDL_Indx incs[]', Comp => 'PDL_Indx nd; PDL_Indx offset; PDL_Indx sdims[$COMP(nd)]; PDL_Indx sincs[$COMP(nd)];', MakeComp => ' PDL_Indx i = 0; $COMP(nd) = dims_count; if ($COMP(nd) < 0) $CROAK("Affine: can not have negative no of dims"); if ($COMP(nd) != incs_count) $CROAK("Affine: number of incs does not match dims"); $DOCOMPALLOC(); $COMP(offset) = offspar; for (i=0; i<$COMP(nd); i++) { $COMP(sdims)[i] = dims[i]; $COMP(sincs)[i] = incs[i]; } ', RedoDims => ' PDL_Indx i; $SETNDIMS($COMP(nd)); $DOPRIVALLOC(); $PRIV(offs) = $COMP(offset); for (i=0;i<$CHILD(ndims);i++) { $PRIV(incs)[i] = $COMP(sincs)[i]; $CHILD(dims)[i] = $COMP(sdims)[i]; } $SETDIMS(); ', Doc => undef, ); */ typedef struct pdl_params_affine { PDL_Indx nd; PDL_Indx offset; PDL_Indx *sdims; PDL_Indx *sincs; } pdl_params_affine; pdl_error pdl_affine_redodims(pdl_trans *trans) { pdl_error PDL_err = {0, NULL, 0}; pdl_params_affine *params = trans->params; pdl *__it = trans->pdls[1]; pdl_hdr_childcopy(trans); PDL_Indx i; PDL_RETERROR(PDL_err, pdl_reallocdims(__it, params->nd)); trans->incs = malloc(sizeof(*trans->incs) * trans->pdls[1]->ndims); if (!trans->incs) return pdl_make_error_simple(PDL_EFATAL, "Out of Memory\n"); trans->offs = params->offset; for (i=0;ipdls[1]->ndims;i++) { trans->incs[i] = params->sincs[i]; trans->pdls[1]->dims[i] = params->sdims[i]; } PDL_RETERROR(PDL_err, pdl_setdims_careful(__it)); trans->dims_redone = 1; return PDL_err; } pdl_error pdl_affine_free(pdl_trans *trans, char destroy) { pdl_error PDL_err = {0, NULL, 0}; pdl_params_affine *params = trans->params; if (destroy) { free(params->sdims); free(params->sincs); } if ((trans)->dims_redone) free(trans->incs); return PDL_err; } static pdl_datatypes pdl_affine_vtable_gentypes[] = PDL_ALL_GENTYPES; static char pdl_affine_vtable_flags[] = { PDL_TPDL_VAFFINE_OK, PDL_TPDL_VAFFINE_OK }; static PDL_Indx pdl_affine_vtable_realdims[] = { 0, 0 }; static char *pdl_affine_vtable_parnames[] = { "PARENT","CHILD" }; static short pdl_affine_vtable_parflags[] = { 0, PDL_PARAM_ISCREAT|PDL_PARAM_ISCREATEALWAYS|PDL_PARAM_ISOUT|PDL_PARAM_ISWRITE }; static pdl_datatypes pdl_affine_vtable_partypes[] = { -1, -1 }; static PDL_Indx pdl_affine_vtable_realdims_starts[] = { 0, 0 }; static PDL_Indx pdl_affine_vtable_realdims_ind_ids[] = { 0 }; static char *pdl_affine_vtable_indnames[] = { "" }; pdl_transvtable pdl_affine_vtable = { 0, PDL_ITRANS_ISAFFINE|PDL_ITRANS_TWOWAY|PDL_ITRANS_DO_DATAFLOW_ANY, pdl_affine_vtable_gentypes, 1, 2, pdl_affine_vtable_flags, pdl_affine_vtable_realdims, pdl_affine_vtable_parnames, pdl_affine_vtable_parflags, pdl_affine_vtable_partypes, pdl_affine_vtable_realdims_starts, pdl_affine_vtable_realdims_ind_ids, 0, 0, pdl_affine_vtable_indnames, pdl_affine_redodims, NULL, NULL, pdl_affine_free, sizeof(pdl_params_affine),"affine_new" }; pdl_error pdl_affine_new(pdl *PARENT,pdl *CHILD,PDL_Indx offspar,PDL_Indx *dims,PDL_Indx dims_count, PDL_Indx *incs, PDL_Indx incs_count) { pdl_error PDL_err = {0, NULL, 0}; pdl_trans *trans = (void *)pdl_create_trans(&pdl_affine_vtable); pdl_params_affine *params = trans->params; trans->pdls[0] = PARENT; trans->pdls[1] = CHILD; PDL_RETERROR(PDL_err, pdl_trans_check_pdls(trans)); char badflag_cache = pdl_trans_badflag_from_inputs((pdl_trans *)trans); pdl_type_coerce((pdl_trans *)trans); PARENT = trans->pdls[0]; CHILD = trans->pdls[1]; PDL_Indx i = 0; params->nd = dims_count; if (params->nd < 0) return pdl_make_error_simple(PDL_EUSERERROR, "Error in affine: can not have negative no of dims"); if (params->nd != incs_count) return pdl_make_error_simple(PDL_EUSERERROR, "Error in affine: number of incs does not match dims"); params->sdims = malloc(sizeof(* params->sdims) * params->nd); if (!params->sdims) return pdl_make_error_simple(PDL_EFATAL, "Out of Memory\n"); params->sincs = malloc(sizeof(* params->sincs) * params->nd); if (!params->sincs) return pdl_make_error_simple(PDL_EFATAL, "Out of Memory\n"); params->offset = offspar; for (i=0; ind; i++) { params->sdims[i] = dims[i]; params->sincs[i] = incs[i]; } PDL_RETERROR(PDL_err, pdl_make_trans_mutual((pdl_trans *)trans)); if (badflag_cache) CHILD->state |= PDL_BADVAL; return PDL_err; } /* generated from: pp_def( 'converttypei', GlobalNew => 'converttypei_new', OtherPars => 'int totype;', Identity => 1, # Forced types FTypes => {CHILD => '$COMP(totype)'}, Doc => 'internal', ); */ typedef struct pdl_params_converttypei { int totype; } pdl_params_converttypei; pdl_error pdl_converttypei_redodims(pdl_trans *trans) { pdl_error PDL_err = {0, NULL, 0}; pdl *__it = trans->pdls[1]; pdl_hdr_childcopy(trans); PDL_Indx i; PDL_RETERROR(PDL_err, pdl_reallocdims(__it, trans->pdls[0]->ndims)); for (i=0; ipdls[1]->ndims; i++) trans->pdls[1]->dims[i] = trans->pdls[0]->dims[i]; PDL_RETERROR(PDL_err, pdl_setdims_careful(__it)); pdl_reallocthreadids(trans->pdls[1], trans->pdls[0]->nthreadids); for (i=0; ipdls[0]->nthreadids; i++) trans->pdls[1]->threadids[i] = trans->pdls[0]->threadids[i]; trans->dims_redone = 1; return PDL_err; } #define COPYCONVERT(from_pdl, to_pdl) \ { \ PDL_Indx i; \ for(i=0; ipdls[1]->nvals; i++) { \ to_pdl ## _physdatap[i] = trans->bvalflag && from_pdl ## _physdatap[i] == from_pdl ## _badval \ ? to_pdl ## _badval \ : from_pdl ## _physdatap[i]; \ ; \ } \ } pdl_error pdl_converttypei_readdata(pdl_trans *trans) { pdl_error PDL_err = {0, NULL, 0}; pdl_params_converttypei *params = trans->params; #define X_OUTER(datatype_out, ctype_out, ...) \ PDL_DECLARE_PARAMETER_BADVAL(ctype_out, (trans->vtable->per_pdl_flags[1]), CHILD, (trans->pdls[1])) \ PDL_GENERICSWITCH2(PDL_TYPELIST2_ALL_, trans->__datatype, X_INNER, return pdl_make_error(PDL_EUSERERROR, "Not a known data type code=%d", trans->__datatype)) #define X_INNER(datatype_in, ctype_in, ...) \ PDL_DECLARE_PARAMETER_BADVAL(ctype_in, (trans->vtable->per_pdl_flags[0]), PARENT, (trans->pdls[0])) \ COPYCONVERT(PARENT, CHILD) PDL_GENERICSWITCH(PDL_TYPELIST2_ALL, params->totype, X_OUTER, return pdl_make_error(PDL_EUSERERROR, "Not a known data type code=%d", params->totype)) #undef X_INNER return PDL_err; } pdl_error pdl_converttypei_writebackdata(pdl_trans *trans) { pdl_error PDL_err = {0, NULL, 0}; pdl_params_converttypei *params = trans->params; #define X_INNER(datatype_in, ctype_in, ...) \ PDL_DECLARE_PARAMETER_BADVAL(ctype_in, (trans->vtable->per_pdl_flags[0]), PARENT, (trans->pdls[0])) \ COPYCONVERT(CHILD, PARENT) PDL_GENERICSWITCH(PDL_TYPELIST2_ALL, params->totype, X_OUTER, return pdl_make_error(PDL_EUSERERROR, "Not a known data type code=%d", params->totype)) #undef X_INNER #undef X_OUTER return PDL_err; } static pdl_datatypes pdl_converttypei_vtable_gentypes[] = PDL_ALL_GENTYPES; static char pdl_converttypei_vtable_flags[] = { 0, 0 }; static PDL_Indx pdl_converttypei_vtable_realdims[] = { 0, 0 }; static char *pdl_converttypei_vtable_parnames[] = { "PARENT","CHILD" }; static short pdl_converttypei_vtable_parflags[] = { 0, PDL_PARAM_ISCREAT|PDL_PARAM_ISCREATEALWAYS|PDL_PARAM_ISIGNORE|PDL_PARAM_ISOUT|PDL_PARAM_ISWRITE }; static pdl_datatypes pdl_converttypei_vtable_partypes[] = { -1, -1 }; static PDL_Indx pdl_converttypei_vtable_realdims_starts[] = { 0, 0 }; static PDL_Indx pdl_converttypei_vtable_realdims_ind_ids[] = { 0 }; static char *pdl_converttypei_vtable_indnames[] = { "" }; pdl_transvtable pdl_converttypei_vtable = { PDL_TRANS_BADPROCESS, PDL_ITRANS_TWOWAY|PDL_ITRANS_DO_DATAFLOW_ANY, pdl_converttypei_vtable_gentypes, 1, 2, pdl_converttypei_vtable_flags, pdl_converttypei_vtable_realdims, pdl_converttypei_vtable_parnames, pdl_converttypei_vtable_parflags, pdl_converttypei_vtable_partypes, pdl_converttypei_vtable_realdims_starts, pdl_converttypei_vtable_realdims_ind_ids, 0, 0, pdl_converttypei_vtable_indnames, pdl_converttypei_redodims, pdl_converttypei_readdata, pdl_converttypei_writebackdata, NULL, sizeof(pdl_params_converttypei),"converttypei_new" }; pdl_error pdl_converttypei_new(pdl *PARENT,pdl *CHILD,int totype) { pdl_error PDL_err = {0, NULL, 0}; pdl_trans *trans = (void *)pdl_create_trans(&pdl_converttypei_vtable); pdl_params_converttypei *params = trans->params; trans->pdls[0] = PARENT; trans->pdls[1] = CHILD; PDL_RETERROR(PDL_err, pdl_trans_check_pdls(trans)); char badflag_cache = pdl_trans_badflag_from_inputs((pdl_trans *)trans); pdl_type_coerce((pdl_trans *)trans); PARENT = trans->pdls[0]; CHILD = trans->pdls[1]; CHILD->datatype = params->totype = totype; PDL_RETERROR(PDL_err, pdl_make_trans_mutual((pdl_trans *)trans)); if (badflag_cache) CHILD->state |= PDL_BADVAL; return PDL_err; } PDL-2.074/Basic/Core/Overloads.pm0000644000175000017500000000116614146003631016302 0ustar osboxesosboxespackage PDL::Complex::Overloads; use strict; use warnings; use parent 'Math::Complex'; use overload fallback => 1; sub cplx { bless &Math::Complex::cplx, __PACKAGE__ } =head1 NAME PDL::Complex::Overloads - subclass of Math::Complex with overload fallbacks =head1 SYNOPSIS require PDL::Complex::Overloads; my $same = PDL::Complex::Overloads::cplx(1, 2) eq '1+2i'; =head1 DESCRIPTION This is a subclass whose only purpose is to provide L's overloads but with C true, mainly to allow string-comparison for backwards compatibility. =head1 AUTHOR Ed J =head1 SEE ALSO L =cut 1; PDL-2.074/Basic/Core/Makefile.PL0000644000175000017500000000565614163274143015777 0ustar osboxesosboxesuse strict; use warnings; eval { require Devel::CheckLib; Devel::CheckLib->import; }; use ExtUtils::MakeMaker::Config; use ExtUtils::MakeMaker; my $malloclib = $PDL::Config{MALLOCDBG}->{libs}; my $mallocinc = $PDL::Config{MALLOCDBG}->{include}; my $pthread_include = ''; if ( defined $PDL::Config{POSIX_THREADS_INC} ) { $pthread_include = $PDL::Config{POSIX_THREADS_INC}; } my $pthread_library = '-lpthread'; if ( defined $PDL::Config{POSIX_THREADS_LIBS} ) { $pthread_library = $PDL::Config{POSIX_THREADS_LIBS}; } my $pthread_conf = $PDL::Config{WITH_POSIX_THREADS}; if (defined $pthread_conf and !$pthread_conf) { print "\tpthread disabled in perldl.conf\n"; $pthread_library = ''; } if ($pthread_library) { (my $libname = $pthread_library) =~ s/^-l//; if (!eval { check_lib(lib=>$libname,header=>'pthread.h',incpath=>$pthread_include) }) { print "\tDevel::CheckLib with '$libname' failed\n"; $pthread_library = ''; } } if ($pthread_library) { $PDL::Config{WITH_POSIX_THREADS} = 1; } else { print "PDL will be built without POSIX thread support.\n"; print "\t==> *NOTE*: PDL threads are unrelated to perl threads (usethreads=y)!\n"; print "\t==> Enabling perl threads will not help!\n"; $PDL::Config{WITH_POSIX_THREADS} = 0; } my $pthread_define = $pthread_library ? ' -DPDL_PTHREAD ' : ''; sub nopl { my $txt = shift; $txt =~ s/[.]PL$//; return $txt} my $libs_string = "$pthread_library $malloclib -lm"; undef &MY::postamble; # suppress warning *MY::postamble = sub { join '', map "$_ :: $_.PL Types.pm\n\t\$(PERLRUN) $_.PL $_\n", qw(pdlsimple.h pdl.h pdlperl.h); }; my @cfiles = qw(pdlcore pdlapi pdlthread pdlconv pdlmagic pdlaffine pdlutil); my $cobj = join ' ', map qq{$_\$(OBJ_EXT)}, @cfiles; WriteMakefile( 'NAME' => 'PDL::Core', 'VERSION_FROM' => '../PDL.pm', 'PM' => { (map {($_,'$(INST_LIBDIR)/'.$_)} ( qw/Core.pm Basic.pm Types.pm Dbg.pm Exporter.pm Config.pm Char.pm/ )), (map {($_,'$(INST_LIBDIR)/Core/'.$_)} ( qw/Dev.pm typemap pdl.h pdlperl.h pdlcore.h pdlmagic.h pdlsimple.h pdlthread.h ppport.h/ )), qq/IFiles.pm/,'$(INST_LIBDIR)/Install/Files.pm', (map +($_=>'$(INST_LIBDIR)/Complex/'.$_), qw(Overloads.pm)), }, 'PL_FILES' => {map {($_ => nopl $_)} grep !/^Makefile.PL$/, 'Types.pm.PL'}, 'OBJECT' => 'Core$(OBJ_EXT) ' . $cobj, 'DEFINE' => $pthread_define, 'LIBS' => [$libs_string], 'clean' => {'FILES' => 'pdl.h pdlperl.h pdlsimple.h '. 'Types.pm Core.c ' }, 'INC' => join(' ', PDL::Core::Dev::PDL_INCLUDE(), map {length($_) ? qq{"$_"} : ()} $pthread_include, $mallocinc ), depend => { 'Core$(OBJ_EXT)' => '$(INST_ARCHLIB)$(DFSEP).exists pm_to_blib pdl.h pdlperl.h pdlcore.h', # Core.xs needs blib/arch for -Mblib to work, as well as pm_to_blib $cobj => 'pdl.h pdlcore.h pdlthread.h pdlmagic.h', 'pdlcore$(OBJ_EXT)' => 'pdlperl.h', }, NO_MYMETA => 1, ); PDL-2.074/Basic/Core/pdlperl.h.PL0000644000175000017500000001002214172737500016132 0ustar osboxesosboxesuse strict; use warnings; use Config; # for ivsize require './Types.pm'; my $file = shift @ARGV; print "Extracting $file\n"; open OUT,">$file" or die "Can't create $file: $!"; chmod 0644, $file; print OUT sprintf qq{#line %d "%s"\n}, __LINE__ + 2, __FILE__; print OUT <<'EOF'; /* * THIS FILE IS GENERATED FROM pdlperl.h.PL! Do NOT edit! */ #ifndef __PDLPERL_H #define __PDLPERL_H #define PDL_XS_SCALAR(type, val) \ PDL_Anyval av; \ ANYVAL_FROM_CTYPE(av,type,val); \ pdl *b = pdl_scalar(av); \ if (!b) XSRETURN_UNDEF; \ SV *b_SV = sv_newmortal(); \ pdl_SetSV_PDL(b_SV, b); \ EXTEND(SP, 1); \ ST(0) = b_SV; \ XSRETURN(1); #define PDL_MAKE_PERL_COMPLEX(output,r,i) { \ dSP; int count; double rval = r, ival = i; SV *ret; \ ENTER; SAVETMPS; PUSHMARK(sp); \ perl_require_pv("PDL/Complex/Overloads.pm"); \ mXPUSHn(rval); \ mXPUSHn(ival); \ PUTBACK; \ count = perl_call_pv("PDL::Complex::Overloads::cplx", G_SCALAR); \ SPAGAIN; \ if (count != 1) croak("Failed to create PDL::Complex::Overloads object (%.9g, %.9g)", rval, ival); \ ret = POPs; \ SvREFCNT_inc(ret); \ output = ret; \ PUTBACK; FREETMPS; LEAVE; \ } /*************** * So many ways to be undefined... */ #define PDL_SV_IS_UNDEF(sv) ( (!(sv) || ((sv)==&PL_sv_undef)) || !(SvNIOK(sv) || (SvTYPE(sv)==SVt_PVMG) || SvPOK(sv) || SvROK(sv))) #define ANYVAL_FROM_SV(outany,insv,use_undefval,forced_type) do { \ SV *sv2 = insv; \ if (PDL_SV_IS_UNDEF(sv2)) { \ if (!use_undefval) { \ outany.type = forced_type >=0 ? forced_type : -1; \ outany.value.B = 0; \ break; \ } \ sv2 = get_sv("PDL::undefval",1); \ if(SvIV(get_sv("PDL::debug",1))) \ fprintf(stderr,"Warning: SvPDLV converted undef to $PDL::undefval (%g).\n",SvNV(sv2)); \ if (PDL_SV_IS_UNDEF(sv2)) { \ outany.type = forced_type >=0 ? forced_type : PDL_B; \ outany.value.B = 0; \ break; \ } \ } \ if (sv_derived_from(sv2, "PDL")) { \ pdl *it = PDL_CORE_(SvPDLV)(sv2); \ outany = PDL_CORE_(at0)(it); \ if (outany.type < 0) croak("Position out of range"); \ } else if (!SvIOK(sv2)) { /* Perl Double (e.g. 2.0) */ \ NV tmp_NV = SvNV(sv2); \ int datatype = forced_type >=0 ? forced_type : _pdl_whichdatatype_double(tmp_NV); \ ANYVAL_FROM_CTYPE(outany, datatype, tmp_NV); \ } else { /* Perl Int (e.g. 2) */ \ IV tmp_IV = SvIV(sv2); \ int datatype = forced_type >=0 ? forced_type : _pdl_whichdatatype(tmp_IV); \ ANYVAL_FROM_CTYPE(outany, datatype, tmp_IV); \ } \ } while (0) #define ANYVAL_TO_SV(outsv,inany) do { switch (inany.type) { \ EOF for (PDL::Types::types()) { print OUT "case @{[$_->sym]}: "; if ($_->real) { my $upper = uc(my $letter = $_->integer ? 'i' : 'n'); print OUT "outsv = newSV${letter}v( (${upper}V)(inany.value.".$_->ppsym.") )"; } else { my ($fs, $ppsym) = ($_->floatsuffix, $_->ppsym); print OUT "PDL_MAKE_PERL_COMPLEX(outsv, creal$fs(inany.value.$ppsym), cimag$fs(inany.value.$ppsym))" } print OUT "; break; \\\n"; } print OUT <<'EOF'; default: outsv = &PL_sv_undef; \ } \ } while (0) EOF print OUT sprintf qq{#line %d "%s"\n}, __LINE__ + 2, __FILE__; print OUT <<'EOF'; /* Check minimum datatype required to represent number */ #define PDL_TESTTYPE(sym, ctype, v) {ctype foo = v; if (v == foo) return sym;} static inline int _pdl_whichdatatype (IV iv) { #define X(sym, ctype, ...) \ PDL_TESTTYPE(sym, ctype, iv) PDL_TYPELIST_ALL(X) #undef X croak("Something's gone wrong: %lld cannot be converted by whichdatatype", (long long)iv); } /* Check minimum, at least double, datatype required to represent number */ static inline int _pdl_whichdatatype_double (NV nv) { PDL_TESTTYPE(PDL_D,PDL_Double, nv) PDL_TESTTYPE(PDL_D,PDL_LDouble, nv) #undef PDL_TESTTYPE /* Default return type PDL_Double */ return PDL_D; } /* __PDLPERL_H */ #endif EOF PDL-2.074/Basic/Core/Char.pm0000644000175000017500000002006514172737500015230 0ustar osboxesosboxespackage PDL::Char; use strict; use warnings; our @ISA = qw (PDL); use overload '""' => \&PDL::Char::string; sub import {} # override the PDL one to avoid the big import list =head1 NAME PDL::Char -- PDL subclass which allows reading and writing of fixed-length character strings as byte PDLs =head1 SYNOPSIS use PDL; use PDL::Char; my $pchar = PDL::Char->new( [['abc', 'def', 'ghi'],['jkl', 'mno', 'pqr']] ); $pchar->setstr(1,0,'foo'); print $pchar; # 'string' bound to "", perl stringify function # Prints: # [ # ['abc' 'foo' 'ghi'] # ['jkl' 'mno' 'pqr'] # ] print $pchar->atstr(2,0); # Prints: # ghi =head1 DESCRIPTION This subclass of PDL allows one to manipulate PDLs of 'byte' type as if they were made of fixed length strings, not just numbers. This type of behavior is useful when you want to work with charactar grids. The indexing is done on a string level and not a character level for the 'setstr' and 'atstr' commands. This module is in particular useful for writing NetCDF files that include character data using the PDL::NetCDF module. =head1 FUNCTIONS =head2 new =for ref Function to create a byte PDL from a string, list of strings, list of list of strings, etc. =for usage # create a new PDL::Char from a perl array of strings $strpdl = PDL::Char->new( ['abc', 'def', 'ghij'] ); # Convert a PDL of type 'byte' to a PDL::Char $strpdl1 = PDL::Char->new (sequence (byte, 4, 5)+99); =for example $pdlchar3d = PDL::Char->new([['abc','def','ghi'],['jkl', 'mno', 'pqr']]); =cut sub new { my $type = shift; my $value = (scalar(@_)>1 ? [@_] : shift); # ref thyself # re-bless byte PDLs as PDL::Char if (ref($value) =~ /PDL/) { PDL::Core::barf('Cannot convert a non-byte PDL to PDL::Char') if ($value->get_datatype != $PDL::Types::PDL_B); return bless $value, $type; } my $ptype = $PDL::Types::PDL_B; my $self = PDL->initialize(); $self->set_datatype($ptype); $value = 0 if !defined($value); my $maxlength; # max length seen for all character strings my $samelen = 1; # Flag = 1 if all character strings are the same length # 1st Pass thru the perl array structure, assume all strings the same length my @dims; my $str = _rcharpack($value,\$maxlength,\$samelen,0,\@dims); unless( $samelen){ # Strings weren't the same length, go thru again and null pad to # the max length. $str = _rcharpack2($value,$maxlength,0,\@dims); } $self->setdims([reverse @dims]); ${$self->get_dataref} = $str; $self->upd_data(); return bless $self, $type; } # Take an N-D perl array of strings and pack it into a single string, # Used by the 'char' constructor # # References supplied so $maxlength and $samelen are updated along the way as well. # # # This version (_rcharpack) is for the 1st pass thru the N-d string array. # It assumes that all strings are the same length, but also checks to see if they aren't sub _rcharpack { my $w = shift; # Input string my ($maxlenref, $samelenref, $level, $dims) = @_; # reference to $maxlength, $samelen my ($ret,$type); $ret = ""; if (ref($w) eq "ARRAY") { PDL::Core::barf('Array is not rectangular') if (defined($dims->[$level]) and $dims->[$level] != scalar(@$w)); $dims->[$level] = scalar (@$w); $level++; $type = ref($$w[0]); for(@$w) { PDL::Core::barf('Array is not rectangular') unless $type eq ref($_); # Equal types $ret .= _rcharpack($_,$maxlenref, $samelenref, $level, $dims); } }elsif (ref(\$w) eq "SCALAR") { my $len = length($w); # Check for this length being different then the others: $$samelenref = 0 if( defined($$maxlenref) && ($len != $$maxlenref) ); # Save the max length: $$maxlenref = $len if( !defined($$maxlenref) || $len > $$maxlenref); # see if this is the max length seen so far $dims->[$level] = $len; $ret = $w; }else{ PDL::Core::barf("Don't know how to make a PDL object from passed argument"); } return $ret; } # # # This version (_rcharpack2) is for the 2nd pass (if required) thru the N-d string array. # If the 1st pass thru (_rcharpack) finds that all strings were not the same length, # this routine will go thru and null-pad all strings to the max length seen. # Note: For efficiency, the error checking is not repeated here, because any errors will # already be detected in the 1st pass. # sub _rcharpack2 { my $w = shift; # Input string my ($maxlen, $level, $dims) = @_; # Length to pad strings to my ($ret,$type); $ret = ""; if (ref($w) eq "ARRAY") { # Checks not needed the second time thru (removed) $dims->[$level] = scalar (@$w); $level++; $type = ref($$w[0]); for(@$w) { $ret .= _rcharpack2($_,$maxlen,$level,$dims); } }elsif (ref(\$w) eq "SCALAR") { my $len = length($w); $dims->[$level] = $maxlen; $ret = $w.("\00" x ($maxlen - $len)); } return $ret; } # # =head2 string =for ref Function to print a character PDL (created by 'char') in a pretty format. =for usage $char = PDL::Char->new( [['abc', 'def', 'ghi'], ['jkl', 'mno', 'pqr']] ); print $char; # 'string' bound to "", perl stringify function # Prints: # [ # ['abc' 'def' 'ghi'] # ['jkl' 'mno' 'pqr'] # ] # 'string' is overloaded to the "" operator, so: # print $char; # should have the same effect. =cut sub string { my $self = shift; my $level = shift || 0; my $sep = $PDL::use_commas ? "," : " "; if ($self->dims == 1) { my $str = ${$self->get_dataref}; # get copy of string $str =~ s/\00+$//g; # get rid of any null padding return "\'". $str. "\'". $sep; } else { my @dims = reverse $self->dims; my $ret = ''; $ret .= (" " x $level) . '[' . ((@dims == 2) ? ' ' : "\n"); for (my $i=0;$i<$dims[0];$i++) { my $slicestr = ":," x (scalar(@dims)-1) . "($i)"; my $substr = $self->slice($slicestr); $ret .= $substr->string($level+1); } $ret .= (" " x $level) . ']' . $sep . "\n"; return $ret; } } =head2 setstr =for ref Function to set one string value in a character PDL. The input position is the position of the string, not a character in the string. The first dimension is assumed to be the length of the string. The input string will be null-padded if the string is shorter than the first dimension of the PDL. It will be truncated if it is longer. =for usage $char = PDL::Char->new( [['abc', 'def', 'ghi'], ['jkl', 'mno', 'pqr']] ); $char->setstr(0,1, 'foobar'); print $char; # 'string' bound to "", perl stringify function # Prints: # [ # ['abc' 'def' 'ghi'] # ['foo' 'mno' 'pqr'] # ] $char->setstr(2,1, 'f'); print $char; # 'string' bound to "", perl stringify function # Prints: # [ # ['abc' 'def' 'ghi'] # ['foo' 'mno' 'f'] -> note that this 'f' is stored "f\0\0" # ] =cut sub setstr { # Sets a particular single value to a string. PDL::Core::barf('Usage: setstr($pdl, $x, $y,.., $value)') if $#_<2; my $self = shift; my $val = pop; my @dims = $self->dims; my $n = $dims[0]; for (my $i=0;$i<$n;$i++) { my $chr = ($i >= length($val)) ? 0 : unpack ("C", substr ($val, $i, 1)); PDL::Core::set_c ($self, [$i, @_], $chr); } } =head2 atstr =for ref Function to fetch one string value from a PDL::Char type PDL, given a position within the PDL. The input position of the string, not a character in the string. The length of the input string is the implied first dimension. =for usage $char = PDL::Char->new( [['abc', 'def', 'ghi'], ['jkl', 'mno', 'pqr']] ); print $char->atstr(0,1); # Prints: # jkl =cut sub atstr { # Fetchs a string value from a PDL::Char PDL::Core::barf('Usage: atstr($pdl, $x, $y,..,)') if (@_ < 2); my $self = shift; my $str = ':,' . join (',', map {"($_)"} @_); my $w = $self->slice($str); my $val = ${$w->get_dataref}; # get the data $val =~ s/\00+$//g; # get rid of any null padding return $val; } # yuck ;) this is a cool little accessor method # rebless a slice into PDL; originally # Marc's idea used in PDL::Complex sub numeric { my ($seq) = @_; return bless $seq->slice(''), 'PDL'; } 1; PDL-2.074/Basic/Options.pm0000644000175000017500000005751414165667604015140 0ustar osboxesosboxespackage PDL::Options; =head1 NAME PDL::Options - simplifies option passing by hash in PerlDL =head1 SYNOPSIS use PDL::Options; %hash = parse( \%defaults, \%user_options); use PDL::Options (); $opt = new PDL::Options; $opt = new PDL::Options ( \%defaults ); $opt->defaults ( \%defaults ); $opt->synonyms ( { 'COLOR' => 'COLOUR' } ); $hashref = $opt->defaults; $opt->options ( \%user_options ); $hashref = $opt->options; $opt->incremental(1); $opt->full_options(0); =head1 DESCRIPTION Object to simplify option passing for PerlDL subroutines. Allows you to merge a user defined options with defaults. A simplified (non-OO) interface is provided. =cut use strict; use warnings; use Carp; require Exporter; # difference to 0.91 is that added CENTRE/CENTER as default # synonymns (patch by Diab Jerius [ #469110 ]) our $VERSION = '0.92'; $VERSION = eval $VERSION; our @ISA = qw(Exporter); our %EXPORT_TAGS = ( 'Func' => [qw/ parse iparse ifhref /] ); Exporter::export_tags('Func'); # List of default synonyms our %DEF_SYNS = ( COLOR => 'COLOUR', COLOUR => 'COLOR', CENTER => 'CENTRE', CENTRE => 'CENTER', ); my $default = { WarnOnMissing => 1, FullOptions => 1, DEBUG => 0, }; =head1 Utility functions =head2 ifhref parse({Ext => 'TIF', ifhref($opt)}); just return the argument if it is a hashref otherwise return an empty hashref. Useful in conjunction with parse to return just the default values if argument is not a hash ref =head1 NON-OO INTERFACE A simplified non-object oriented interface is provided. These routines are exported into the callers namespace by default. =over 4 =item parse( \%defaults, \%user_options) This will parse user options by using the defaults. The following settings are used for parsing: The options are case-sensitive, a default synonym table is consulted (see L), minimum-matching is turned on, and translation of values is not performed. A hash (not hash reference) containing the processed options is returned. %options = parse( { LINE => 1, COLOUR => 'red'}, { COLOR => 'blue'}); =item iparse( \%defaults, \%user_options) Same as C but matching is case insensitive =cut sub ifhref { my ($href) = @_; return defined $href && ref $href eq 'HASH' ? $href : {}; } sub parse { return _parse(1,@_) } sub iparse { return _parse(0,@_) } sub _parse { croak 'Usage: parse( \%defaults, \%user )' if scalar(@_) != 3; my $casechk = shift; my $defaults = shift; croak ("First argument is not a hash reference") unless ref($defaults) eq "HASH"; my $user = shift; croak ("Second argument is not a hash reference") unless ref($user) eq "HASH"; # Create new object my $opt = new PDL::Options ( $defaults ); # Set up default behaviour $opt->minmatch(1); $opt->casesens($casechk); $opt->synonyms( \%DEF_SYNS ); # Process the options my $optref = $opt->options( $user ); return %$optref; } =back =head2 Default Synonyms The following default synonyms are available in the non-OO interface: COLOR => COLOUR COLOUR => COLOR CENTER => CENTRE CENTRE => CENTER =head1 METHODS The following methods are available to PDL::Options objects. =over 4 =item new() Constructor. Creates the object. With an optional argument can also set the default options. =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; my $opt = {}; # Set up object structure $opt->{DEFAULTS} = {}; # Default options $opt->{CURRENT} = {}; # Current options $opt->{CurrKeys} = []; # list of selected keys if full_options(0) $opt->{SYNONYMS} = {}; # List of synonyms $opt->{INC} = 0; # Flag to decide whether we are incremental on cur $opt->{CaseSens} = 0; # Are options case sensitive $opt->{MinMatch} = 1; # Minimum matching on keys $opt->{Translation} = {};# Translation from eg 'RED' to 1 $opt->{AutoTranslate}= 1;# Automatically translate options when processing $opt->{MinMatchTrans} = 0; # Min matching during translation $opt->{CaseSensTrans} = 0; # Case sensitive during translation # Return full options list $opt->{FullOptions} = $default->{FullOptions}; # Whether to warn for options that are invalid or not $opt->{WarnOnMissing}= $default->{WarnOnMissing}; $opt->{DEBUG} = $default->{DEBUG}; # Turn on debug messages # Bless into class bless ( $opt, $class); # If we were passed arguments, pass to defaults method if (@_) { $opt->defaults( @_ ); } return $opt; } =item extend (\%options) This will copy the existing options object and extend it with the requested extra options. =cut sub extend { my ($self, $opt)=@_; my $class = ref($self); my $h = {%{$self}}; croak ("Argument is not reference to hash!\n") unless ref($opt) eq 'HASH'; # # The next step is to perform a deep copy of the hash # references since we might want to change these without # changing the originals. # $h->{SYNONYMS}={%{$self->{SYNONYMS}}}; $h->{Translation}={%{$self->{Translation}}}; $h->{CurrKeys}=[@{$self->{CurrKeys}}]; # # Create the extended option list. # my %all_options = (%{$opt}, %{$self->{DEFAULTS}}); # Bless it bless ($h, $class); # And parse the default options $h->defaults(\%all_options); return $h; } # =item change_defaults (\%options) # This will merge the options given with the defaults hash and hence change # the default hash. This is not normally a good idea, but in certain dynamic # situations you might want to adjust a default parameter for future calls # to the routine. # =cut # sub change_defaults { # my $self=shift; # my $arg = shift; # croak("Argument is not a hash reference!\n") unless ref($arg) eq 'HASH'; # my $defs = $self->defaults($arg); # $self->defaults($) # } =item defaults( \%defaults ) Method to set or return the current defaults. The argument should be a reference to a hash. The hash reference is returned if no arguments are supplied. The current values are reset whenever the defaults are changed. =cut sub defaults { my $self = shift; if (@_) { my $arg = shift; croak("Argument is not a hash reference") unless ref($arg) eq "HASH"; $self->{DEFAULTS} = $arg; # Reset the current state (making sure that I disconnect the # hashes my %hash = %$arg; $self->curr_full(\%hash); } # Decouple the hash to protect it from being modified outside the # object my %hash = %{$self->{DEFAULTS}}; return \%hash; } =item add_synonym (\%synonyms) Method to add another synonym to an option set The argument should be a reference to a hash. =cut sub add_synonym { my $self=shift; return unless @_; my $arg = shift; croak("Synonym argument is not a hash reference") unless ref($arg) eq "HASH"; foreach (keys %$arg) { $self->{SYNONYMS}{$_}=$arg->{$_}; } my %hash = %{$self->{SYNONYMS}}; return \%hash; } =item add_translation (\%translation) Method to add another translation rule to an option set. The argument should be a reference to a hash. =cut sub add_translation { my $self = shift; return unless @_; my $arg = shift; croak("Translation argument is not a hash reference") unless ref($arg) eq 'HASH'; foreach (keys %$arg) { $self->{Translation}{$_}=$arg->{$_}; } my %hash = %{$self->{Translation}}; return \%hash; } =item synonyms( \%synonyms ) Method to set or return the current synonyms. The argument should be a reference to a hash. The hash reference is returned if no arguments are supplied. This allows you to provide alternate keywords (such as allowing 'COLOR' as an option when your defaults uses 'COLOUR'). =cut sub synonyms { my $self = shift; if (@_) { my $arg = shift; croak("Argument is not a hash reference") unless ref($arg) eq "HASH"; $self->{SYNONYMS} = $arg; } # Decouple the hash to protect it from being modified outside the # object my %hash = %{$self->{SYNONYMS}}; return \%hash; } =item current Returns the current state of the options. This is returned as a hash reference (although it is not a reference to the actual hash stored in the object). If full_options() is true the full options hash is returned, if full_options() is false only the modified options are returned (as set by the last call to options()). =cut sub current { my $self = shift; if ($self->full_options) { return $self->curr_full; } else { my @keys = $self->curr_keys; my %hash = (); my $curr = $self->curr_full; foreach my $key (@keys) { $hash{$key} = $$curr{$key} if exists $$curr{$key}; } return \%hash; } } =item clear_current This routine clears the 'state' of the C object so that the next call to current will return an empty list =cut sub clear_current { my $self = shift; @{$self->{CurrKeys}}=(); } # Method to set the 'mini' state of the object # This is just a list of the keys in %defaults that were selected # by the user. current() returns the hash with these keys if # called with full_options(0). # Not publicising this sub curr_keys { my $self = shift; if (@_) { @{$self->{CurrKeys}} = @_; } return @{$self->{CurrKeys}}; } # Method to set the full state of the object # Not publicising this sub curr_full { my $self = shift; if (@_) { my $arg = shift; croak("Argument is not a hash reference") unless ref($arg) eq "HASH"; $self->{CURRENT} = $arg; } # Decouple the hash my %hash = %{$self->{CURRENT}}; return \%hash; } =item translation Provide translation of options to more specific values that are recognised by the program. This allows, for example, the automatic translation of the string 'red' to '#ff0000'. This method can be used to setup the dictionary and is hash reference with the following structure: OPTIONA => { 'string1' => decode1, 'string2' => decode2 }, OPTIONB => { 's4' => decodeb1, } etc.... Where OPTION? corresponds to the top level option name as stored in the defaults array (eg LINECOLOR) and the anonymous hashes provide the translation from string1 ('red') to decode1 ('#ff0000'). An options string will be translated automatically during the main options() processing if autotrans() is set to true. Else translation can be initiated by the user using the translate() method. =cut sub translation { my $self = shift; if (@_) { my $arg = shift; croak("Argument is not a hash reference") unless ref($arg) eq "HASH"; $self->{Translation} = $arg; } # Decouple the hash to protect it from being modified outside the # object my %hash = %{$self->{Translation}}; return \%hash; } =item incremental Specifies whether the user defined options will be treated as additions to the current state of the object (1) or modifications to the default values only (0). Can be used to set or return this value. Default is false. =cut sub incremental { my $self = shift; if (@_) { $self->{INC} = shift; } return $self->{INC}; } =item full_options Governs whether a complete set of options is returned (ie defaults + expanded user options), true, or if just the expanded user options are returned, false (ie the values specified by the user). This can be useful when you are only interested in the changes to the options rather than knowing the full state. (For example, if defaults contains keys for COLOUR and LINESTYLE and the user supplied a key of COL, you may simply be interested in the modification to COLOUR rather than the state of LINESTYLE and COLOUR.) Default is true. =cut sub full_options { my $self = shift; if (@_) { $self->{FullOptions} = shift; } return $self->{FullOptions}; } =item casesens Specifies whether the user defined options will be processed independent of case (0) or not (1). Default is to be case insensitive. Can be used to set or return this value. =cut sub casesens { my $self = shift; if (@_) { $self->{CaseSens} = shift; } return $self->{CaseSens}; } =item minmatch Specifies whether the user defined options will be minimum matched with the defaults (1) or whether the user defined options should match the default keys exactly. Defaults is true (1). If a particular key matches exactly (within the constraints imposed bby case sensitivity) this key will always be taken as correct even if others are similar. For example COL would match COL and COLOUR but this implementation will always return COL in this case (note that for CO it will return both COL and COLOUR and pick one at random. Can be used to set or return this value. =cut sub minmatch { my $self = shift; if (@_) { $self->{MinMatch} = shift; } return $self->{MinMatch}; } =item autotrans Specifies whether the user defined options will be processed via the translate() method immediately following the main options parsing. Default is to autotranslate (1). Can be used to set or return this value. =cut sub autotrans { my $self = shift; if (@_) { $self->{AutoTranslate} = shift; } return $self->{AutoTranslate}; } =item casesenstrans Specifies whether the keys in the options hash will be matched insensitive of case (0) during translation() or not (1). Default is to be case insensitive. Can be used to set or return this value. =cut sub casesenstrans { my $self = shift; if (@_) { $self->{CaseSensTrans} = shift; } return $self->{CaseSensTrans}; } =item minmatchtrans Specifies whether the keys in the options hash will be minimum matched during translation(). Default is false (0). If a particular key matches exactly (within the constraints imposed bby case sensitivity) this key will always be taken as correct even if others are similar. For example COL would match COL and COLOUR but this implementation will always return COL in this case (note that for CO it will return both COL and COLOUR and pick one at random. Can be used to set or return this value. =cut sub minmatchtrans { my $self = shift; if (@_) { $self->{MinMatchTrans} = shift; } return $self->{MinMatchTrans}; } =item warnonmissing Turn on or off the warning message printed when an options is not in the options hash. This can be convenient when a user passes a set of options that has to be parsed by several different option objects down the line. =cut sub warnonmissing { my $self = shift; if (ref $self) { if (@_) { $self->{WarnOnMissing}=shift;} return $self->{WarnOnMissing}; } else { $default->{WarnOnMissing} = shift if @_; return $default->{WarnOnMissing}; } } =item debug Turn on or off debug messages. Default is off (0). Can be used to set or return this value. =cut sub debug { my $self = shift; if (ref $self) { if (@_) { $self->{DEBUG} = shift; } return $self->{DEBUG}; } else { $default->{DEBUG} = shift if @_; return $default->{DEBUG}; } } =item options Takes a set of user-defined options (as a reference to a hash) and merges them with the current state (or the defaults; depends on the state of incremental()). The user-supplied keys will be compared with the defaults. Case sensitivity and minimum matching can be configured using the mimatch() and casesens() methods. A warning is raised if keys present in the user options are not present in the defaults unless warnonmissing is set. A reference to a hash containing the merged options is returned. $merged = $opt->options( { COL => 'red', Width => 1}); The state of the object can be retrieved after this by using the current() method or by using the options() method with no arguments. If full_options() is true, all options are returned (options plus overrides), if full_options() is false then only the modified options are returned. Synonyms are supported if they have been configured via the synonyms() method. =cut sub options { my $self = shift; # If there is an argument do something clever if (@_) { # check that the arg is a hash my $arg = shift; croak("Argument is not a hash reference") unless ref($arg) eq "HASH"; # Turn the options into a real hash my %user = %$arg; # Now read in the base options my $base; if ($self->incremental) { $base = $self->curr_full; } else { $base = $self->defaults; } # Turn into a real hash for convenience my %base = %$base; # Store a list of all the expanded user keys my @list = (); # Read in synonyms my %syn = %{$self->synonyms}; # Now go through the keys in the user hash and compare with # the defaults foreach my $userkey (sort keys %user) { # Check for matches in the default set my @matched = $self->compare_with_list(0, $userkey, sort keys %base); # If we had no matches, check the synonyms list if ($#matched == -1) { @matched = $self->compare_with_list(0, $userkey, sort keys %syn); # If we have matched then convert the key to the actual # value stored in the object for (my $i =0; $i <= $#matched; $i++) { $matched[$i] = $syn{$matched[$i]}; } } # At this point we have matched the userkey to a key in the # defaults list (or if not say so) if ($#matched == -1) { print "Warning: $userkey is not a valid option\n" if $self->{WarnOnMissing}; } else { if ( $#matched > 0 ) { print "Warning: Multiple matches for option $userkey\n"; print "Warning: Could be any of the following:\n"; print join("\n",@matched) . "\n"; print "Accepting the first match ($matched[0])\n"; } # Modify the value in %base and keep track of a separate # array containing only the matched keys $base{$matched[0]} = $user{$userkey}; push(@list, $matched[0]); print "Matched: $userkey for $matched[0]\n" if $self->debug; } } # Finished matching so set this as the current state of the # object $self->curr_keys(@list); $self->curr_full(\%base); # Now process the values via the provided translation # if required. Note that the current design means that # We have to run this after we have set the current state. # Otherwise the translation() method would not work directly # and we would have to provide a public version and a private one. # Note that translate updates the current state of the object # So we don't need to catch the return value $self->translate if $self->autotrans; } # Current state should now be in current. # Simply return it return $self->current; } =item translate Translate the current option values (eg those set via the options() method) using the provided translation(). This method updates the current state of the object and returns the updated options hash as a reference. $ref = $opt->translate; =cut sub translate { my $self = shift; my %trans = %{$self->translation}; my %opt = %{$self->curr_full}; # Process all options # Now need to go through each of the keys # and if the corresponding key exists in the translation # hash we need to check that a valid translation exists foreach my $key ( sort keys %opt ) { if (exists $trans{$key}) { # Okay so a translation might exist # Now compare keys in the hash in the hash my %subhash = %{$trans{$key}}; my @matched = $self->compare_with_list(1, $opt{$key}, sort keys %subhash); # At this point we have matched the userkey to a key in the # dictionary. If there is no translation dont say anything # since it may be a 'REAL' answer (ie 1 instead of 'red') if ($#matched > -1) { if ( $#matched > 0 ) { print "Warning: Multiple matches for $opt{$key} in option $key\n"; print "Warning: Could be any of the following:\n"; print join("\n",@matched) . "\n"; print "Accepting the first match ($matched[0])\n"; } # Modify the value in the options set print "Translation: $opt{$key} translated to $subhash{$matched[0]}\n" if $self->debug; $opt{$key} = $subhash{$matched[0]}; } } } # Update the current state return $self->curr_full( \%opt ); } # Private method to compare a key with a list of keys. # The object controls whether case-sensitivity of minimum matching # are required # Arguments: flag to determine whether I am matchin options or translations # this is needed since both methods are configurable with # regards to minimum matching and case sensitivity. # 0 - use $self->minmatch and $self->casesens # 1 - use $self->minmatchtrans and $self->casesenstrans # $key: Key to be compared # @keys: List of keys # Returns: Array of all keys that match $key taking into account the # object state. # # There must be a more compact way of doing this sub compare_with_list { my $self = shift; my $flag = shift; my $key = shift; my @list = @_; my @result = (); my ($casesens, $minmatch); if ($flag == 0) { $casesens = $self->casesens; $minmatch = $self->minmatch; } else { $casesens = $self->casesenstrans; $minmatch = $self->minmatchtrans; } # Do matches # Case Sensitive if ($casesens) { # Always start with the exact match before proceding to minimum # match. # We want to make sure that we will always match on the # exact match even if alternatives exist (eg COL will always # match just COL if the keys are COL and COLOUR) # Case insensitive @result = grep { /^$key$/ } @list; # Proceed to minimum match if we detected nothing # Minumum match/ Case sensitive if ($#result == -1 && $minmatch) { @result = grep { /^$key/ } @list; } } else { # We want to make sure that we will always match on the # exact match even if alternatives exist (eg COL will always # match just COL if the keys are COL and COLOUR) # First do the exact match (case insensitive) @result = grep { /^$key$/i } @list; # If this match came up with something then we will use it # Else we will try a minimum match (assuming flag is true) # Minumum match/ Case insensitive if ($#result == -1 && $minmatch) { @result = grep { /^$key/i } @list; } } return @result; } =back =head1 EXAMPLE Two examples are shown. The first uses the simplified interface and the second uses the object-oriented interface. =head1 Non-OO use PDL::Options (':Func'); %options = parse( { LINE => 1, COLOUR => 'red', }, { COLOR => 'blue' } ); This will return a hash containing %options = ( LINE => 1, COLOUR => 'blue' ) =head1 Object oriented The following example will try to show the main points: use PDL::Options (); # Create new object and supply defaults $opt = new PDL::Options( { Colour => 'red', LineStyle => 'dashed', LineWidth => 1 } ); # Create synonyms $opt->synonyms( { Color => 'Colour' } ); # Create translation dictionary $opt->translation( { Colour => { 'blue' => '#0000ff', 'red' => '#ff0000', 'green'=> '#00ff00' }, LineStyle => { 'solid' => 1, 'dashed' => 2, 'dotted' => 3 } } ); # Generate and parse test hash $options = $opt->options( { Color => 'green', lines => 'solid', } ); When this code is run, $options will be the reference to a hash containing the following: Colour => '#00ff00', LineStyle => 1, LineWidth => 1 If full_options() was set to false (0), $options would be a reference to a hash containing: Colour => '#00ff00', LineStyle => 1 Minimum matching and case insensitivity can be configured for both the initial parsing and for the subsequent translating. The translation can be turned off if not desired. Currently synonyms are not available for the translation although this could be added quite simply. =head1 AUTHOR Copyright (C) Tim Jenness 1998 (t.jenness@jach.hawaii.edu). 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 1; PDL-2.074/Basic/Ufunc/0000755000175000017500000000000014200406301014162 5ustar osboxesosboxesPDL-2.074/Basic/Ufunc/ufunc.pd0000644000175000017500000010316214200050261015632 0ustar osboxesosboxesuse strict; use warnings; use PDL::Types qw(types ppdefs_complex ppdefs_all); my $T = [map $_->ppsym, grep $_->integer, types]; my $C = [ppdefs_complex]; my $A = [ppdefs_all]; pp_addpm({At=>'Top'},<<'EOD'); use strict; use warnings; =head1 NAME PDL::Ufunc - primitive ufunc operations for pdl =head1 DESCRIPTION This module provides some primitive and useful functions defined using PDL::PP based on functionality of what are sometimes called I (for example NumPY and Mathematica talk about these). It collects all the functions generally used to C or C along a dimension. These all do their job across the first dimension but by using the slicing functions you can do it on any dimension. The L module provides an alternative interface to many of the functions in this module. =head1 SYNOPSIS use PDL::Ufunc; =cut use PDL::Slices; use Carp; EOD # helper functions sub projectdocs { my $name = shift; my $op = shift; my $extras = shift; < etc. it is possible to use I dimension. =for usage \$y = $op(\$x); =for example \$spectrum = $op \$image->transpose $extras =cut EOD } # sub: projectdocs() sub cumuprojectdocs { my $name = shift; my $op = shift; my $extras = shift; < etc. it is possible to use I dimension. The sum is started so that the first element in the cumulative $name is the first element of the parameter. =for usage \$y = $op(\$x); =for example \$spectrum = $op \$image->transpose $extras =cut EOD } # sub: cumuprojectdocs() # it's a bit unclear what to do with the comparison operators, # since the return value could be bad because all elements are bad, # which needs checking for since the bad value could evaluate to # true or false (eg if the user has set it to 0) # # by setting CopyBadStatusCode to '', we stop the output ndarray # from automatically being set bad if any of the input ndarrays are bad. # - we can set the flag within BadCode if necessary # # This may NOT be sensible. Only time, and comments, will tell... # my %over = ( sumover => { name => 'sum', op => '+=', init => 0, }, prodover => { name => 'product', op => '*=', init => 1, }, ); foreach my $func ( sort keys %over ) { # creates $func and cumu$func functions # and d$func and dcumu$func functions, which # perform the calculations in double precision my $name = $over{$func}{name}; my $op = $over{$func}{op}; my $init = $over{$func}{init}; pp_def( $_->[0].$func, HandleBad => 1, Pars => "a(n); $_->[1] [o]b();", $_->[2] ? (GenericTypes=>$_->[2]) : (), Code => qq{ \$GENERIC(b) tmp = $init; int flag = 0; loop(n) %{ PDL_IF_BAD(if ( \$ISGOOD(a()) ) { flag = 1;,) tmp $op \$a(); PDL_IF_BAD(},) %} PDL_IF_BAD(if ( !flag ) \$SETBAD(b()); else,) \$b() = tmp; }, Doc => projectdocs( $name, $_->[0].$func, $_->[3] ), ) for ( ['', 'int+', $A, ''], ['c', 'cdouble', $C, "Unlike L, the calculations are performed in complex double precision." ], ['d', 'double', undef, "Unlike L, the calculations are performed in double precision." ], ); my $cfunc = "cumu${func}"; pp_def( $_->[0].$cfunc, HandleBad => 1, Pars => "a(n); $_->[1] [o]b(n);", $_->[2] ? (GenericTypes=>$_->[2]) : (), Code => qq{ \$GENERIC(b) tmp = $init; loop(n) %{ PDL_IF_BAD(if ( \$ISBAD(a()) ) { \$SETBAD(b()); } else {,) tmp $op \$a(); \$b() = tmp; PDL_IF_BAD(},) %} }, Doc => cumuprojectdocs( $name, $_->[0].$cfunc, $_->[3] ), ) for ( ['', 'int+', $A, ''], ['d', 'double', undef, "Unlike L, the calculations are performed in double precision." ], ); } # foreach: my $func %over = ( zcover => { def=>'char tmp', txt => '== 0', init => 1, alltypes => 1, otype => 'int+', op => 'tmp &= ($a() == 0);', check => '!tmp' }, andover => { def=>'char tmp', txt => 'and', init => 1, alltypes => 1, otype => 'int+', op => 'tmp &= ($a() != 0);', check => '!tmp' }, bandover => { def=>'$GENERIC() tmp', txt => 'bitwise and', init => '~0', otype => '', op => 'tmp &= $a();', check => '!tmp' }, orover => { def=>'char tmp', txt => 'or', init => 0, alltypes => 1, otype => 'int+', op => 'tmp |= ($a() != 0);', check => 'tmp' }, borover => { def=>'$GENERIC() tmp', txt => 'bitwise or', init => 0, otype => '', op => 'tmp |= $a() ;', check => '!~tmp' }, ); foreach my $func ( sort keys %over ) { my $def = $over{$func}{def}; my $txt = $over{$func}{txt}; my $init = $over{$func}{init}; my $otype = $over{$func}{otype}; my $op = $over{$func}{op}; my $check = $over{$func}{check}; my %extra; unless ( $over{$func}{alltypes} ) { $extra{GenericTypes} = $T, } pp_def( $func, HandleBad => 1, %extra, Pars => 'a(n); ' . $otype . ' [o]b();', Code => qq{ $def = $init; int flag = 0; loop(n) %{ PDL_IF_BAD(if ( \$ISGOOD(a()) ) { flag = 1;,) $op if ( $check ) break; PDL_IF_BAD(},) %} PDL_IF_BAD(if ( !flag ) { \$SETBAD(b()); \$PDLSTATESETBAD(b); } else,) \$b() = tmp; }, CopyBadStatusCode => '', Doc => projectdocs( $txt, $func,''), BadDoc => 'If C contains only bad data (and its bad flag is set), C is set bad. Otherwise C will have its bad flag cleared, as it will not contain any bad values.', ); } # foreach: $func # this would need a lot of work to support bad values # plus it gives me a chance to check out HandleBad => 0 ;) # pp_def( 'intover', HandleBad => 0, Pars => 'a(n); float+ [o]b();', Code => '$GENERIC(b) tmp = 0; PDL_Indx ns = $SIZE(n), nn; /* Integration formulae from Press et al 2nd Ed S 4.1 */ switch (ns) { case 1: threadloop %{ $b() = 0.; /* not a(n=>0); as interval has zero width */ %} break; case 2: threadloop %{ $b() = 0.5*($a(n=>0)+$a(n=>1)); %} break; case 3: threadloop %{ $b() = ($a(n=>0)+4*$a(n=>1)+$a(n=>2))/3.; %} break; case 4: threadloop %{ $b() = ($a(n=>0)+$a(n=>3)+3.*($a(n=>1)+$a(n=>2)))*0.375; %} break; case 5: threadloop %{ $b() = (14.*($a(n=>0)+$a(n=>4)) +64.*($a(n=>1)+$a(n=>3)) +24.*$a(n=>2))/45.; %} break; default: threadloop %{ for (nn=3,tmp=0;nnnn); } tmp += (23./24.)*($a(n=>2)+$a(n=>nn));nn++; tmp += (7./6.) *($a(n=>1)+$a(n=>nn));nn++; tmp += 0.375 *($a(n=>0)+$a(n=>nn)); $b() = tmp; %} } ', Doc => projectdocs('integral','intover', q~Notes: C uses a point spacing of one (i.e., delta-h==1). You will need to scale the result to correct for the true point delta). For C 3>, these are all C (like Simpson's rule), but are integrals between the end points assuming the pdl gives values just at these centres: for such `functions', sumover is correct to C, but is the natural (and correct) choice for binned data, of course. ~) ); # intover sub synonym { my ($name, $synonym) = @_; pp_add_exported('', $synonym); pp_addpm( "=head2 $synonym\n\n=for ref\n\n Synonym for $name.\n\n=cut\n *PDL::$synonym = *$synonym = \\&PDL::$name;" ); } sub make_average { my ($prefix, $outpar_type, $extra) = @_; pp_def( "${prefix}average", HandleBad => 1, Pars => "a(n); $outpar_type [o]b();", Code => q{ $GENERIC(b) tmp = 0; PDL_Indx cnt = 0; loop(n) %{ PDL_IF_BAD(if ( $ISGOOD(a()) ) {,) cnt++; tmp += $a(); PDL_IF_BAD(},) %} if ( !cnt ) { PDL_IF_BAD($SETBAD(b()), $b() = PDL_IF_GENTYPE_INTEGER(0,NAN)); } else $b() = tmp / cnt; }, Doc => projectdocs( 'average', "${prefix}average", $extra||'' ), ); synonym(map "$prefix$_", qw(average avgover)); } make_average('', 'int+'); make_average('c', 'cdouble', "Unlike L, the calculation is performed in complex double precision." ); make_average('d', 'double', "Unlike L, the calculation is performed in double precision." ); for my $which ( [qw(minimum < minover)], [qw(maximum > maxover)], ) { my ($name, $op, $synonym) = @$which; pp_def( $name, HandleBad => 1, Pars => 'a(n); [o]c();', Code => '$GENERIC() cur = 0; int flag = 0; loop(n) %{ if( !flag || ($a() '.$op.' cur ) || PDL_ISNAN_$PPSYM()(cur) ) { cur = $a(); flag = 1;} %} if(flag && !PDL_ISNAN_$PPSYM()(cur)) { $c() = cur; } else { $SETBAD(c()); $PDLSTATESETBAD(c); } ', BadCode => '$GENERIC() cur = 0; int flag = 0; loop(n) %{ if( $ISGOOD(a()) && ($a()*0 == 0) && (!flag || $a() '.$op.' cur)) {cur = $a(); flag = 1;} %} if ( flag ) { $c() = cur; } else { $SETBAD(c()); $PDLSTATESETBAD(c); }', CopyBadStatusCode => '', Doc => projectdocs($name,$name,''), BadDoc => 'Output is set bad if all elements of the input are bad, otherwise the bad flag is cleared for the output ndarray. Note that C are considered to be valid values; see L and L for ways of masking NaNs. ', ); synonym($name, $synonym); pp_def( "${name}_ind", HandleBad => 1, Pars => 'a(n); indx [o] c();', Code => '$GENERIC() cur = 0; PDL_Indx curind = -1; loop(n) %{ if(curind == -1 || $a() '.$op.' cur || PDL_ISNAN_$PPSYM()(cur)) {cur = $a(); curind = n;} %} if(curind != -1 && !PDL_ISNAN_$PPSYM()(cur)) { $c() = curind; } else { $SETBAD(c()); $PDLSTATESETBAD(c); } ', BadCode => '$GENERIC() cur = 0; PDL_Indx curind = -1; loop(n) %{ if( $ISGOOD(a()) && (curind == -1 || $a() '.$op.' cur)) {cur = $a(); curind = n;} %} if ( curind != -1 && !PDL_ISNAN_$PPSYM()(cur) ) { $c() = curind; } else { $SETBAD(c()); $PDLSTATESETBAD(c); }', CopyBadStatusCode => '', Doc => "Like $name but returns the index rather than the value", BadDoc => 'Output is set bad if all elements of the input are bad, otherwise the bad flag is cleared for the output ndarray.', ); synonym("${name}_ind", "${synonym}_ind"); pp_def( "${name}_n_ind", HandleBad => 0, # just a marker Pars => 'a(n); indx [o]c(m);', Code => '$GENERIC() cur = 0; PDL_Indx curind; register PDL_Indx ns = $SIZE(n); if($SIZE(m) > $SIZE(n)) $CROAK("n_ind: m_size > n_size"); loop(m) %{ curind = ns; loop(n) %{ PDL_Indx nm; int flag=0; for(nm=0; nmnm) == n) {flag=1; break;} } if(!flag && ((curind == ns) || $a() '.$op.' cur || PDL_ISNAN_$PPSYM()(cur))) {cur = $a(); curind = n;} %} $c() = curind; %}', Doc => "Returns the index of C $name elements", BadDoc => 'Not yet been converted to ignore bad values', ); synonym("${name}_n_ind", "${synonym}_n_ind"); } # foreach: $which pp_def( 'minmaximum', HandleBad => 1, Pars => 'a(n); [o]cmin(); [o] cmax(); indx [o]cmin_ind(); indx [o]cmax_ind();', Code => '$GENERIC() curmin = 0, curmax = 0; /* Handle null ndarray --CED */ PDL_Indx curmin_ind = 0, curmax_ind = 0; loop(n) %{ if ( !n ) { curmin = curmax = $a(); curmin_ind = curmax_ind = n; } else { if ( $a() < curmin ) { curmin = $a(); curmin_ind = n; } if ( $a() > curmax ) { curmax = $a(); curmax_ind = n; } } %} $cmin() = curmin; $cmin_ind() = curmin_ind; $cmax() = curmax; $cmax_ind() = curmax_ind;', CopyBadStatusCode => '', BadCode => '$GENERIC() curmin = 0, curmax = 0; PDL_Indx curmin_ind = 0, curmax_ind = 0; int flag = 0; loop(n) %{ if ( $ISGOOD(a()) ) { if ( !flag ) { curmin = curmax = $a(); curmin_ind = curmax_ind = n; flag = 1; } else { if ( $a() < curmin ) { curmin = $a(); curmin_ind = n; } if ( $a() > curmax ) { curmax = $a(); curmax_ind = n; } } } /* ISGOOD */ %} if ( flag ) { /* Handle null ndarray */ $cmin() = curmin; $cmin_ind() = curmin_ind; $cmax() = curmax; $cmax_ind() = curmax_ind; } else { $SETBAD(cmin()); $SETBAD(cmin_ind()); $SETBAD(cmax()); $SETBAD(cmax_ind()); $PDLSTATESETBAD(cmin); $PDLSTATESETBAD(cmin_ind); $PDLSTATESETBAD(cmax); $PDLSTATESETBAD(cmax_ind); }', Doc => ' =for ref Find minimum and maximum and their indices for a given ndarray; =for usage pdl> $x=pdl [[-2,3,4],[1,0,3]] pdl> ($min, $max, $min_ind, $max_ind)=minmaximum($x) pdl> p $min, $max, $min_ind, $max_ind [-2 0] [4 3] [0 1] [2 2] See also L, which clumps the ndarray together. =cut ', BadDoc => 'If C contains only bad data, then the output ndarrays will be set bad, along with their bad flag. Otherwise they will have their bad flags cleared, since they will not contain any bad values.', ); # pp_def minmaximum synonym(qw(minmaximum minmaxover)); # Generate small ops functions to do entire array # How to handle a return value of BAD - ie what # datatype to use? for my $op ( ['avg','average','average'], ['sum','sumover','sum'], ['prod','prodover','product'], ['davg','daverage','average (in double precision)'], ['dsum','dsumover','sum (in double precision)'], ['dprod','dprodover','product (in double precision)'], ['zcheck','zcover','check for zero'], ['and','andover','logical and'], ['band','bandover','bitwise and'], ['or','orover','logical or'], ['bor','borover','bitwise or'], ['min','minimum','minimum'], ['max','maximum','maximum'], ['median', 'medover', 'median'], ['mode', 'modeover', 'mode'], ['oddmedian','oddmedover','oddmedian']) { my $name = $op->[0]; my $func = $op->[1]; my $text = $op->[2]; pp_add_exported('', $name); pp_addpm(<<"EOD"); =head2 $name =for ref Return the $text of all elements in an ndarray. See the documentation for L for more information. =for usage \$x = $name(\$data); =for bad This routine handles bad values. =cut *$name = \\&PDL::$name; sub PDL::$name { my(\$x) = \@_; my \$tmp; \$x->clump(-1)->${func}( \$tmp=PDL->nullcreate(\$x) ); \$tmp; } EOD } # for $op pp_add_exported('','any all'); pp_addpm(<<'EOPM'); =head2 any =for ref Return true if any element in ndarray set Useful in conditional expressions: =for example if (any $x>15) { print "some values are greater than 15\n" } =for bad See L for comments on what happens when all elements in the check are bad. =cut *any = \∨ *PDL::any = \&PDL::or; =head2 all =for ref Return true if all elements in ndarray set Useful in conditional expressions: =for example if (all $x>15) { print "all values are greater than 15\n" } =for bad See L for comments on what happens when all elements in the check are bad. =cut *all = \∧ *PDL::all = \&PDL::and; =head2 minmax =for ref Returns a list with minimum and maximum values of an ndarray. =for usage ($mn, $mx) = minmax($pdl); This routine does I thread over the dimensions of C<$pdl>; it returns the minimum and maximum values of the whole ndarray. See L if this is not what is required. The two values are returned as Perl scalars similar to min/max, and therefore ignore whether the values are bad. =for example pdl> $x = pdl [1,-2,3,5,0] pdl> ($min, $max) = minmax($x); pdl> p "$min $max\n"; -2 5 =cut *minmax = \&PDL::minmax; sub PDL::minmax { my ($x)=@_; my $tmp; my @arr = $x->clump(-1)->minmaximum; map $_->sclr, @arr[0,1]; # as scalars ! } EOPM pp_add_exported('', 'minmax'); pp_addhdr(PDL::PP::pp_line_numbers(__LINE__, <<'EOF')); PDL_TYPELIST_REAL(PDL_QSORT) /* Internal utility sorting routine for median/qsort/qsortvec routines. */ #define X(symbol, ctype, ppsym, ...) \ static inline void qsort_ind_ ## ppsym(ctype* xx, PDL_Indx* ix, PDL_Indx a, PDL_Indx b) { \ PDL_Indx i,j; \ PDL_Indx t; \ ctype median; \ i = a; j = b; \ median = xx[ix[(i+j) / 2]]; \ do { \ while (xx[ix[i]] < median) \ i++; \ while (median < xx[ix[j]]) \ j--; \ if (i <= j) { \ t = ix[i]; ix[i] = ix[j]; ix[j] = t; \ i++; j--; \ } \ } while (i <= j); \ if (a < j) \ qsort_ind_ ## ppsym(xx,ix,a,j); \ if (i < b) \ qsort_ind_ ## ppsym(xx,ix,i,b); \ } PDL_TYPELIST_REAL(X) #undef X #define X(symbol, ctype, ppsym, ...) \ /******* \ * qsortvec helper routines \ * --CED 21-Aug-2003 \ */ \ /* Compare a vector in lexicographic order, return equivalent of "<=>". \ */ \ static inline signed int pdl_cmpvec_ ## ppsym(ctype *a, ctype *b, PDL_Indx n) { \ PDL_Indx i; \ for(i=0; i *b ) return 1; \ } \ return 0; \ } PDL_TYPELIST_REAL(X) #undef X #define PDL_QSORTVEC(ppsym, RECURSE, INDEXTERM, swapcode) \ PDL_Indx i,j, median_ind; \ i = a; \ j = b; \ median_ind = (i+j)/2; \ do { \ while( pdl_cmpvec_ ## ppsym( &(xx[n*INDEXTERM(i)]), &(xx[n*INDEXTERM(median_ind)]), n ) < 0 ) \ i++; \ while( pdl_cmpvec_ ## ppsym( &(xx[n*INDEXTERM(j)]), &(xx[n*INDEXTERM(median_ind)]), n ) > 0 ) \ j--; \ if(i<=j) { \ PDL_Indx k; \ swapcode \ if (median_ind==i) \ median_ind=j; \ else if (median_ind==j) \ median_ind=i; \ i++; \ j--; \ } \ } while (i <= j); \ if (a < j) \ RECURSE( ppsym, a, j ); \ if (i < b) \ RECURSE( ppsym, i, b ); #define PDL_QSORTVEC_INDEXTERM(indexterm) indexterm #define PDL_QSORTVEC_RECURSE(ppsym, ...) pdl_qsortvec_ ## ppsym(xx, n, __VA_ARGS__) #define X(symbol, ctype, ppsym, ...) \ static inline void pdl_qsortvec_ ## ppsym(ctype *xx, PDL_Indx n, PDL_Indx a, PDL_Indx b) { \ PDL_QSORTVEC(ppsym, PDL_QSORTVEC_RECURSE, PDL_QSORTVEC_INDEXTERM, \ ctype *aa = &xx[n*i]; \ ctype *bb = &xx[n*j]; \ for( k=0; k 1, Pars => 'a(n); [o]b(); [t]tmp(n);', Doc => projectdocs('median','medover',''), Code => "PDL_Indx nn2;\n" . $copy_to_temp_good . $find_median_average, BadCode => $copy_to_temp_bad . ' PDL_Indx nn1, nn2; nn -= 1; ' . generic_qsort('tmp') . $find_median_average . '}', ); # pp_def: medover pp_def( 'oddmedover', HandleBad => 1, Pars => 'a(n); [o]b(); [t]tmp(n);', Doc => projectdocs('oddmedian','oddmedover',' The median is sometimes not a good choice as if the array has an even number of elements it lies half-way between the two middle values - thus it does not always correspond to a data value. The lower-odd median is just the lower of these two values and so it ALWAYS sits on an actual data value which is useful in some circumstances. '), Code => $copy_to_temp_good . $find_median_lower, BadCode => $copy_to_temp_bad . ' PDL_Indx nn1; nn -= 1; '. $find_median_lower . '}', ); # pp_def: oddmedover pp_def('modeover', HandleBad=>undef, Pars => 'data(n); [o]out(); [t]sorted(n);', GenericTypes=>$T, Doc=>projectdocs('mode','modeover',' The mode is the single element most frequently found in a discrete data set. It I makes sense for integer data types, since floating-point types are demoted to integer before the mode is calculated. C treats BAD the same as any other value: if BAD is the most common element, the returned value is also BAD. '), Code => <<'EOCODE', PDL_Indx i = 0; PDL_Indx most = 0; $GENERIC() curmode = 0; $GENERIC() curval = 0; /* Copy input to buffer for sorting, and sort it */ loop(n) %{ $sorted() = $data(); %} qsort_$PPSYM()($P(sorted),0,$SIZE(n)-1); /* Walk through the sorted data and find the most common elemen */ loop(n) %{ if( n==0 || curval != $sorted() ) { curval = $sorted(); i=0; } else { i++; if(i>most){ most=i; curmode = curval; } } %} $out() = curmode; EOCODE ); my $find_pct_interpolate = ' np = nn * $p(); nn1 = np; nn2 = nn1+1; nn1 = (nn1 < 0) ? 0 : nn1; nn2 = (nn2 < 0) ? 0 : nn2; nn1 = (nn1 > nn) ? nn : nn1; nn2 = (nn2 > nn) ? nn : nn2; if (nn == 0) { pp1 = 0; pp2 = 0; } else { pp1 = (double)nn1/(double)(nn); pp2 = (double)nn2/(double)(nn); } if ( np <= 0.0 ) { $b() = $tmp(n => 0); } else if ( np >= nn ) { $b() = $tmp(n => nn); } else if ($tmp(n => nn2) == $tmp(n => nn1)) { $b() = $tmp(n => nn1); } else if ($p() == pp1) { $b() = $tmp(n => nn1); } else if ($p() == pp2) { $b() = $tmp(n => nn2); } else { $b() = (np - nn1)*($tmp(n => nn2) - $tmp(n => nn1)) + $tmp(n => nn1); } '; pp_def('pctover', HandleBad => 1, Pars => 'a(n); p(); [o]b(); [t]tmp(n);', Doc => projectdocs('specified percentile', 'pctover', 'The specified percentile must be between 0.0 and 1.0. When the specified percentile falls between data points, the result is interpolated. Values outside the allowed range are clipped to 0.0 or 1.0 respectively. The algorithm implemented here is based on the interpolation variant described at L as used by Microsoft Excel and recommended by NIST. '), Code => ' double np, pp1, pp2; PDL_Indx nn2; ' . $copy_to_temp_good . $find_pct_interpolate, BadCode => $copy_to_temp_bad . ' PDL_Indx nn1, nn2; double np, pp1, pp2; nn -= 1; ' . generic_qsort('tmp') . $find_pct_interpolate . '}', ); pp_def('oddpctover', HandleBad => 1, Pars => 'a(n); p(); [o]b(); [t]tmp(n);', Doc => projectdocs('specified percentile', 'oddpctover', 'The specified percentile must be between 0.0 and 1.0. When the specified percentile falls between two values, the nearest data value is the result. The algorithm implemented is from the textbook version described first at L. '), Code => ' PDL_Indx np; ' . $copy_to_temp_good . ' np = (nn+1)*$p(); if (np > nn) np = nn; if (np < 0) np = 0; $b() = $tmp(n => np); ', BadCode => 'PDL_Indx np; ' . $copy_to_temp_bad . ' nn -= 1; ' . generic_qsort('tmp') . ' np = (nn+1)*$p(); if (np > nn) np = nn; if (np < 0) np = 0; $b() = $tmp(n => np); }', ); pp_add_exported('', 'pct'); pp_addpm(<<'EOD'); =head2 pct =for ref Return the specified percentile of all elements in an ndarray. The specified percentile (p) must be between 0.0 and 1.0. When the specified percentile falls between data points, the result is interpolated. =for usage $x = pct($data, $pct); =cut *pct = \&PDL::pct; sub PDL::pct { my($x, $p) = @_; $x->clump(-1)->pctover($p, my $tmp=PDL->nullcreate($x)); $tmp; } EOD pp_add_exported('', 'oddpct'); pp_addpm(<<'EOD'); =head2 oddpct =for ref Return the specified percentile of all elements in an ndarray. The specified percentile must be between 0.0 and 1.0. When the specified percentile falls between two values, the nearest data value is the result. =for usage $x = oddpct($data, $pct); =cut *oddpct = \&PDL::oddpct; sub PDL::oddpct { my($x, $p) = @_; $x->clump(-1)->oddpctover($p, my $tmp=PDL->nullcreate($x)); $tmp; } EOD sub qsort_croak { my ($out, $insizedim, $outsizedim) = @_; 'if ($PDL(a)->dims['.$insizedim.'] != $PDL('.$out.')->dims['.$outsizedim.'] && $PDL(a)->dims['.$insizedim.'] > 1) /* last term detects non-trivial sort */ $CROAK("You likely passed a scalar argument, when you should have passed an ndarray (or nothing at all)"); if ($PDL(a)->nvals == 0) return PDL_err; ' } # move all bad values to the end of the array # pp_def( 'qsort', HandleBad => 1, Inplace => 1, Pars => 'a(n); [o]b(n);', Code => 'PDL_Indx nn; '.qsort_croak('b',0,0).' loop(n) %{ $b() = $a(); %} nn = $SIZE(n)-1; '.generic_qsort('b'), BadCode => 'register PDL_Indx nn = 0, nb = $SIZE(n) - 1; '.qsort_croak('b',0,0).' loop(n) %{ if ( $ISGOOD(a()) ) { $b(n=>nn) = $a(); nn++; } else { $SETBAD(b(n=>nb)); nb--; } %} if ( nn != 0 ) { nn -= 1; ' . generic_qsort('b') . ' }', Doc => ' =for ref Quicksort a vector into ascending order. =for example print qsort random(10); =cut ', BadDoc => ' Bad values are moved to the end of the array: pdl> p $y [42 47 98 BAD 22 96 74 41 79 76 96 BAD 32 76 25 59 BAD 96 32 BAD] pdl> p qsort($y) [22 25 32 32 41 42 47 59 74 76 76 79 96 96 96 98 BAD BAD BAD BAD] ', ); # pp_def qsort sub generic_qsort_ind { 'qsort_ind_$PPSYM() ($P(a), $P(indx), 0, nn);'; } pp_def( 'qsorti', HandleBad => 1, Pars => 'a(n); indx [o]indx(n);', Code => 'PDL_Indx nn = $SIZE(n)-1; if ($SIZE(n) == 0) return PDL_err; '.qsort_croak('indx',0,0).' loop(n) %{ $indx() = n; %} '.generic_qsort_ind(), BadCode => 'register PDL_Indx nn = 0, nb = $SIZE(n) - 1; if ($SIZE(n) == 0) return PDL_err; '.qsort_croak('indx',0,0).' loop(n) %{ if ( $ISGOOD(a()) ) { $indx(n=>nn) = n; nn++; } /* play safe since nn used more than once */ else { $indx(n=>nb) = n; nb--; } %} if ( nn != 0 ) { nn -= 1; ' . generic_qsort_ind() . ' }', BadDoc => 'Bad elements are moved to the end of the array: pdl> p $y [42 47 98 BAD 22 96 74 41 79 76 96 BAD 32 76 25 59 BAD 96 32 BAD] pdl> p $y->index( qsorti($y) ) [22 25 32 32 41 42 47 59 74 76 76 79 96 96 96 98 BAD BAD BAD BAD] ', Doc => ' =for ref Quicksort a vector and return index of elements in ascending order. =for example $ix = qsorti $x; print $x->index($ix); # Sorted list =cut ' ); # pp_def: qsorti # move all bad values to the end of the array # pp_def( 'qsortvec', HandleBad => 1, Inplace => 1, Pars => 'a(n,m); [o]b(n,m);', Code => 'PDL_Indx nn = ($SIZE(m))-1; PDL_Indx nd = $SIZE(n); '.qsort_croak('b',1,1).' if ($P(a) != $P(b)) loop(n,m) %{ $b() = $a(); %} '.generic_qsortvec('b','nd'), BadCode => 'register PDL_Indx nn = 0, nb = $SIZE(m) - 1; char is_inplace = ($P(a) == $P(b)); PDL_Indx nd = $SIZE(n); '.qsort_croak('b',1,1).' loop(m) %{ char allgood_a = 1; loop(n) %{ if ( $ISBAD(a()) ) { allgood_a = 0; break; } %} PDL_Indx copy_dest = allgood_a ? nn++ : nb--; if (is_inplace) { if (allgood_a) continue; /* nothing to do */ char anybad_b = 0; do { anybad_b = 0; loop(n) %{ if ($ISBAD(b(m=>copy_dest))) { anybad_b = 1; break; } %} if (anybad_b) copy_dest = nb--; } while (anybad_b); if (m != copy_dest) loop(n) %{ /* as in-place we know same badval source and dest */ $GENERIC() tmp = $b(m=>copy_dest); $b(m=>copy_dest) = $a(); $a() = tmp; %} if (m >= nb-1) { nn = nb+1; break; } /* run out of "good" vectors */ } else { loop(n) %{ if ($ISGOOD(a())) $b(m=>copy_dest) = $a(); else $SETBAD(b(m=>copy_dest)); %} } %} if ( nn != 0 ) { nn -= 1;' . generic_qsortvec('b','nd') .' }', Doc => ' =for ref Sort a list of vectors lexicographically. The 0th dimension of the source ndarray is dimension in the vector; the 1st dimension is list order. Higher dimensions are threaded over. =for example print qsortvec pdl([[1,2],[0,500],[2,3],[4,2],[3,4],[3,5]]); [ [ 0 500] [ 1 2] [ 2 3] [ 3 4] [ 3 5] [ 4 2] ] =cut ', BadDoc => ' Vectors with bad components are moved to the end of the array: pdl> p $p = pdl("[0 0] [-100 0] [BAD 0] [100 0]")->qsortvec [ [-100 0] [ 0 0] [ 100 0] [ BAD 0] ] ', ); # pp_def qsortvec sub generic_qsortvec_ind { my $pdl = shift; my $ndim = shift; 'pdl_qsortvec_ind_$PPSYM() ($P(' . $pdl . '), $P(indx), '. $ndim.', 0, nn);'; } pp_def( 'qsortveci', HandleBad => 1, Pars => 'a(n,m); indx [o]indx(m);', Code => 'PDL_Indx nd = $SIZE(n); PDL_Indx nn=$SIZE(m)-1; '.qsort_croak('indx',1,0).' loop(m) %{ $indx()=m; %} '.generic_qsortvec_ind('a','nd'), BadCode => 'register PDL_Indx nn = 0, nb = $SIZE(m) - 1; PDL_Indx nd = $SIZE(n); '.qsort_croak('indx',1,0).' loop(m) %{ char allgood_a = 1; loop(n) %{ if ( $ISBAD(a()) ) { allgood_a = 0; break; } %} PDL_Indx copy_dest = allgood_a ? nn++ : nb--; $indx(m=>copy_dest) = m; %} if ( nn != 0 ) { nn -= 1;' . generic_qsortvec_ind('a','nd') .' }', Doc => ' =for ref Sort a list of vectors lexicographically, returning the indices of the sorted vectors rather than the sorted list itself. As with C, the input PDL should be an NxM array containing M separate N-dimensional vectors. The return value is an integer M-PDL containing the M-indices of original array rows, in sorted order. As with C, the zeroth element of the vectors runs slowest in the sorted list. Additional dimensions are threaded over: each plane is sorted separately, so qsortveci may be thought of as a collapse operator of sorts (groan). =cut ', BadDoc => ' Vectors with bad components are moved to the end of the array as for L. ', ); pp_addpm({At=>'Bot'},<<'EOD'); =head1 AUTHOR Copyright (C) Tuomas J. Lukka 1997 (lukka@husc.harvard.edu). Contributions by Christian Soeller (c.soeller@auckland.ac.nz) and Karl Glazebrook (kgb@aaoepp.aao.gov.au). 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(); PDL-2.074/Basic/Ufunc/Makefile.PL0000644000175000017500000000065614176424544016170 0ustar osboxesosboxesuse strict; use warnings; use ExtUtils::MakeMaker; use ExtUtils::MakeMaker::Config; use File::Spec::Functions; my @pack = (["ufunc.pd", qw(Ufunc PDL::Ufunc)]); my %hash = pdlpp_stdargs_int(@pack); $hash{LIBS}->[0] .= ' -lm'; $hash{depend} = { 'pp-bandover$(OBJ_EXT)' => catfile(updir, qw(Core pdlperl.h)) }; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.074/Basic/Complex/0000755000175000017500000000000014200406301014511 5ustar osboxesosboxesPDL-2.074/Basic/Complex/complex.pd0000644000175000017500000007462014200376722016533 0ustar osboxesosboxesuse strict; use warnings; use PDL::Types qw(ppdefs ppdefs_complex types); my $R = [ppdefs()]; my $F = [map $_->ppsym, grep $_->real && !$_->integer, types()]; my $C = [ppdefs_complex()]; pp_beginwrap; # required for overload to work # pp_def functions go into the PDL::Complex namespace # to avoid clashing with PDL::FFTW funcs of the same name that go # into the PDL namespace # it should be of no effect to the user of the module but you # never know.... pp_bless('PDL::Complex'); pp_addpm {At => 'Top'}, <<'EOD'; use strict; use warnings; use Carp; our $VERSION = '2.009'; use PDL::Slices; use PDL::Types; use PDL::Bad; use vars qw($sep $sep2); EOD pp_addpm {At => 'Top'}, <<'EOD'; =encoding iso-8859-1 =head1 NAME PDL::Complex - handle complex numbers (DEPRECATED - use native complex) =head1 SYNOPSIS use PDL; use PDL::Complex; =head1 DESCRIPTION This module is deprecated in favour of using "native complex" data types, e.g.: use PDL; my $complex_pdl = cdouble('[1+3i]'); print $complex_pdl * pdl('i'); # [-3+i] This module features a growing number of functions manipulating complex numbers. These are usually represented as a pair C<[ real imag ]> or C<[ magnitude phase ]>. If not explicitly mentioned, the functions can work inplace (not yet implemented!!!) and require rectangular form. While there is a procedural interface available (C<< $x/$y*$c <=> Cmul (Cdiv ($x, $y), $c) >>), you can also opt to cast your pdl's into the C datatype, which works just like your normal ndarrays, but with all the normal perl operators overloaded. The latter means that C will be evaluated using the normal rules of complex numbers, while other pdl functions (like C) just treat the ndarray as a real-valued ndarray with a lowest dimension of size 2, so C will return the maximum of all real and imaginary parts, not the "highest" (for some definition) =head2 Native complex support 2.027 added changes in complex number handling, with support for C99 complex floating-point types, and most functions and modules in the core distribution support these as well. PDL can now handle complex numbers natively as scalars. This has the advantage that real and complex valued ndarrays have the same dimensions. Consider this when writing code in the future. See L, L, L, L, L for more. =head1 TIPS, TRICKS & CAVEATS =over 4 =item * C is a function (not, as of 2.047, a constant) exported by this module, which represents C<-1**0.5>, i.e. the imaginary unit. it can be used to quickly and conveniently write complex constants like this: C<4+3*i>. B This will override the PDL::Core function of the same name, which returns a native complex value. =item * Use C to convert from real to complex, as in C<$r = Cpow $cplx, r2C 2>. The overloaded operators automatically do that for you, all the other functions, do not. So C will return all the fifths roots of 1+1*i (due to threading). =item * use C to cast from normal ndarrays into the complex datatype. Use C to cast back. This requires a copy, though. =item * This module has received some testing by Vanuxem Grégory (g.vanuxem at wanadoo dot fr). Please report any other errors you come across! =back =head1 EXAMPLE WALK-THROUGH The complex constant five is equal to C: pdl> p $x = r2C 5 5 +0i Now calculate the three cubic roots of five: pdl> p $r = Croots $x, 3 [1.70998 +0i -0.854988 +1.48088i -0.854988 -1.48088i] Check that these really are the roots: pdl> p $r ** 3 [5 +0i 5 -1.22465e-15i 5 -7.65714e-15i] Duh! Could be better. Now try by multiplying C<$r> three times with itself: pdl> p $r*$r*$r [5 +0i 5 -4.72647e-15i 5 -7.53694e-15i] Well... maybe C (which is used by the C<**> operator) isn't as bad as I thought. Now multiply by C and negate, then take the complex conjugate, which is just a very expensive way of swapping real and imaginary parts. pdl> p Cconj(-($r*i)) [0 +1.70998i 1.48088 -0.854988i -1.48088 -0.854988i] Now plot the magnitude of (part of) the complex sine. First generate the coefficients: pdl> $sin = i * zeroes(50)->xlinvals(2,4) + zeroes(50)->xlinvals(0,7) Now plot the imaginary part, the real part and the magnitude of the sine into the same diagram: pdl> use PDL::Graphics::Gnuplot pdl> gplot( with => 'lines', PDL::cat(im ( sin $sin ), re ( sin $sin ), abs( sin $sin ) )) An ASCII version of this plot looks like this: 30 ++-----+------+------+------+------+------+------+------+------+-----++ + + + + + + + + + + + | $$| | $ | 25 ++ $$ ++ | *** | | ** *** | | $$* *| 20 ++ $** ++ | $$$* #| | $$$ * # | | $$ * # | 15 ++ $$$ * # ++ | $$$ ** # | | $$$$ * # | | $$$$ * # | 10 ++ $$$$$ * # ++ | $$$$$ * # | | $$$$$$$ * # | 5 ++ $$$############ * # ++ |*****$$$### ### * # | * #***** # * # | | ### *** ### ** # | 0 ## *** # * # ++ | * # * # | | *** # ** # | | * # * # | -5 ++ ** # * # ++ | *** ## ** # | | * #* # | | **** ***## # | -10 ++ **** # # ++ | # # | | ## ## | + + + + + + + ### + ### + + + -15 ++-----+------+------+------+------+------+-----###-----+------+-----++ 0 5 10 15 20 25 30 35 40 45 50 =head1 OPERATORS The following operators are overloaded: =over 4 =item +, += (addition) =item -, -= (subtraction) =item *, *= (multiplication; L) =item /, /= (division; L) =item **, **= (exponentiation; L) =item atan2 (4-quadrant arc tangent) =item sin (L) =item cos (L) =item exp (L) =item abs (L) =item log (L) =item sqrt (L) =item ++, -- (increment, decrement; they affect the real part of the complex number only) =item "" (stringification) =back Comparing complex numbers other than for equality is a fatal error. =cut my $i; BEGIN { $i = bless pdl 0,1 } { no warnings 'redefine'; sub i { $i->copy + (@_ ? $_[0] : 0) }; } EOD for (qw(Ctan Catan re im i cplx real)) { pp_add_exported '', $_; } pp_addhdr <<'EOH'; #include #ifndef M_PI # define M_PI 3.1415926535897932384626433832795029 #endif #ifndef M_2PI # define M_2PI (2. * M_PI) #endif #if __GLIBC__ > 1 && (defined __USE_MISC || defined __USE_XOPEN || defined __USE_ISOC9X) # define CABS(r,i) hypot (r, i) #else static double CABS (double r, double i) { double t; if (r < 0) r = - r; if (i < 0) i = - i; if (i > r) { t = r; r = i; i = t; } if (r + i == r) return r; t = i / r; return r * sqrt (1 + t*t); } #endif #if __GLIBC__ >= 2 && __GLIBC_MINOR__ >= 1 && defined __USE_GNU # define SINCOS(x,s,c) sincos ((x), &(s), &(c)) #else # define SINCOS(x,s,c) \ (s) = sin (x); \ (c) = cos (x); #endif #define CSQRT(type,ar,ai,cr,ci) \ type mag = CABS ((ar), (ai)); \ type t; \ \ if (mag == 0) \ (cr) = (ci) = 0; \ else if ((ar) > 0) \ { \ t = sqrt (0.5 * (mag + (ar))); \ (cr) = t; \ (ci) = 0.5 * (ai) / t; \ } \ else \ { \ t = sqrt (0.5 * (mag - (ar))); \ \ if ((ai) < 0) \ t = -t; \ \ (cr) = 0.5 * (ai) / t; \ (ci) = t; \ } #define CLOG(ar,ai,cr,ci) \ (cr) = log (CABS ((ar), (ai))); \ (ci) = atan2 ((ai), (ar)); EOH pp_addpm <<'EOP'; =head2 from_native =for ref Class method to convert a native-complex ndarray to a PDL::Complex object. =for usage PDL::Complex->from_native($native_complex_ndarray) =cut sub from_native { my ($class, $ndarray) = @_; return $ndarray if UNIVERSAL::isa($ndarray,'PDL::Complex'); # NOOP if P:C croak "not an ndarray" if !UNIVERSAL::isa($ndarray,'PDL'); croak "not a native complex ndarray" if $ndarray->type->real; bless PDL::append($ndarray->re->dummy(0),$ndarray->im->dummy(0)), $class; } =head2 as_native =for ref Object method to convert a PDL::Complex object to a native-complex ndarray. =for usage $pdl_complex_obj->as_native =cut sub as_native { PDL::Ops::czip(map $_[0]->slice("($_)"), 0..1); } =head2 cplx =for ref Cast a real-valued ndarray to the complex datatype. The first dimension of the ndarray must be of size 2. After this the usual (complex) arithmetic operators are applied to this pdl, rather than the normal elementwise pdl operators. Dataflow to the complex parent works. Use C on the result if you don't want this. =for usage cplx($real_valued_pdl) =head2 complex =for ref Cast a real-valued ndarray to the complex datatype I dataflow and I. Achieved by merely reblessing an ndarray. The first dimension of the ndarray must be of size 2. =for usage complex($real_valued_pdl) =head2 real =for ref Cast a complex valued pdl back to the "normal" pdl datatype. Afterwards the normal elementwise pdl operators are used in operations. Dataflow to the real parent works. Use C on the result if you don't want this. =for usage real($cplx_valued_pdl) =cut sub cplx($) { return $_[0] if UNIVERSAL::isa($_[0],'PDL::Complex'); # NOOP if just ndarray croak "first dimsize must be 2" unless $_[0]->dims > 0 && $_[0]->dim(0) == 2; bless $_[0]->slice(''); } sub complex($) { return $_[0] if UNIVERSAL::isa($_[0],'PDL::Complex'); # NOOP if just ndarray croak "first dimsize must be 2" unless $_[0]->dims > 0 && $_[0]->dim(0) == 2; bless $_[0]; } *PDL::cplx = \&cplx; *PDL::complex = \&complex; sub real($) { return $_[0] unless UNIVERSAL::isa($_[0],'PDL::Complex'); # NOOP unless complex bless $_[0]->slice(''), 'PDL'; } EOP pp_def 'r2C', Pars => 'r(); [o]c(m=2)', Doc => 'convert real to complex, assuming an imaginary part of zero', PMCode => << 'EOPM', undef &PDL::r2C; *PDL::r2C = \&PDL::Complex::r2C; sub PDL::Complex::r2C { return $_[0] if UNIVERSAL::isa($_[0],'PDL::Complex'); my $r = __PACKAGE__->initialize; &PDL::Complex::_r2C_int($_[0], $r); $r } EOPM Code => q! $c(m=>0) = $r(); $c(m=>1) = 0; ! ; pp_def 'i2C', Pars => 'r(); [o]c(m=2)', Doc => 'convert imaginary to complex, assuming a real part of zero', PMCode => 'undef &PDL::i2C; *PDL::i2C = \&PDL::Complex::i2C; sub PDL::Complex::i2C { my $r = __PACKAGE__->initialize; &PDL::Complex::_i2C_int($_[0], $r); $r }', Code => q! $c(m=>0) = 0; $c(m=>1) = $r(); ! ; pp_def 'Cr2p', Pars => 'r(m=2); float+ [o]p(m=2)', Inplace => 1, Doc => 'convert complex numbers in rectangular form to polar (mod,arg) form. Works inplace', Code => q! $GENERIC() x = $r(m=>0); $GENERIC() y = $r(m=>1); $p(m=>0) = CABS (x, y); $p(m=>1) = atan2 (y, x); ! ; pp_def 'Cp2r', Pars => 'r(m=2); [o]p(m=2)', Inplace => 1, GenericTypes => $F, Doc => 'convert complex numbers in polar (mod,arg) form to rectangular form. Works inplace', Code => q! $GENERIC() m = $r(m=>0); $GENERIC() a = $r(m=>1); double s, c; SINCOS (a, s, c); $p(m=>0) = c * m; $p(m=>1) = s * m; ! ; pp_def 'Cadd', # this is here for a) completeness and b) not having to mess with PDL::Ops Pars => 'a(m=2); b(m=2); [o]c(m=2)', Doc => undef, Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); $GENERIC() br = $b(m=>0), bi = $b(m=>1); $c(m=>0) = ar + br; $c(m=>1) = ai + bi; ^ ; pp_def 'Csub', # this is here for a) completeness and b) not having to mess with PDL::Ops Pars => 'a(m=2); b(m=2); [o]c(m=2)', Doc => undef, Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); $GENERIC() br = $b(m=>0), bi = $b(m=>1); $c(m=>0) = ar - br; $c(m=>1) = ai - bi; ^ ; pp_def 'Cmul', Pars => 'a(m=2); b(m=2); [o]c(m=2)', Doc => 'complex multiplication', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); $GENERIC() br = $b(m=>0), bi = $b(m=>1); $c(m=>0) = ar*br - ai*bi; $c(m=>1) = ar*bi + ai*br; ^ ; pp_def 'Cprodover', Pars => 'a(m=2,n); [o]c(m=2)', Doc => 'Project via product to N-1 dimension', Code => q^ PDL_Long iter; $GENERIC() br, bi, cr, ci,tmp; cr = $a(m=>0,n=>0); ci = $a(m=>1,n=>0); for (iter=1; iter < $SIZE(n);iter++) { br = $a(m=>0,n=>iter); bi = $a(m=>1,n=>iter); tmp = cr*bi + ci*br; cr = cr*br - ci*bi; ci = tmp; } $c(m=>0) = cr; $c(m=>1) = ci; ^ ; pp_def 'Cscale', Pars => 'a(m=2); b(); [o]c(m=2)', Doc => 'mixed complex/real multiplication', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); $c(m=>0) = ar * $b(); $c(m=>1) = ai * $b(); ^ ; pp_def 'Cdiv', Pars => 'a(m=2); b(m=2); [o]c(m=2)', GenericTypes => $F, Doc => 'complex division', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); $GENERIC() br = $b(m=>0), bi = $b(m=>1); if (fabs (br) > fabs (bi)) { $GENERIC() tt = bi / br; $GENERIC() dn = br + tt * bi; $c(m=>0) = (ar + tt * ai) / dn; $c(m=>1) = (ai - tt * ar) / dn; } else { $GENERIC() tt = br / bi; $GENERIC() dn = br * tt + bi; $c(m=>0) = (ar * tt + ai) / dn; $c(m=>1) = (ai * tt - ar) / dn; } ^ ; pp_def 'Ceq', Pars => 'a(m=2); b(m=2); [o]c()', GenericTypes => $F, Doc => "=for ref\n\nComplex equality operator.", Code => q^ $c() = (($a(m=>0) == $b(m=>0)) && ($a(m=>1) == $b(m=>1))); ^, PMCode => <<'EOF', sub PDL::Complex::Ceq { my @args = !$_[2] ? @_[1,0] : @_[0,1]; $args[1] = r2C($args[1]) if ref $args[1] ne __PACKAGE__; PDL::Complex::_Ceq_int($args[0], $args[1], my $r = PDL->null); $r; } EOF ; pp_def 'Cconj', Pars => 'a(m=2); [o]c(m=2)', Inplace => 1, Doc => 'complex conjugation. Works inplace', Code => q^ $c(m=>0) = $a(m=>0); $c(m=>1) = -$a(m=>1); ^ ; pp_def 'Cabs', Pars => 'a(m=2); [o]c()', GenericTypes => $F, Doc => 'complex C (also known as I)', PMCode => q^sub PDL::Complex::Cabs($) { my $pdl= shift; my $abs = PDL->null; &PDL::Complex::_Cabs_int($pdl, $abs); $abs; }^, Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); $c() = CABS (ar, ai); ^ ; pp_def 'Cabs2', Pars => 'a(m=2); [o]c()', Doc => 'complex squared C (also known I)', PMCode => q^sub PDL::Complex::Cabs2($) { my $pdl= shift; my $abs2 = PDL->null; &PDL::Complex::_Cabs2_int($pdl, $abs2); $abs2; }^, Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); $c() = ar*ar + ai*ai; ^ ; pp_def 'Carg', Pars => 'a(m=2); [o]c()', GenericTypes => $F, Doc => 'complex argument function ("angle")', PMCode => q^sub PDL::Complex::Carg($) { my $pdl= shift; my $arg = PDL->null; &PDL::Complex::_Carg_int($pdl, $arg); $arg; }^, Code => q^ $c() = atan2 ($a(m=>1), $a(m=>0)); ^ ; pp_def 'Csin', Pars => 'a(m=2); [o]c(m=2)', Inplace => 1, GenericTypes => $F, Doc => ' sin (a) = 1/(2*i) * (exp (a*i) - exp (-a*i)). Works inplace', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); double s, c; SINCOS (ar, s, c); $c(m=>0) = s * cosh (ai); $c(m=>1) = c * sinh (ai); ^ ; pp_def 'Ccos', Pars => 'a(m=2); [o]c(m=2)', Inplace => 1, GenericTypes => $F, Doc => ' cos (a) = 1/2 * (exp (a*i) + exp (-a*i)). Works inplace', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); double s, c; SINCOS (ar, s, c); $c(m=>0) = c * cosh (ai); $c(m=>1) = - s * sinh (ai); ^ ; pp_addpm <<'EOD'; =head2 Ctan =for ref Complex tangent tan (a) = -i * (exp (a*i) - exp (-a*i)) / (exp (a*i) + exp (-a*i)) Does not work inplace. =cut sub Ctan($) { Csin($_[0]) / Ccos($_[0]) } EOD pp_def 'Cexp', Pars => 'a(m=2); [o]c(m=2)', Inplace => 1, GenericTypes => $F, Doc => ' exp (a) = exp (real (a)) * (cos (imag (a)) + i * sin (imag (a))). Works inplace', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); $GENERIC() ex = exp (ar); double s, c; SINCOS (ai, s, c); $c(m=>0) = ex * c; $c(m=>1) = ex * s; ^ ; pp_def 'Clog', Pars => 'a(m=2); [o]c(m=2)', Inplace => 1, GenericTypes => $F, Doc => ' log (a) = log (cabs (a)) + i * carg (a). Works inplace', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); CLOG (ar, ai, $c(m=>0), $c(m=>1)); ^ ; pp_def 'Cpow', Pars => 'a(m=2); b(m=2); [o]c(m=2)', Inplace => ['a'], GenericTypes => $F, Doc => 'complex C (C<**>-operator)', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); $GENERIC() br = $b(m=>0), bi = $b(m=>1); PDL_COMMENT(real ndarray (scalar or 1-ndarray)) if($PDL(b)->dims[0]==0) bi = 0; PDL_COMMENT(printf("ar: %f ai: %f\nbr: %f bi: %f\nDimsB: %ld\n",ar,ai,br,bi,$PDL(b)->dims[0]);) double logr, logi, x, y; double s, c; if(ar == 0 && ai == 0){ if(br == 0 && bi == 0) { $c(m=>0) = 1; $c(m=>1) = 0; } else { $c(m=>0) = 0; $c(m=>1) = 0; } } else { CLOG (ar, ai, logr, logi); x = exp (logr*br - logi*bi); y = logr*bi + logi*br; SINCOS (y, s, c); $c(m=>0) = x * c; if(ai == 0 && bi == 0) $c(m=>1) = 0; else $c(m=>1) = x * s; } ^ ; pp_def 'Csqrt', Pars => 'a(m=2); [o]c(m=2)', Inplace => 1, GenericTypes => $F, Doc => 'Works inplace', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); CSQRT ($GENERIC(), ar, ai, $c(m=>0), $c(m=>1)); ^ ; pp_def 'Casin', Pars => 'a(m=2); [o]c(m=2)', Inplace => 1, GenericTypes => $F, Doc => 'Works inplace', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); $GENERIC() t1 = sqrt ((ar+1)*(ar+1) + ai*ai); $GENERIC() t2 = sqrt ((ar-1)*(ar-1) + ai*ai); $GENERIC() alpha = (t1+t2)*0.5; $GENERIC() beta = (t1-t2)*0.5; if (alpha < 1) alpha = 1; if (beta > 1) beta = 1; else if (beta < -1) beta = -1; $c(m=>0) = atan2 (beta, sqrt (1-beta*beta)); $c(m=>1) = - log (alpha + sqrt (alpha*alpha-1)); if (ai > 0 || (ai == 0 && ar < -1)) $c(m=>1) = - $c(m=>1); ^ ; pp_def 'Cacos', Pars => 'a(m=2); [o]c(m=2)', Inplace => 1, GenericTypes => $F, Doc => 'Works inplace', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); $GENERIC() t1 = sqrt ((ar+1)*(ar+1) + ai*ai); $GENERIC() t2 = sqrt ((ar-1)*(ar-1) + ai*ai); $GENERIC() alpha = (t1+t2)*0.5; $GENERIC() beta = (t1-t2)*0.5; if (alpha < 1) alpha = 1; if (beta > 1) beta = 1; else if (beta < -1) beta = -1; $c(m=>0) = atan2 (sqrt (1-beta*beta), beta); $c(m=>1) = log (alpha + sqrt (alpha*alpha-1)); if (ai > 0 || (ai == 0 && ar < -1)) $c(m=>1) = - $c(m=>1); ^ ; pp_addpm <<'EOD'; =head2 Catan =for ref Return the complex C. Does not work inplace. =cut sub Catan($) { my $z = shift; Cmul Clog(Cdiv (PDL::Complex::i()+$z, PDL::Complex::i()-$z)), pdl(0, 0.5); } EOD pp_def 'Csinh', Pars => 'a(m=2); [o]c(m=2)', Inplace => 1, GenericTypes => $F, Doc => ' sinh (a) = (exp (a) - exp (-a)) / 2. Works inplace', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); double s, c; SINCOS (ai, s, c); $c(m=>0) = sinh (ar) * c; $c(m=>1) = cosh (ar) * s; ^ ; pp_def 'Ccosh', Pars => 'a(m=2); [o]c(m=2)', Inplace => 1, GenericTypes => $F, Doc => ' cosh (a) = (exp (a) + exp (-a)) / 2. Works inplace', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); double s, c; SINCOS (ai, s, c); $c(m=>0) = cosh (ar) * c; $c(m=>1) = sinh (ar) * s; ^ ; pp_def 'Ctanh', Pars => 'a(m=2); [o]c(m=2)', Inplace => 1, GenericTypes => $F, Doc => 'Works inplace', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); double den; double s, c; SINCOS (2*ai, s, c); den = cosh (2*ar) + c; $c(m=>0) = sinh (2*ar) / den; $c(m=>1) = s / den; ^ ; pp_def 'Casinh', Pars => 'a(m=2); [o]c(m=2)', Inplace => 1, GenericTypes => $F, Doc => 'Works inplace', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); $GENERIC() yr = (ar-ai) * (ar+ai) + 1; $GENERIC() yi = 2*ar*ai; CSQRT ($GENERIC(), yr, yi, yr, yi) yr += ar; yi += ai; CLOG (yr, yi, $c(m=>0), $c(m=>1)); ^ ; pp_def 'Cacosh', Pars => 'a(m=2); [o]c(m=2)', Inplace => 1, GenericTypes => $F, Doc => 'Works inplace', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); $GENERIC() yr = (ar-ai) * (ar+ai) - 1; $GENERIC() yi = 2*ar*ai; CSQRT ($GENERIC(), yr, yi, yr, yi) yr += ar; yi += ai; CLOG (yr, yi, $c(m=>0), $c(m=>1)); ^ ; pp_def 'Catanh', Pars => 'a(m=2); [o]c(m=2)', Inplace => 1, GenericTypes => $F, Doc => 'Works inplace', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); double i2 = ai*ai; double num = i2 + (1+ar) * (1+ar); double den = i2 + (1-ar) * (1-ar); $c(m=>0) = 0.25 * (log(num) - log(den)); $c(m=>1) = 0.5 * atan2 (2*ai, 1 - ar*ar - i2); ^ ; pp_def 'Cproj', Pars => 'a(m=2); [o]c(m=2)', Inplace => 1, GenericTypes => $F, Doc => 'compute the projection of a complex number to the riemann sphere. Works inplace', Code => q^ $GENERIC() ar = $a(m=>0), ai = $a(m=>1); double den = ar*ar + ai*ai + 1; $c(m=>0) = 2*ar / den; $c(m=>1) = 2*ai / den; ^ ; pp_def 'Croots', Pars => 'a(m=2); [o]c(m=2,n)', OtherPars => 'int n => n', GenericTypes => $F, Doc => 'Compute the C roots of C. C must be a positive integer. The result will always be a complex type!', PMCode => q^sub PDL::Complex::Croots($$) { my ($pdl, $n) = @_; my $r = PDL->null; &PDL::Complex::_Croots_int($pdl, $r, $n); bless $r; }^, Code => q^ double s, c; double ar = $a(m=>0), ai = $a(m=>1), n1 = 1 / (double)$COMP(n), rr = pow (CABS (ar, ai), n1), /* do not optimize the sqrt out of this expr! */ at = atan2 (ai, ar) * n1, ti = M_2PI * n1; loop(n) %{ SINCOS (at, s, c); $c(m=>0) = rr * c; $c(m=>1) = rr * s; at += ti; %} ^ ; pp_addpm <<'EOD'; =head2 re, im Return the real or imaginary part of the complex number(s) given. These are slicing operators, so data flow works. The real and imaginary parts are returned as ndarrays (ref eq PDL). =cut sub re($) { $_[0]->slice("(0)") } sub im($) { $_[0]->slice("(1)") } { no warnings 'redefine'; # if the argument does anything other than pass through 0-th dim, re-bless sub slice :lvalue { my $first = ref $_[1] ? $_[1][0] : (split ',', $_[1])[0]; my $class = ($first//'') =~ /^[:x]?$/i ? ref($_[0]) : 'PDL'; my $ret = bless $_[0]->SUPER::slice(@_[1..$#_]), $class; $ret; } } EOD pp_def 'rCpolynomial', Pars => 'coeffs(n); x(c=2,m); [o]out(c=2,m)', Doc => 'evaluate the polynomial with (real) coefficients C at the (complex) position(s) C. C is the constant term.', GenericTypes => $F, PMCode=> q! sub rCpolynomial { my $coeffs = shift; my $x = shift; my $out = $x->copy; _rCpolynomial_int($coeffs,$x,$out); return PDL::complex($out); } !, Code => q! loop(m) %{ double xr = 1; double xi = 0; double or = 0; double oi = 0; double Xr; loop(n) %{ or += $coeffs() * xr; oi += $coeffs() * xi; Xr = xr; xr = Xr * $x(c=>0) - xi * $x(c=>1); xi = xi * $x(c=>0) + Xr * $x(c=>1); %} $out(c=>0) = or; $out(c=>1) = oi; %} ! ; pp_add_isa 'PDL'; pp_addpm {At => 'Bot'}, <<'EOD'; # overload must be here, so that all the functions can be seen # undocumented compatibility functions (thanks to Luis Mochan!) sub Catan2($$) { Clog( $_[1] + i()*$_[0])/i } sub atan2($$) { Clog( $_[1] + i()*$_[0])/i } =begin comment In _gen_biop, the '+' or '-' between the operator (e.g., '*') and the function that it overloads (e.g., 'Cmul') flags whether the operation is ('+') or is not ('-') commutative. See the discussion of argument swapping in the section "Calling Conventions and Magic Autogeneration" in "perldoc overload". =end comment =cut my %NO_MUTATE; BEGIN { @NO_MUTATE{qw(atan2 .= ==)} = (); } sub _gen_biop { local $_ = shift; my $sub; if (/(\S+)\+(\w+)/) { #commutes $sub = eval 'sub { '.$2.' $_[0], ref $_[1] eq __PACKAGE__ ? $_[1] : r2C $_[1] }'; } elsif (/(\S+)\-(\w+)/) { #does not commute $sub = eval 'sub { my $y = ref $_[1] eq __PACKAGE__ ? $_[1] : r2C $_[1]; $_[2] ? '.$2.' $y, $_[0] : '.$2.' $_[0], $y }'; #need to swap? } else { die; } return ($1, $sub) if exists $NO_MUTATE{$1}; ($1, $sub, "$1=", $sub); } sub _gen_unop { my ($op, $func) = ($_[0] =~ /(.+)@(\w+)/); no strict 'refs'; *$op = \&$func if $op =~ /\w+/; # create an alias ($op, eval 'sub { '.$func.' $_[0] }'); } sub initialize { # Bless a null PDL into the supplied 1st arg package # If 1st arg is a ref, get the package from it bless PDL->null, ref($_[0]) || $_[0]; } # so threading doesn't also assign the real value into the imaginary sub Cassgn { my @args = !$_[2] ? @_[1,0] : @_[0,1]; $args[1] = r2C($args[1]) if ref $args[1] ne __PACKAGE__; PDL::Ops::assgn(@args); $args[1]; } use overload (map _gen_biop($_), qw(++Cadd --Csub *+Cmul /-Cdiv **-Cpow atan2-Catan2 ==+Ceq .=-Cassgn)), (map _gen_unop($_), qw(sin@Csin cos@Ccos exp@Cexp abs@Cabs log@Clog sqrt@Csqrt)), (map +($_ => sub { confess "Can't compare complex numbers" }), qw(< > <= >=)), "!=" => sub { !($_[0] == $_[1]) }, '""' => sub { $_[0]->isnull ? "PDL::Complex->null" : $_[0]->as_native->string }, ; sub sum { my($x) = @_; return $x if $x->dims==1; my $tmp = $x->mv(0,-1)->clump(-2)->mv(1,0)->sumover; return $tmp; } sub sumover{ my $m = shift; PDL::Ufunc::sumover($m->transpose); } *PDL::Complex::Csumover=\&sumover; # define through alias *PDL::Complex::prodover=\&Cprodover; # define through alias sub prod { my($x) = @_; return $x if $x->dims==1; my $tmp = $x->mv(0,-1)->clump(-2)->mv(1,0)->prodover; return $tmp; } =head1 AUTHOR Copyright (C) 2000 Marc Lehmann . All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation as described in the file COPYING in the PDL distribution. =head1 SEE ALSO perl(1), L. =cut EOD pp_done; PDL-2.074/Basic/Complex/t/0000755000175000017500000000000014200406301014754 5ustar osboxesosboxesPDL-2.074/Basic/Complex/t/complex.t0000644000175000017500000003100014200376610016613 0ustar osboxesosboxesuse strict; use warnings; use PDL::Lite; use PDL::Complex; use PDL::Math; use Test::More; sub tapprox { my($x,$y) = @_; my $c = abs($x-$y); my $d = PDL::max($c); $d < 0.0001; } #Type of cplx and cmplx my $x=PDL->sequence(2); my $y=$x->cplx; is(ref $y, 'PDL::Complex', 'type of cplx'); is(ref $x, 'PDL', "cplx doesn't modify original pdl"); my $z=$y->real; is(ref $z, 'PDL', 'real returns type to pdl'); is(ref $y, 'PDL::Complex', "real doesn't change type of parent"); #Should there be a real subroutine, such as complex, that does change #the parent? $y=$x->complex; is(ref $y, 'PDL::Complex', 'type of complex'); is(ref $x, 'PDL::Complex', 'complex does modify original pdl'); eval { my $string = PDL::Complex->null.'' }; is $@, '', 'can stringify complex null'; #Check r2C is(ref r2C(1), 'PDL::Complex', 'type of r2C'); is(r2C(1)->re, 1, 'real part of r2C'); is(r2C(1)->im, 0, 'imaginary part of r2C'); #Check i2C is(ref i2C(1), 'PDL::Complex', 'type of i2C'); is(i2C(1)->re, 0, 'real part of i2C'); is(i2C(1)->im, 1, 'imaginary part of i2C'); #Test mixed complex-real operations my $ref = pdl(-1,1); $x = i - 1; is(ref $x, 'PDL::Complex', 'type promotion i - real scalar'); ok(tapprox($x->real,$ref), 'value from i - real scalar') or diag "x=$x, real=", $x->real, "\nexpected: $ref"; $x = 1 - i(); is(ref $x, 'PDL::Complex', 'type promotion real scalar - i'); ok(tapprox($x->real,-$ref), 'value from real scalar - i'); $x = pdl('[1+2i 3+4i]'); $y = eval { PDL::Complex->from_native($x) }; $ref = pdl([1, 2], [3, 4]); ok(tapprox($y->real,$ref), 'from_native works') or diag "x=$x, from_native=", $x->real, "\nexpected: $ref"; is $y->as_native.'', $x.'', 'as_native'; is($y->as_native->type, 'cdouble', 'as_native right type'); $ref = pdl([[-2,1],[-3,1]]); $x = i() - pdl(2,3); is(ref $x, 'PDL::Complex', 'type promotion i - real ndarray'); ok(tapprox($x->real,$ref), 'value from i - real ndarray') or diag "x=$x, real=", $x->real; $x = pdl(2,3) - i; is(ref $x, 'PDL::Complex', 'type promotion real ndarray - i'); ok(tapprox($x->real,-$ref), 'value from real ndarray - i'); # dataflow from complex to real my $ar = $x->real; $ar++; ok(tapprox($x->real, -$ref+1), 'complex to real dataflow'); # dataflow from real to complex when using cplx my $refc=$ref->copy; my $ac = $refc->cplx; $ac .= $ac - 1 - i; ok(tapprox($refc, $ref-1), 'real to complex dataflow') or diag "refc=$refc\nref=$ref\nac=$ac"; # no dataflow from real to complex when complex $refc=$ref->copy; $ac = $refc->complex; $ac .= $ac - 1 - i; ok(tapprox($refc->real, $ref-1), 'real to complex dataflow'); #Check Cr2p and Cp2r ok(tapprox(Cr2p(pdl(1,1)), pdl(sqrt(2),atan2(1,1))), 'rectangular to polar'); ok(tapprox(Cp2r(pdl(sqrt(2),atan2(1,1))), pdl(1,1)), 'polar to rectangular'); # Check that converting from re/im to mag/ang and # back we get the same thing $x = cplx($ref); $y = $x->Cr2p()->Cp2r(); ok(tapprox($x-$y, 0), 'check re/im and mag/ang equivalence'); # Test Cadd, Csub, Cmul, Cscale, Cdiv $x=1+2*i; $y=3+4*i; $a=3; my $pa=pdl(3); is(ref Cadd($x,$y), 'PDL::Complex', 'Type of Cadd'); ok(tapprox(Cadd($x,$y)->real, $x->real+$y->real), 'Value of Cadd'); is(ref Csub($x,$y), 'PDL::Complex', 'Type of Csub'); ok(tapprox(Csub($x,$y)->real, $x->real-$y->real), 'Value of Csub'); #is(ref Cmul($x,$y), 'PDL::Complex', 'Type of Cmul'); #ok(tapprox(Cmul($x,$y)->real, # pdl($x->re*$y->re-$x->im*$y->im, # $x->re*$y->im+$x->im*$y->re)), 'Value of Cmul'); is(ref Cscale($x,$a), 'PDL::Complex', 'Type of Cscale with scalar'); ok(tapprox(Cscale($x,$a)->real, $x->real*$a), 'Value of Cscale with scalar'); is(ref Cscale($x,$pa), 'PDL::Complex', 'Type of Cscale with pdl'); ok(tapprox(Cscale($x,$pa)->real, $x->real*$pa), 'Value of Cscale with pdl'); #is(ref Cdiv($x,$y), 'PDL::Complex', 'Type of Cdiv'); #ok(tapprox(Cdiv($x,$y)->real, # Cscale(Cmul($x,$y->Cconj), 1/$y->Cabs2)->real), 'Value of Cdiv'); # to test Cabs, Cabs2, Carg (ref PDL) $x = cplx($ref); my $cabs = sqrt($x->re**2+$x->im**2); is(ref Cabs $x, 'PDL', 'Cabs type'); is(ref Cabs2 $x, 'PDL', 'Cabs2 type'); is(ref Carg $x, 'PDL', 'Carg type'); ok(tapprox($cabs, Cabs $x), 'Cabs value'); ok(tapprox($cabs**2, Cabs2 $x), 'Cabs2 value'); ok(tapprox(atan2($x->im, $x->re), Carg $x), 'Carg value'); #Csin, Ccos, Ctan is(ref Csin(i), 'PDL::Complex', 'Csin type'); ok(tapprox(Csin($x->re->r2C)->re, sin($x->re)), 'Csin of reals'); ok(tapprox(Csin(i()*$x->im)->im, sinh($x->im)), 'Csin of imags'); is(ref Ccos(i), 'PDL::Complex', 'Ccos type'); ok(tapprox(Ccos($x->re->r2C)->re, cos($x->re)), 'Ccos of reals'); ok(tapprox(Ccos(i()*$x->im)->re, cosh($x->im)), 'Ccos of imags'); is(ref Ctan(i), 'PDL::Complex', 'Ctan type'); ok(tapprox(Ctan($x->re->r2C)->re, tan($x->re)), 'Ctan of reals'); ok(tapprox(Ctan(i()*$x->im)->im, tanh($x->im)), 'Ctan of imags'); #Cexp, Clog, Cpow is(ref Cexp(i), 'PDL::Complex', 'Cexp type'); ok(tapprox(Cexp($x->re->r2C)->re, exp($x->re)), 'Cexp of reals'); ok(tapprox(Cexp(i()*$x->im->r2C)->real, pdl(cos($x->im), sin($x->im))->mv(1,0)), 'Cexp of imags '); is(ref Clog(i), 'PDL::Complex', 'Clog type'); ok(tapprox(Clog($x)->real, pdl(log($x->Cabs), atan2($x->im, $x->re))->mv(1,0)), 'Clog of reals'); is(ref Cpow($x, r2C(2)), 'PDL::Complex', 'Cpow type'); ok(tapprox(Cpow($x,r2C(2))->real, pdl($x->re**2-$x->im**2, 2*$x->re*$x->im)->mv(1,0)), 'Cpow value'); #Csqrt is(ref Csqrt($x), 'PDL::Complex', 'Csqrt type'); ok(tapprox((Csqrt($x)*Csqrt($x))->real, $x->real), 'Csqrt value'); ok(tapprox(Cpow(i,2)->real, pdl(-1,0)), 'scalar power of i'); ok(tapprox(Cpow(i,pdl(2))->real, pdl(-1,0)), 'real pdl power of i'); #Casin, Cacos, Catan is(ref Casin($x), 'PDL::Complex', 'Casin type'); ok(tapprox(Csin(Casin($x))->real, $x->real), 'Casin value'); is(ref Cacos($x), 'PDL::Complex', 'Cacos type'); ok(tapprox(Ccos(Cacos($x))->real, $x->real), 'Cacos value'); is(ref Catan($x), 'PDL::Complex', 'Catan type'); ok(tapprox(Ctan(Catan($x))->real, $x->real), 'Catan value'); #Csinh, Ccosh, Ctanh is(ref Csinh($x), 'PDL::Complex', 'Csinh type'); ok(tapprox(Csinh($x)->real, (i()*Csin($x/i()))->real), 'Csinh value'); is(ref Ccosh($x), 'PDL::Complex', 'Ccosh type'); ok(tapprox(Ccosh($x)->real, (Ccos($x/i()))->real), 'Ccosh value'); is(ref Ctanh($x), 'PDL::Complex', 'Ctanh type'); ok(tapprox(Ctanh($x)->real, (i()*Ctan($x/i()))->real), 'Ctanh value'); #Casinh, Cacosh, Catanh is(ref Casinh($x), 'PDL::Complex', 'Casinh type'); ok(tapprox(Csinh(Casinh($x))->real, $x->real), 'Casinh value'); is(ref Cacosh($x), 'PDL::Complex', 'Cacosh type'); ok(tapprox(Ccosh(Cacosh($x))->real, $x->real), 'Cacosh value'); is(ref Catanh($x), 'PDL::Complex', 'Catanh type'); ok(tapprox(Ctanh(Catanh($x))->real, $x->real), 'Catanh value'); # Croots is(ref Croots($x, 5), 'PDL::Complex', 'Croots type'); ok(tapprox(Cpow(Croots($x, 5), r2C(5))->real, $x->real->slice(':,*1')), 'Croots value'); ok(tapprox(Croots($x, 5)->sumover, pdl(0)), 'Croots center of mass'); #Check real and imaginary parts is((2+3*i())->re, 2, 'Real part'); is((2+3*i())->im, 3, 'Imaginary part'); #rCpolynomial is(ref rCpolynomial(pdl(1,2,3), $x), 'PDL::Complex', 'rCpolynomial type'); ok(tapprox(rCpolynomial(pdl(1,2,3), $x)->real, (1+2*$x+3*$x**2)->real), 'rCpolynomial value'); # Check cat'ing of PDL::Complex $y = $x->copy + 1; my $bigArray = $x->cat($y); ok(abs($bigArray->sumover->sumover + 8 - 4*i()) < .0001, 'check cat for PDL::Complex'); ok(abs($bigArray->sum() + 8 - 4*i()) < .0001, 'check cat for PDL::Complex'); $z = pdl(0) + i()*pdl(0); $z **= 2; ok($z->at(0) == 0 && $z->at(1) == 0, 'check that 0 +0i exponentiates correctly'); # Wasn't always so. my $zz = $z ** 0; #Are these results really correct? WLM ok($zz->at(0) == 1 && $zz->at(1) == 0, 'check that 0+0i ** 0 is 1+0i'); $z **= $z; ok($z->at(0) == 1 && $z->at(1) == 0, 'check that 0+0i ** 0+0i is 1+0i'); my $r = pdl(-10) + i()*pdl(0); $r **= 2; ok($r->at(0) < 100.000000001 && $r->at(0) > 99.999999999 && $r->at(1) == 0, 'check that imaginary part is exactly zero') or diag "got:$r"; $r = PDL->sequence(2,2,3)->complex; my $slice = $r->slice('(0),:,(0)'); $slice .= 44; like $r->slice(':,(1),(0)'), qr/44.*3/ or diag "got:", $r->slice(':,(1),(0)'); $r = r2C(-10); $r .= 2; ok(PDL::approx($r->at(0), 2) && PDL::approx($r->at(1), 0), 'check threading does not make assigning a real value affect imag part') or diag "got:$r"; $r = r2C(2); $r++; ok(PDL::approx($r->at(0), 3) && PDL::approx($r->at(1), 0), '++ not imag') or diag "got:$r"; $r = r2C(3); $r--; ok(PDL::approx($r->at(0), 2) && PDL::approx($r->at(1), 0), '-- not imag') or diag "got:$r"; #Check Csumover sumover, Cprodover and prodover $x=PDL->sequence(2,3)+1; $y=$x->copy->complex; is(ref $y->Csumover, 'PDL::Complex', 'Type of Csumover'); is($y->Csumover->dim(0), 2, 'Dimension 0 of Csumover'); ok(tapprox($y->Csumover->real, $x->mv(1,0)->sumover), 'Csumover value'); is(ref $y->sumover, 'PDL::Complex', 'Type of sumover'); is($y->sumover->dim(0), 2, 'Dimension 0 of sumover'); ok(tapprox($y->sumover->real, $x->mv(1,0)->sumover), 'sumover value'); is(ref PDL::sumover($y), 'PDL::Complex', 'Type of sumover'); TODO: { local $TODO="sumover as method and as function differ"; is(PDL::sumover($y)->dim(0), 2, 'Dimension 0 of sumover'); SKIP: { todo_skip "sumover as function is real sumover", 1; ok(tapprox(PDL::sumover($y)->real, $x->mv(1,0)->sumover), 'sumover value'); } } is(ref $y->Cprodover, 'PDL::Complex', 'Type of Cprodover'); is($y->Cprodover->dim(0), 2, 'Dimension 0 of Cprodover'); my @els = map $y->slice(":,($_)"), 0..2; ok(tapprox($y->Cprodover->real, ($els[0]*$els[1]*$els[2])->real), 'Value of Cprodover'); is(ref $y->prodover, 'PDL::Complex', 'Type of prodover'); is($y->prodover->dim(0), 2, 'Dimension 0 of prodover'); ok(tapprox($y->prodover->real, ($els[0]*$els[1]*$els[2])->real), 'Value of prodover'); #Check sum $x=PDL->sequence(2,3)+1; $y=$x->copy->complex; is(ref $y->sum, 'PDL::Complex', 'Type of sum'); is($y->sum->dims, 1, 'Dimensions of sum'); is($y->sum->dim(0), 2, 'Dimension 0 of sum'); ok(tapprox($y->sum->real, $x->mv(1,0)->sumover), 'Value of sum'); #Check prod $x=PDL->sequence(2,3)+1; $y=$x->copy->complex; is(ref $y->prod, 'PDL::Complex', 'Type of prod'); is($y->prod->dims, 1, 'Dimensions of prod'); is($y->prod->dim(0), 2, 'Dimension 0 of prod'); ok(tapprox($y->prod->real, $y->prodover->real), 'Value of prod'); { # Check stringification of complex ndarray my $c = 9.1234 + 4.1234*i(); like($c->dummy(2,1).'', qr/9.123\S*4.123/, 'sf.net bug #1176614'); $c = PDL->sequence(2, 3, 4)->complex; unlike $c.'', qr/\s\+/, 'stringified no space before +'; } TODO: { local $TODO="Autoincrement creates new copy, so doesn't flow"; # autoincrement flow $x=i; $y=$x; $y++; ok(tapprox($x->real, $y->real), 'autoincrement flow'); diag("$x should have equaled $y"); } TODO: { local $TODO="Computed assignment creates new copy, so doesn't flow"; # autoincrement flow $x=i; $y=$x; $y+=1; ok(tapprox($x->real, $y->real), 'computed assignment flow'); diag("$x should have equaled $y"); } TODO: { local $TODO="Computed assignment doesn't modify slices"; # autoincrement flow $x=PDL->sequence(2,3)->complex; $y=$x->copy; $x+=$x; $y->slice('')+=$y; ok(tapprox($x->real, $y->real), 'computed assignment to slice'); diag("$x should have equaled $y"); } $x=3+4*i;$y=4+2*i; my $c=1+1*i; ok(Cmul($x,$y) == 4+22*i,"Cmul"); ok($x*$y == 4+22*i,"overloaded *"); ok(Cdiv($x,$y) == 1 + 0.5*i,"Cdiv"); ok($x/$y == 1+0.5*i,"overloaded /"); ok(tapprox(Cabs(atan2(pdl(1)->r2C,pdl(0)->r2C)),PDL::Math::asin(1)),"atan2"); TODO: { local $TODO="Transpose of complex data should leave 0-th dimension alone"; $x=PDL->sequence(2,3,4)->complex; $y=$x->transpose; is($y->dim(0),2, "Keep dimension 0 when transposing"); } TODO: { local $TODO="complex numbers should not be so after moving dimension 0"; $x=PDL->sequence(2,2)->complex; $y=$x->mv(0,1); is(ref $y, 'PDL', 'PDL::Complex becomes real PDL after moving dim 0'); } #test overloaded operators { my $less = 3-4*i; my $equal = -1*(-3+4*i); my $more = 3+2*i; my $zero_imag = r2C(4); eval { my $bool = $less<$more }; ok $@, 'exception on invalid operator'; eval { my $bool = $less<=$equal }; ok $@, 'exception on invalid operator'; ok($less==$equal,'equal to'); ok(!($less!=$equal),'not equal to'); eval { my $bool = $more>$equal }; ok $@, 'exception on invalid operator'; eval { my $bool = $more>=$equal }; ok $@, 'exception on invalid operator'; ok($zero_imag==4,'equal to real'); ok($zero_imag!=5,'neq real'); } done_testing; PDL-2.074/Basic/Complex/Makefile.PL0000644000175000017500000000043614014062163016475 0ustar osboxesosboxesuse strict; use warnings; use ExtUtils::MakeMaker; my @pack = (["complex.pd", qw(Complex PDL::Complex)]); my %hash = pdlpp_stdargs_int(@pack); $hash{LIBS} = ['-lm']; undef &MY::postamble; # suppress warning *MY::postamble = sub{ pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.074/Basic/Constants.pm0000644000175000017500000000230714165336442015440 0ustar osboxesosboxes=head1 NAME PDL::Constants -- basic compile time constants for PDL =head1 DESCRIPTION This module is used to define compile time constant values for PDL. It uses Perl's L pragma for simplicity and availability. =head1 SYNOPSIS use PDL::Constants qw(PI E); print 'PI is ' . PI . "\n"; print 'E is ' . E . "\n"; =cut package PDL::Constants; use strict; use warnings; our $VERSION = "0.02"; $VERSION = eval $VERSION; require Exporter; our @ISA = qw(Exporter); our @EXPORT_OK = qw(PI DEGRAD E I J); # symbols to export use PDL::Lite; =head2 PI The ratio of a circle's circumference to its diameter =cut use constant PI => 4 * atan2(1, 1); =head2 DEGRAD The number of degrees of arc per radian (180/PI) =cut use constant DEGRAD => 180/PI; =head2 E The base of the natural logarithms or Euler's number =cut use constant E => exp(1); =head1 COPYRIGHT & LICENSE Copyright 2010 Chris Marshall (chm at cpan dot org). This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. =cut 1; PDL-2.074/Basic/Gen/0000755000175000017500000000000014200406301013613 5ustar osboxesosboxesPDL-2.074/Basic/Gen/PP.pm0000644000175000017500000023417214200157464014516 0ustar osboxesosboxes# $PDL::PP::deftbl is an array-ref of # PDL::PP::Rule->new("Name1", "Name2", $ref_to_sub) # where Name1 represents the target of the rule, Name2 the condition, # and the subroutine reference is the routine called when the rule is # applied. # # If there is no condition, the argument can be left out of the call # (unless there is a doc string), so # PDL::PP::Rule->new("Name1", $ref_to_sub) # # The target and conditions can also be an array reference, so # PDL::PP::Rule->new("Name1", ["Name2","Name3"], $ref_to_sub) # PDL::PP::Rule->new(["Name1","Name2"], "Name3", $ref_to_sub) # PDL::PP::Rule->new(["Name1","Name2"], ["Name3","Name4], $ref_to_sub) # # If a doc string exists then the condition must also # be supplied, even if it is just [] (ie no condition). # # There are specialized rules for common situations. The rules for the # target, condition, and doc arguments hold from the base class (ie # whether scalar or array values are used, ...) # # Return a constant: # # PDL::PP::Rule::Returns->new($targets [,$conditions [,$doc]], $value) # is used to return a constant. So # PDL::PP::Rule::Returns->new("Name1", "foo") # # This class is specialized since there are some common return values: # PDL::PP::Rule::Returns::Zero->new($targets [,$conditions [,$doc]]) # PDL::PP::Rule::Returns::One->new($targets [,$conditions [,$doc]]) # PDL::PP::Rule::Returns::EmptyString->new($targets [,$conditions [,$doc]]) # PDL::PP::Rule::Returns::NULL->new($targets [,$conditions [,$doc]]) # which return 0, 1, "", and "NULL" respectively # # The InsertName class exists to allow you to return something like # "foobar" # e.g. # PDL::PP::Rule::InsertName->new("Foo", '_pdl_${name}_bar') # PDL::PP::Rule::InsertName->new("Foo", "Arg2", '_pdl_${name}_bar') # Note that the Name argument is automatically used as a condition, so # it does not need to be supplied, and the return value should be # given as a single-quoted string and use the $name variable # # The Substitute rule replaces dollar-signed macros ($P(), $ISBAD(), etc) # with the low-level C code to perform the macro. # PDL::PP::Rule::Substitute("NewXSCoerceMustSubs", "NewXSCoerceMustSub1") # PDL::PP::Rule::Substitute->new($target,$condition) # $target and $condition must be scalars. # Implicit conditions are NewXSSymTab and Name # # PDL::PP::Rule::Substitute::Usual->new($target, $condition) # $target and $condition must be scalars. # Implicit conditions are NewXSSymTab and Name # # The MakeComp rule creates the compiled representation accessed by $COMP() # PDL::PP::Rule::MakeComp->new("MakeCompiledRepr", ["MakeComp","CompObj"], # "COMP") # PDL::PP::Rule::MakeComp->new($target,$conditions,$symbol) # $target and $symbol must be scalars. # Notes: # Substitute, Substitute::Usual, MakeComp classes feel a bit # ugly. See next point. Also the get_std_childparent method is # a bit of a hack. package PDL::PP::Rule; use strict; use warnings; use Carp; use overload ("\"\"" => \&PDL::PP::Rule::stringify); sub stringify { my $self = shift; my $str = ref $self; if ("PDL::PP::Rule" eq $str) { $str = "Rule"; } else { $str =~ s/PDL::PP::Rule:://; } $str = "($str) "; $str .= exists $self->{doc} ? $self->{doc} : join(",", @{$self->{targets}}); return $str; } # Takes two args: the calling object and the message, but we only care # about the message: sub report ($$) { print $_[1] if $::PP_VERBOSE; } # Very limited error checking. # Allow scalars for targets and conditions to be optional # # At present you have to have a conditions argument if you supply # a doc string my $rule_usage = "Usage: PDL::PP::Rule->new(\$targets[,\$conditions[,\$doc],] [,\$ref])\n"; sub new { die $rule_usage if @_ < 2 or @_ > 5; my $class = shift; my $self = bless {}, $class; my $targets = shift; $targets = [$targets] unless ref $targets eq "ARRAY"; $self->{targets} = $targets; return $self if !@_; $self->{ref} = pop if ref $_[-1] eq "CODE"; my $conditions = shift // []; $conditions = [$conditions] unless ref $conditions eq "ARRAY"; $self->{conditions} = $conditions; $self->{doc} = shift if defined $_[0]; $self; } # $rule->any_targets_exist($pars); # # Returns 1 if any of the targets exist in $pars, 0 otherwise. # A return value of 1 means that the rule should not be applied. sub any_targets_exist { my $self = shift; my $pars = shift; my $targets = $self->{targets}; foreach my $target (@$targets) { if (exists $pars->{$target}) { $self->report("--skipping since TARGET $target exists\n"); return 1; } } return 0; } # $rule->all_conditions_exist($pars); # # Returns 1 if all of the required conditions exist in $pars, 0 otherwise. # A return value of 0 means that the rule should not be applied. sub all_conditions_exist { my $self = shift; my $pars = shift; return 1 unless my @nonexist = grep !ref() && !exists $pars->{$_}, @{$self->{conditions}}; $self->report("--skipping since CONDITIONs (@nonexist) do not exist\n"); 0; } # $rule->should_apply($pars); # # Returns 1 if the rule should be applied (ie no targets already # exist in $pars and all the required conditions exist in $pars), # otherwise 0. # sub should_apply { my $self = shift; my $pars = shift; return 0 if $self->any_targets_exist($pars); return 0 unless $self->all_conditions_exist($pars); return 1; } # my @args = $self->extract_args($pars); sub extract_args { my ($self, $pars) = @_; @$pars{ map ref($_) eq "SCALAR" ? $$_ : $_, @{ $self->{conditions} } }; } # Apply the rule using the supplied $pars hash reference. # sub apply { my $self = shift; my $pars = shift; carp "Unable to apply rule $self as there is no subroutine reference!" unless exists $self->{ref}; my $targets = $self->{targets}; my $conditions = $self->{conditions}; my $ref = $self->{ref}; $self->report("Applying: $self\n"); return unless $self->should_apply($pars); # Create the argument array for the routine. # my @args = $self->extract_args($pars); # Run this rule's subroutine: my @retval = $ref->(@args); # Check for any inconsistencies: confess "Internal error: rule '$self' returned " . (1+$#retval) . " items and expected " . (1+$#$targets) unless $#retval == $#$targets; $self->report("--setting:"); foreach my $target (@$targets) { $self->report(" $target"); confess "Cannot have multiple meanings for target $target!" if exists $pars->{$target}; my $result = shift @retval; # The following test suggests that things could/should be # improved in the code generation. # if (defined $result and $result eq 'DO NOT SET!!') { $self->report (" is 'DO NOT SET!!'"); } else { $pars->{$target} = $result; } } $self->report("\n"); } package PDL::PP::Rule::Croak; # Croaks if all of the input variables are defined. Use this to identify # incompatible arguments. our @ISA = qw(PDL::PP::Rule); use Carp; sub new { croak('Usage: PDL::PP::Rule::Croak->new(["incompatible", "arguments"], "Croaking message")') unless @_ == 3; shift->SUPER::new([], @_); } sub apply { my ($self, $pars) = @_; croak($self->{doc}) if $self->should_apply($pars); } package PDL::PP::Rule::Returns; use strict; use Carp; our @ISA = qw (PDL::PP::Rule); # This class does not treat return values of "DO NOT SET!!" # as special. # sub new { my $class = shift; my $value = pop; my $self = $class->SUPER::new(@_); $self->{"returns.value"} = $value; my $targets = $self->{targets}; croak "There can only be 1 target for a $self, not " . (1+$#$targets) . "!" unless $#$targets == 0; return $self; } sub apply { my $self = shift; my $pars = shift; carp "Unable to apply rule $self as there is no return value!" unless exists $self->{"returns.value"}; my $target = $self->{targets}->[0]; $self->report("Applying: $self\n"); return unless $self->should_apply($pars); # Set the value # $self->report ("--setting: $target\n"); $pars->{$target} = $self->{"returns.value"}; } package PDL::PP::Rule::Returns::Zero; use strict; our @ISA = qw (PDL::PP::Rule::Returns); sub new { shift->SUPER::new(@_,0); } package PDL::PP::Rule::Returns::One; use strict; our @ISA = qw (PDL::PP::Rule::Returns); sub new { shift->SUPER::new(@_,1); } package PDL::PP::Rule::Returns::EmptyString; use strict; our @ISA = qw (PDL::PP::Rule::Returns); sub new { shift->SUPER::new(@_,""); } package PDL::PP::Rule::Returns::NULL; use strict; our @ISA = qw (PDL::PP::Rule::Returns); sub new { shift->SUPER::new(@_,"NULL"); } package PDL::PP::Rule::InsertName; use strict; use Carp; our @ISA = qw (PDL::PP::Rule); # This class does not treat return values of "DO NOT SET!!" # as special. # sub new { my $class = shift; my $value = pop; my @args = @_; my $self = $class->SUPER::new(@args); $self->{"insertname.value"} = $value; # Generate a defaul doc string unless (exists $self->{doc}) { $self->{doc} = 'Sets ' . $self->{targets}->[0] . ' to "' . $value . '"'; } my $targets = $self->{targets}; croak "There can only be 1 target for a $self, not " . (1+$#$targets) . "!" unless $#$targets == 0; # we add "Name" as the first condition # my $conditions = $self->{conditions}; unshift @$conditions, "Name"; return $self; } sub apply { my $self = shift; my $pars = shift; carp "Unable to apply rule $self as there is no return value!" unless exists $self->{"insertname.value"}; $self->report("Applying: $self\n"); return unless $self->should_apply($pars); # Set the value # my $target = $self->{targets}->[0]; my $name = $pars->{Name}; $self->report ("--setting: $target (name=$name)\n"); $pars->{$target} = eval "return \"" . $self->{"insertname.value"} . "\";"; } # PDL::PP::Rule->new("NewXSCoerceMustSubs", ["NewXSCoerceMustSub1","NewXSSymTab","Name"], # \&dosubst), # # PDL::PP::Rule::Substitute->new($target,$condition) # $target and $condition must be scalars. # # Implicit conditions are NewXSSymTab and Name # package PDL::PP::Rule::Substitute; use strict; use Carp; our @ISA = qw (PDL::PP::Rule); sub badflag_isset { PDL::PP::pp_line_numbers(__LINE__-1, "($_[0]->state & PDL_BADVAL)") } # Probably want this directly in the apply routine but leave as is for now # sub dosubst_private { my ($src,$sname,$pname,$name,$sig) = @_; my $ret = (ref $src ? $src->[0] : $src); my %syms = ( ((ref $src) ? %{$src->[1]} : ()), PRIV => sub {return "$sname->$_[0]"}, COMP => sub {return "$pname->$_[0]"}, CROAK => sub {PDL::PP::pp_line_numbers(__LINE__-1, "return PDL->make_error(PDL_EUSERERROR, \"Error in $name:\" $_[0])")}, NAME => sub {return $name}, MODULE => sub {return $::PDLMOD}, SETPDLSTATEBAD => sub { PDL::PP::pp_line_numbers(__LINE__-1, "$_[0]\->state |= PDL_BADVAL") }, SETPDLSTATEGOOD => sub { PDL::PP::pp_line_numbers(__LINE__-1, "$_[0]\->state &= ~PDL_BADVAL") }, ISPDLSTATEBAD => \&badflag_isset, ISPDLSTATEGOOD => sub {"!".badflag_isset($_[0])}, BADFLAGCACHE => sub { PDL::PP::pp_line_numbers(__LINE__-1, "badflag_cache") }, PDLSTATESETBAD => sub { PDL::PP::pp_line_numbers(__LINE__-1, $sig->objs->{$_[0]}->do_pdlaccess."->state |= PDL_BADVAL") }, PDLSTATESETGOOD => sub { PDL::PP::pp_line_numbers(__LINE__-1, $sig->objs->{$_[0]}->do_pdlaccess."->state &= ~PDL_BADVAL") }, PDLSTATEISBAD => sub {badflag_isset($sig->objs->{$_[0]}->do_pdlaccess)}, PDLSTATEISGOOD => sub {"!".badflag_isset($sig->objs->{$_[0]}->do_pdlaccess)}, PP => sub { $sig->objs->{$_[0]}->do_physpointeraccess }, P => sub { (my $o = $sig->objs->{$_[0]})->{FlagPhys} = 1; $o->do_pointeraccess; }, PDL => sub { $sig->objs->{$_[0]}->do_pdlaccess }, SIZE => sub { $sig->ind_obj($_[0])->get_size }, %PDL::PP::macros, ); while (my ($before, $kw, $args, $other) = macro_extract($ret)) { confess("$kw not defined in '$ret'!") if !$syms{$kw}; $ret = join '', $before, $syms{$kw}->($args), $other; } $ret; } sub macro_extract { require Text::Balanced; my ($text) = @_; return unless $text =~ /\$(\w+)\s*(?=\()/; my ($before, $kw, $other) = ($`, $1, $'); (my $bracketed, $other) = Text::Balanced::extract_bracketed($other, '(")'); $bracketed = substr $bracketed, 1, -1; # chop off brackets $bracketed =~ s:^\s*(.*?)\s*$:$1:; ($before, $kw, $bracketed, $other); } sub new { my $class = shift; die "Usage: PDL::PP::Rule::Substitute->new(\$target,\$condition);" unless $#_ == 1; my $target = shift; my $condition = shift; die "\$target must be a scalar for PDL::PP::Rule::Substitute" if ref $target; die "\$condition must be a scalar for PDL::PP::Rule::Substitute" if ref $condition; $class->SUPER::new($target, [$condition, qw(StructName ParamStructName Name SignatureObj)], \&dosubst_private); } # PDL::PP::Rule->new("CacheBadFlagInit", ["CacheBadFlagInitNS","NewXSSymTab","Name"], # \&dousualsubsts), # # PDL::PP::Rule::Substitute::Usual->new($target, $condition) # $target and $condition must be scalars. # # Implicit conditions are NewXSSymTab and Name # # Need to think about @std_childparent as it is also used by # other bits of code. At the moment provide a class method # to access the array but there has to be better ways of # doing this. # package PDL::PP::Rule::Substitute::Usual; use strict; use Carp; our @ISA = qw (PDL::PP::Rule::Substitute); # This is a copy of the main one for now. Need a better solution. # my @std_childparent = ( CHILD => sub {PDL::PP::pp_line_numbers(__LINE__-1, '$PRIV(pdls[1]->'.(join ',',@_).")")}, PARENT => sub {PDL::PP::pp_line_numbers(__LINE__-1, '$PRIV(pdls[0]->'.(join ',',@_).")")}, CHILD_PTR => sub {PDL::PP::pp_line_numbers(__LINE__-1, '$PRIV(pdls[1])')}, PARENT_PTR => sub {PDL::PP::pp_line_numbers(__LINE__-1, '$PRIV(pdls[0])')}, ); sub get_std_childparent { return @std_childparent; } # We modify the arguments from the conditions to include the # extra information # # We simplify the base-class version since we assume that all # conditions are required here. # sub extract_args { my $self = shift; my $pars = shift; # The conditions are [, NewXSSymTab, Name] # my $code = $pars->{$self->{conditions}[0]}; my $sname = $pars->{$self->{conditions}[1]}; my $name = $pars->{$self->{conditions}[2]}; return ([$code,{@std_childparent}],$sname,$name); } # PDL::PP::Rule::MakeComp->new($target,$conditions,$symbol) # $target and $symbol must be scalars. # package PDL::PP::Rule::MakeComp; use strict; use Carp; our @ISA = qw (PDL::PP::Rule); # This is a copy of the main one for now. Need a better solution. # my @std_redodims = ( SETNDIMS => sub {PDL::PP::pp_line_numbers(__LINE__-1, "PDL_RETERROR(PDL_err, PDL->reallocdims(__it,$_[0]));")}, SETDIMS => sub {PDL::PP::pp_line_numbers(__LINE__-1, "PDL_RETERROR(PDL_err, PDL->setdims_careful(__it));")}, SETDELTATHREADIDS => sub {PDL::PP::pp_line_numbers(__LINE__, <reallocthreadids(\$CHILD_PTR(), \$PARENT(nthreadids))); for(__ind=0; __ind<\$PARENT(nthreadids); __ind++) \$CHILD(threadids[__ind]) = \$PARENT(threadids[__ind]) + ($_[0]); } EOF ); # Probably want this directly in the apply routine but leave as is for now # sub subst_makecomp_private { my($which,$mc,$cobj) = @_; my ($cn,$co) = !$cobj ? () : map $cobj->$_, qw(othernames otherobjs); return [$mc,{ PDL::PP::Rule::Substitute::Usual::get_std_childparent(), ($cn ? (('DO'.$which.'ALLOC') => sub {join('', map $$co{$_}->get_malloc("\$$which($_)"), grep $$co{$_}->need_malloc, @$cn)}) : () ), ($which eq "PRIV" ? @std_redodims : ()), }, ]; } sub new { my $class = shift; die "Usage: PDL::PP::Rule::MakeComp->new(\$target,\$conditions,\$symbol);" unless $#_ == 2; my $target = shift; my $condition = shift; my $symbol = shift; die "\$target must be a scalar for PDL::PP::Rule->MakeComp" if ref $target; die "\$symbol must be a scalar for PDL::PP::Rule->MakeComp" if ref $symbol; my $self = $class->SUPER::new($target, $condition, \&subst_makecomp_private); $self->{"makecomp.value"} = $symbol; return $self; } # We modify the arguments from the conditions to include the # extra information # # We simplify the base-class version since we assume that all # conditions are required here. # sub extract_args { my $self = shift; my $pars = shift; ($self->{"makecomp.value"}, @$pars{@{$self->{conditions}}}); } package PDL::PP; use strict; our $VERSION = "2.3"; $VERSION = eval $VERSION; our $macros_xs = <<'EOF'; #define PDL_XS_PREAMBLE \ char *objname = "PDL"; /* XXX maybe that class should actually depend on the value set \ by pp_bless ? (CS) */ \ HV *bless_stash = 0; \ SV *parent = 0; \ int nreturn = 0; \ (void)nreturn; #define PDL_XS_PACKAGEGET \ PDL_COMMENT("Check if you can get a package name for this input value. ") \ PDL_COMMENT("It can be either a PDL (SVt_PVMG) or a hash which is a ") \ PDL_COMMENT("derived PDL subclass (SVt_PVHV) ") \ if (SvROK(ST(0)) && ((SvTYPE(SvRV(ST(0))) == SVt_PVMG) || (SvTYPE(SvRV(ST(0))) == SVt_PVHV))) { \ parent = ST(0); \ if (sv_isobject(parent)){ \ bless_stash = SvSTASH(SvRV(ST(0))); \ objname = HvNAME((bless_stash)); PDL_COMMENT("The package to bless output vars into is taken from the first input var") \ } \ } #define PDL_XS_PERLINIT(name, to_push, method) \ if (strcmp(objname,"PDL") == 0) { PDL_COMMENT("shortcut if just PDL") \ name ## _SV = sv_newmortal(); \ name = PDL->pdlnew(); \ if (!name) PDL->pdl_barf("Error making null pdl"); \ PDL->SetSV_PDL(name ## _SV, name); \ if (bless_stash) name ## _SV = sv_bless(name ## _SV, bless_stash); \ } else { \ PUSHMARK(SP); \ XPUSHs(to_push); \ PUTBACK; \ perl_call_method(#method, G_SCALAR); \ SPAGAIN; \ name ## _SV = POPs; \ PUTBACK; \ name = PDL->SvPDLV(name ## _SV); \ } #define PDL_XS_RETURN(clause1) \ if (nreturn) { \ if (nreturn > 0) EXTEND (SP, nreturn); \ clause1; \ XSRETURN(nreturn); \ } else { \ XSRETURN(0); \ } #define PDL_XS_INPLACE(in, out) \ if (in->state & PDL_INPLACE && (out != in)) { \ in->state &= ~PDL_INPLACE; PDL_COMMENT("unset") \ out = in; \ PDL->SetSV_PDL(out ## _SV,out); \ } #define PDL_XS_INPLACE_CHECK(in) \ if (in->state & PDL_INPLACE) barf("inplace input but output given"); EOF our $header_c = pp_line_numbers(__LINE__, <<'EOF'); /* * THIS FILE WAS GENERATED BY PDL::PP! Do not modify! */ #define PDL_COMMENT(comment) PDL_COMMENT("This preprocessor symbol is used to add commentary in the PDL ") PDL_COMMENT("autogenerated code. Normally, one would use typical C-style ") PDL_COMMENT("multiline comments (i.e. /* comment */). However, because such ") PDL_COMMENT("comments do not nest, it's not possible for PDL::PP users to ") PDL_COMMENT("comment-out sections of code using multiline comments, as is ") PDL_COMMENT("often the practice when debugging, for example. So, when you ") PDL_COMMENT("see something like this: ") PDL_COMMENT(" ") PDL_COMMENT("Memory access") PDL_COMMENT(" ") PDL_COMMENT("just think of it as a C multiline comment like: ") PDL_COMMENT(" ") PDL_COMMENT(" /* Memory access */ ") #define PDL_FREE_CODE(trans, destroy, comp_free_code, ntpriv_free_code) \ if (destroy) { \ comp_free_code \ } \ if ((trans)->dims_redone) { \ ntpriv_free_code \ } #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "pdl.h" #include "pdlcore.h" #define PDL %s extern Core* PDL; PDL_COMMENT("Structure hold core C functions") static int __pdl_boundscheck = 0; static SV* CoreSV; PDL_COMMENT("Gets pointer to perl var holding core structure") #if ! %s # define PP_INDTERM(max, at) at #else # define PP_INDTERM(max, at) (__pdl_boundscheck? PDL->safe_indterm(max,at, __FILE__, __LINE__) : at) #endif EOF our $header_xs = pp_line_numbers(__LINE__, <<'EOF'); Core* PDL = NULL; PDL_COMMENT("Structure hold core C functions") MODULE = %1$s PACKAGE = %1$s PROTOTYPES: ENABLE int set_boundscheck(i) int i; CODE: if (! %6$s) warn("Bounds checking is disabled for %1$s"); RETVAL = __pdl_boundscheck; __pdl_boundscheck = i; OUTPUT: RETVAL MODULE = %1$s PACKAGE = %2$s %3$s BOOT: PDL_COMMENT("Get pointer to structure of core shared C routines") PDL_COMMENT("make sure PDL::Core is loaded") %4$s %5$s EOF use Config; use Exporter; use Data::Dumper; our @ISA = qw(Exporter); our @EXPORT = qw/pp_addhdr pp_addpm pp_bless pp_def pp_done pp_add_boot pp_add_exported pp_addxs pp_add_isa pp_export_nothing pp_core_importList pp_beginwrap pp_setversion pp_addbegin pp_boundscheck pp_line_numbers pp_deprecate_module pp_add_macros/; $PP::boundscheck = 1; $::PP_VERBOSE = 0; our $done = 0; # pp_done has not been called yet use Carp; sub nopm { $::PDLPACK eq 'NONE' } # flag that we don't want to generate a PM sub import { my ($mod,$modname, $packname, $prefix, $callpack, $multi_c) = @_; # Allow for users to not specify the packname ($packname, $prefix, $callpack) = ($modname, $packname, $prefix) if ($packname =~ m|/|); $::PDLMOD=$modname; $::PDLPACK=$packname; $::PDLPREF=$prefix; $::CALLPACK = $callpack || $::PDLMOD; $::PDLMULTI_C = $multi_c; # one pp-*.c per function $::PDLOBJ = "PDL"; # define pp-funcs in this package $::PDLXS=""; $::PDLBEGIN=""; $::PDLPMROUT=""; for ('Top','Bot','Middle') { $::PDLPM{$_}="" } @::PDLPMISA=('PDL::Exporter', 'DynaLoader'); @::PDL_IFBEGINWRAP = ('',''); $::PDLVERSIONSET = ''; $::PDLMODVERSION = undef; $::DOCUMENTED = 0; $::PDLCOREIMPORT = ""; #import list from core, defaults to everything, i.e. use Core # could be set to () for importing nothing from core. or qw/ barf / for # importing barf only. @_=("PDL::PP"); goto &Exporter::import; } sub list_functions { my ($file) = @_; my @funcs; undef &PDL::PP::pp_def; local *PDL::PP::pp_def = sub { push @funcs, (_pp_parsename($_[0]))[0]}; undef &PDL::PP::pp_done; local *PDL::PP::pp_done = sub {}; $_ = '' for $::PDLMOD, $::CALLPACK, $::PDLOBJ; # stop warnings require File::Spec::Functions; do ''.File::Spec::Functions::rel2abs($file); die $@ if $@; @funcs; } our %macros; sub pp_add_macros { confess "Usage: pp_add_macros(name=>sub {},...)" if @_%2; %macros = (%macros, @_); } # query/set boundschecking # if on the generated XS code will have optional boundschecking # that can be turned on/off at runtime(!) using # __PACKAGE__::set_boundscheck(arg); # arg should be 0/1 # if off code is speed optimized and no runtime boundschecking # can be performed # ON by default sub pp_boundscheck { my $ret = $PP::boundscheck; $PP::boundscheck = $_[0] if $#_ > -1; return $ret; } sub pp_beginwrap { @::PDL_IFBEGINWRAP = ('BEGIN {','}'); } sub pp_setversion { my ($ver) = @_; $ver = qq{'$ver'} if $ver !~ /['"]/; $::PDLMODVERSION = '$VERSION'; $::PDLVERSIONSET = "our \$VERSION = $ver;"; } sub pp_addhdr { my ($hdr) = @_; $::PDLXSC .= $hdr; $::PDLXSC_header .= $hdr if $::PDLMULTI_C; } sub pp_addpm { my $pm = shift; my $pos; if (ref $pm) { my $opt = $pm; $pm = shift; croak "unknown option" unless defined $opt->{At} && $opt->{At} =~ /^(Top|Bot|Middle)$/; $pos = $opt->{At}; } else { $pos = 'Middle'; } my @c = caller; $::PDLPM{$pos} .= _pp_line_number_file(@c[1,2], $pm) . "\n\n"; } sub pp_add_exported { shift if !$_[0] or $_[0] eq __PACKAGE__; $::PDLPMROUT .= join ' ', @_, ''; } sub pp_addbegin { my ($cmd) = @_; if ($cmd =~ /^\s*BOOT\s*$/) { pp_beginwrap; } else { $::PDLBEGIN .= $cmd."\n"; } } # Sub to call to export nothing (i.e. for building OO package/object) sub pp_export_nothing { $::PDLPMROUT = ' '; } sub pp_add_isa { push @::PDLPMISA,@_; } sub pp_add_boot { my ($boot) = @_; $boot =~ s/^\s*\n//gm; # XS doesn't like BOOT having blank lines $::PDLXSBOOT .= $boot; } sub pp_bless{ my($new_package)=@_; $::PDLOBJ = $new_package; } # sub to call to set the import list from core on the 'Use Core' line in the .pm file. # set to '()' to not import anything from Core, or 'qw/ barf /' to import barf. sub pp_core_importList{ $::PDLCOREIMPORT = $_[0]; } sub printxs { shift; $::PDLXS .= join'',@_; } sub pp_addxs { PDL::PP->printxs("\nMODULE = $::PDLMOD PACKAGE = $::CALLPACK\n\n", @_, "\nMODULE = $::PDLMOD PACKAGE = $::PDLOBJ\n\n"); } # inserts #line directives into source text. Use like this: # ... # FirstKey => ..., # Code => pp_line_numbers(__LINE__, $x . $y . $c), # OtherKey => ... sub pp_line_numbers { _pp_line_number_file((caller)[1], @_); } sub _pp_line_number_file { my ($filename, $line, $string) = @_; confess "pp_line_numbers called with undef" if !defined $string; # The line needs to be incremented by one for the bookkeeping to work $line++; $filename =~ s/\\/\\\\/g; # Escape backslashes my @to_return = "\nPDL_LINENO_START $line \"$filename\"\n"; # Look for threadloops and loops and add # line directives foreach (split (/\n/, $string)) { # Always add the current line. push @to_return, "$_\n"; # If we need to add a # line directive, do so after incrementing $line++; if (/%\{/ or /%}/) { push @to_return, "PDL_LINENO_END\n"; push @to_return, "PDL_LINENO_START $line \"$filename\"\n"; } } push @to_return, "PDL_LINENO_END\n"; return join('', @to_return); } sub _pp_linenumber_fill { my ($file, $text) = @_; my (@stack, @to_return) = [$file, 1]; foreach (split (/\n/, $text)) { $_->[1]++ for @stack; push(@to_return, $_), next if !/^(\s*)PDL_LINENO_(?:START (\S+) "(.*)"|(END))$/; my ($ci, $new_line, $new_file, $is_end) = ($1, $2, $3, $4); if ($is_end) { pop @stack; push @to_return, qq{$ci#line $stack[-1][1] "$stack[-1][0]"}; } else { push @stack, [$new_file, $new_line-1]; push @to_return, qq{$ci#line @{[$stack[-1][1]+1]} "$stack[-1][0]"}; } } join '', map "$_\n", @to_return; } sub _file_same { my ($from_text, $to_file) = @_; require File::Map; File::Map::map_file(my $to_map, $to_file, '<'); s/^[^\n]*#line[^\n]*?\n//gm for $from_text, (my $to_text = $to_map); $from_text eq $to_text; } sub _write_file { my ($file, $text) = @_; $text = _pp_linenumber_fill($file, $text); return if -f $file && _file_same($text, $file); open my $fh, '>', $file or confess "open $file: $!"; binmode $fh; # to guarantee length will be same for same contents print $fh $text; } sub printxsc { (undef, my $file) = (shift, shift); my $text = join '',@_; if (defined $file) { (my $mod_underscores = $::PDLMOD) =~ s#::#_#g; $text = join '', sprintf($PDL::PP::header_c, $mod_underscores, $PP::boundscheck), $::PDLXSC_header//'', $text; _write_file($file, $text); } else { $::PDLXSC .= $text; } } sub pp_done { return if $PDL::PP::done; # do only once! $PDL::PP::done = 1; print "DONE!\n" if $::PP_VERBOSE; print "Inline running PDL::PP version $PDL::PP::VERSION...\n" if nopm(); require PDL::Core::Dev; my $pdl_boot = PDL::Core::Dev::PDL_BOOT('PDL', $::PDLMOD); (my $mod_underscores = $::PDLMOD) =~ s#::#_#g; my $text = join '', sprintf($PDL::PP::header_c, $mod_underscores, $PP::boundscheck), $::PDLXSC//'', $PDL::PP::macros_xs, sprintf($PDL::PP::header_xs, $::PDLMOD, $::PDLOBJ, $::PDLXS, $pdl_boot, $::PDLXSBOOT//'', $PP::boundscheck, ); _write_file("$::PDLPREF.xs", $text); return if nopm; $::PDLPMISA = "'".join("','",@::PDLPMISA)."'"; $::PDLBEGIN = "BEGIN {\n$::PDLBEGIN\n}" unless $::PDLBEGIN =~ /^\s*$/; $::PDLMODVERSION //= ''; $::FUNCSPOD = $::DOCUMENTED ? "\n\n=head1 FUNCTIONS\n\n=cut\n\n" : ''; _write_file("$::PDLPREF.pm", join "\n\n", <\\\@EXPORT_OK); use PDL::Core$::PDLCOREIMPORT; use PDL::Exporter; use DynaLoader; $::PDL_IFBEGINWRAP[0] $::PDLVERSIONSET our \@ISA = ( $::PDLPMISA ); push \@PDL::Core::PP, __PACKAGE__; bootstrap $::PDLMOD $::PDLMODVERSION; $::PDL_IFBEGINWRAP[-1] EOF } # end pp_done sub _pp_parsename { my ($name) = @_; # See if the 'name' is multiline, in which case we extract the # name and add the FullDoc field return ($name, undef) if $name !~ /\n/; my $fulldoc = $name; # See if the very first thing is a word. That is going to be the # name of the function under consideration if ($fulldoc =~ s/^(\w+)//) { $name = $1; } elsif ($fulldoc =~ /=head2 (\w+)/) { $name = $1; } else { croak('Unable to extract name'); } ($name, $fulldoc); } sub pp_def { require PDL::Core::Dev; require PDL::Types; require PDL::PP::PdlParObj; require PDL::PP::Signature; require PDL::PP::Dims; require PDL::PP::CType; require PDL::PP::PDLCode; PDL::PP::load_deftable() if !$PDL::PP::deftbl; my($name,%obj) = @_; print "*** Entering pp_def for $name\n" if $::PP_VERBOSE; ($name, my $fulldoc) = _pp_parsename($name); $obj{FullDoc} = $fulldoc if defined $fulldoc; $obj{Name} = $name; croak("ERROR: pp_def=$name given empty GenericTypes!\n") if exists $obj{GenericTypes} and !@{ $obj{GenericTypes} || [] }; foreach my $rule (@$PDL::PP::deftbl) { $rule->apply(\%obj); } print "Result of translate for $name:\n" . Dumper(\%obj) . "\n" if exists $obj{Dump} and $obj{Dump} and $::PP_VERBOSE; croak("ERROR: No FreeFunc for pp_def=$name!\n") unless exists $obj{FreeFunc}; my $ctext = join("\n\n",grep $_, @obj{'StructDecl','RedoDimsFunc', 'ReadDataFunc','WriteBackDataFunc', 'FreeFunc', 'VTableDef','RunFunc', } ); if ($::PDLMULTI_C) { PDL::PP->printxsc(undef, <printxsc("pp-$obj{Name}.c", $ctext); } else { PDL::PP->printxsc(undef, $ctext); } PDL::PP->printxs($obj{NewXSCode}); pp_add_boot($obj{BootSetNewXS}) if $obj{BootSetNewXS}; PDL::PP->pp_add_exported($name); PDL::PP::pp_addpm("\n".$obj{PdlDoc}."\n") if $obj{PdlDoc}; PDL::PP::pp_addpm($obj{PMCode}) if defined $obj{PMCode}; PDL::PP::pp_addpm($obj{PMFunc}."\n"); print "*** Leaving pp_def for $name\n" if $::PP_VERBOSE; } # marks this module as deprecated. This handles the user warnings, and adds a # notice into the documentation. Can take a {infavor => "newmodule"} option sub pp_deprecate_module { my $options; if( ref $_[0] eq 'HASH' ) { $options = shift; } else { $options = { @_ }; } my $infavor; if( $options && ref $options eq 'HASH' && $options->{infavor} ) { $infavor = $options->{infavor}; } my $mod = $::PDLMOD; my $envvar = 'PDL_SUPPRESS_DEPRECATION_WARNING__' . uc $mod; $envvar =~ s/::/_/g; my $warning_main = "$mod is deprecated."; $warning_main .= " Please use $infavor instead." if $infavor; my $warning_suppression_runtime = "This module will be removed in the future; please update your code.\n" . "Set the environment variable $envvar\n" . "to suppress this warning\n"; my $warning_suppression_pod = "A warning will be generated at runtime upon a C of this module\n" . "This warning can be suppressed by setting the $envvar\n" . "environment variable\n"; my $deprecation_notice = < 'Top'}, $deprecation_notice ); pp_addpm {At => 'Top'}, <) { next if /^\s*#/; my $line_no = $. + 1; if (/^INPUT\s*$/) { $mode = 'Input'; $current = \$junk; next; } if (/^OUTPUT\s*$/) { $mode = 'Output'; $current = \$junk; next; } if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk; next; } if ($mode eq 'Typemap') { chomp; my $line = $_ ; TrimWhitespace($_) ; # skip blank lines and comment lines next if /^$/ or /^#/ ; my($t_type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next; $t_type = TidyType($t_type) ; $type_kind{$t_type} = $kind ; # prototype defaults to '$' $proto = "\$" unless $proto ; warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n") unless ValidProtoString($proto) ; $proto_letter{$t_type} = C_string($proto) ; } elsif (/^\s/) { $$current .= $_; } elsif ($mode eq 'Input') { s/\s+$//; $input_expr{$_} = ''; $current = \$input_expr{$_}; } else { s/\s+$//; $output_expr{$_} = ''; $current = \$output_expr{$_}; } } close $fh; } # # Do checks... # # First reconstruct the type declaration to look up in type_kind my $full_type=TidyType($type->get_decl('', {VarArrays2Ptrs=>1})); # Skip the variable name die "The type =$full_type= does not have a typemap entry!\n" unless exists($type_kind{$full_type}); my $typemap_kind = $type_kind{$full_type}; # Look up the conversion from the INPUT typemap. Note that we need to do some # massaging of this. my $input = $input_expr{$typemap_kind}; $input =~ s/^(.*?)=\s*//s; # Remove all before = $input =~ s/\$(var|\{var\})/$oname/g; $input =~ s/\$(arg|\{arg\})/$arg/g; $input =~ s/\$(type|\{type\})/$full_type/g; return ($input); } sub wrap_vfn { my ( $code,$rout,$func_header, $all_func_header,$sname,$pname,$ptype,$extra_args, ) = @_; my $str = join "\n", grep $_, $all_func_header, $func_header, $code; my $opening = 'pdl_error PDL_err = {0, NULL, 0};'; my $closing = 'return PDL_err;'; PDL::PP::pp_line_numbers(__LINE__, <params;" : ""]} $str$closing} EOF } my @vfn_args_always = (\"AllFuncHeader", qw(StructName ParamStructName ParamStructType)); sub make_vfn_args { my ($which, $extra_args) = @_; ("${which}Func", ["${which}CodeSubd","${which}FuncName",\"${which}FuncHeader", @vfn_args_always ], sub {$_[1] eq 'NULL' ? '' : wrap_vfn(@_,$extra_args//'')} ); } sub make_xs_code { my($xscode_before,$xscode_after,$str, $xs_c_headers, @bits) = @_; my($boot,$prelude); if($xs_c_headers) { $prelude = join '' => ($xs_c_headers->[0], @bits, $xs_c_headers->[1]); $boot = $xs_c_headers->[2]; $str .= "\n"; } else { my $xscode = join '' => @bits; $str .= " $xscode_before\n $xscode$xscode_after\n\n"; } $str =~ s/(\s*\n)+/\n/g; ($str,$boot,$prelude) } sub indent($$) { my ($text,$ind) = @_; $text =~ s/^(.*)$/$ind$1/mg; return $text; } # This subroutine generates the XS code needed to call the perl 'initialize' # routine in order to create new output PDLs sub callPerlInit { my $names = shift; # names of variables to initialize my $ci = shift; # current indenting my $callcopy = $#_ > -1 ? shift : 0; my $ret = ''; foreach my $name (@$names) { my ($to_push, $method) = $callcopy ? ('parent', 'copy') : ('sv_2mortal(newSVpv(objname, 0))', 'initialize'); $ret .= PDL::PP::pp_line_numbers(__LINE__-1, "PDL_XS_PERLINIT($name, $to_push, $method)\n"); } indent($ret,$ci); } #sub callPerlInit() ########################################################### # Name : extract_signature_from_fulldoc # Usage : $sig = extract_signature_from_fulldoc($fulldoc) # Purpose : pull out the signature from the fulldoc string # Returns : whatever is in parentheses in the signature, or undef # Parameters : $fulldoc # Throws : never # Notes : the signature must have the following form: # : # : =for sig # : # : Signature: () # : # : # : The two spaces before "Signature" are required, as are # : the parentheses. sub extract_signature_from_fulldoc { my $fulldoc = shift; if ($fulldoc =~ /=for sig\n\n Signature: \(([^\n]*)\n/g) { # Extract the signature and remove the final parenthesis my $sig = $1; $sig .= $1 while $fulldoc =~ /\G\h+([^\n]*)\n/g; $sig =~ s/\)\s*$//; return $sig; } return; } # function to be run by real pp_def so fake pp_def can do without other modules sub load_deftable { # Build the valid-types regex and valid Pars argument only once. These are # also used in PDL::PP::PdlParObj, which is why they are globally available. my $pars_re = $PDL::PP::PdlParObj::pars_re; # Set up the rules for translating the pp_def contents. # $PDL::PP::deftbl = [ PDL::PP::Rule->new( [qw(RedoDims EquivCPOffsCode HandleBad P2Child TwoWay)], ["Identity"], "something to do with dataflow between CHILD & PARENT, I think.", sub { (PDL::PP::pp_line_numbers(__LINE__-1, ' int i; $SETNDIMS($PARENT(ndims)); for(i=0; i<$CHILD(ndims); i++) { $CHILD(dims[i]) = $PARENT(dims[i]); } $SETDIMS(); $SETDELTATHREADIDS(0); $PRIV(dims_redone) = 1; '), # NOTE: we use the same bit of code for all-good and bad data - # see the Code rule # we can NOT assume that PARENT and CHILD have the same type, # hence the version for bad code # # NOTE: we use the same code for 'good' and 'bad' cases - it's # just that when we use it for 'bad' data, we have to change the # definition of the EQUIVCPOFFS macro - see the Code rule PDL::PP::pp_line_numbers(__LINE__, 'PDL_Indx i; for(i=0; i<$PDL(CHILD)->nvals; i++) { $EQUIVCPOFFS(i,i); }'), 1, 1, 1); }), # used as a flag for many of the routines # ie should we bother with bad values for this routine? # 1 - yes, # 0 - no, maybe issue a warning PDL::PP::Rule->new("BadFlag", \"HandleBad", "Sets BadFlag based upon HandleBad key", sub { $_[0] }), #################### # FullDoc Handling # #################### # Error processing: does FullDoc contain BadDoc, yet BadDoc specified? PDL::PP::Rule::Croak->new(['FullDoc', 'BadDoc'], 'Cannot have both FullDoc and BadDoc defined'), PDL::PP::Rule::Croak->new(['FullDoc', 'Doc'], 'Cannot have both FullDoc and Doc defined'), # Note: no error processing on Pars; it's OK for the docs to gloss over # the details. # Add the Pars section based on the signature of the FullDoc if the Pars # section doesn't already exist PDL::PP::Rule->new('Pars', 'FullDoc', 'Sets the Pars from the FullDoc if Pars is not explicitly specified', # Purpose : extract the Pars from the signature from the fulldoc string, # : the part of the signature that specifies the ndarrays # Returns : a string appropriate for the Pars key # Parameters : $fulldoc # Throws : if there is no signature # : if there is no extractable Pars section # : if some PDL arguments come after the OtherPars arguments start # Notes : This is meant to be used directly in a Rule. Therefore, it # : is only called if the Pars key does not yet exist, so if it # : is not possible to extract the Pars section, it dies. sub { my $fulldoc = shift; # Get the signature or die my $sig = extract_signature_from_fulldoc($fulldoc) or confess('No Pars specified and none could be extracted from FullDoc'); # Everything is semicolon-delimited my @args = split /\s*;\s*/, $sig; my @pars; my $switched_to_other_pars = 0; for my $arg (@args) { confess('All PDL args must come before other pars in FullDoc signature') if $switched_to_other_pars and $arg =~ $pars_re; if ($arg =~ $pars_re) { push @pars, $arg; } else { $switched_to_other_pars = 1; } } # Make sure there's something there confess('FullDoc signature contains no PDL arguments') if @pars == 0; # All done! return join('; ', @pars); } ), PDL::PP::Rule->new('OtherPars', 'FullDoc', 'Sets the OtherPars from the FullDoc if OtherPars is not explicitly specified', # Purpose : extract the OtherPars from the signature from the fulldoc # : string, the part of the signature that specifies non-ndarray # : arguments # Returns : a string appropriate for the OtherPars key # Parameters : $fulldoc # Throws : if some OtherPars arguments come before the last PDL argument # Notes : This is meant to be used directly in a Rule. Therefore, it # : is only called if the OtherPars key does not yet exist. sub { my $fulldoc = shift; # Get the signature or do not set my $sig = extract_signature_from_fulldoc($fulldoc) or return 'DO NOT SET!!'; # Everything is semicolon-delimited my @args = split /\s*;\s*/, $sig; my @otherpars; for my $arg (@args) { confess('All PDL args must come before other pars in FullDoc signature') if @otherpars > 0 and $arg =~ $pars_re; if ($arg !~ $pars_re) { push @otherpars, $arg; } } # All done! return 'DO NOT SET!!'if @otherpars == 0; return join('; ', @otherpars); } ), ################################ # Other Documentation Handling # ################################ # no docs by default PDL::PP::Rule::Returns->new("Doc", [], 'Sets the default doc string', "\n=for ref\n\ninfo not available\n"), # try and automate the docs # could be really clever and include the sig to see about # input/output params, for instance PDL::PP::Rule->new("BadDoc", ["BadFlag","Name",\"CopyBadStatusCode"], 'Sets the default documentation for handling of bad values', sub { my ( $bf, $name, $code ) = @_; my $str; if ( not defined($bf) ) { $str = "$name does not process bad values.\n"; } elsif ( $bf ) { $str = "$name processes bad values.\n"; } else { $str = "$name ignores the bad-value flag of the input ndarrays.\n"; } if ( not defined($code) ) { $str .= "It will set the bad-value flag of all output ndarrays if " . "the flag is set for any of the input ndarrays.\n"; } elsif ( $code eq '' ) { $str .= "The output ndarrays will NOT have their bad-value flag set.\n"; } else { $str .= "The state of the bad-value flag of the output ndarrays is unknown.\n"; } } ), # Default: no otherpars PDL::PP::Rule::Returns::EmptyString->new("OtherPars"), # the docs PDL::PP::Rule->new("PdlDoc", "FullDoc", sub { my $fulldoc = shift; # Append a final cut if it doesn't exist due to heredoc shinanigans $fulldoc .= "\n\n=cut\n" unless $fulldoc =~ /\n=cut\n*$/; # Make sure the =head1 FUNCTIONS section gets added $::DOCUMENTED++; return $fulldoc; } ), PDL::PP::Rule->new("PdlDoc", ["Name",\"Pars","OtherPars","Doc",\"BadDoc"], sub { my ($name,$pars,$otherpars,$doc,$baddoc) = @_; return '' if !defined $doc # Allow explcit non-doc using Doc=>undef or $doc =~ /^\s*internal\s*$/i; # If the doc string is one line let's have to for the # reference card information as well $doc = "=for ref\n\n".$doc if $doc !~ /\n/; $::DOCUMENTED++; $pars = "P(); C()" unless $pars; # Strip leading whitespace and trailing semicolons and whitespace $pars =~ s/^\s*(.+[^;])[;\s]*$/$1/; $otherpars =~ s/^\s*(.+[^;])[;\s]*$/$1/ if $otherpars; my $sig = "$pars".( $otherpars ? "; $otherpars" : ""); $doc =~ s/\n(=cut\s*\n)+(\s*\n)*$/\n/m; # Strip extra =cut's if ( defined $baddoc ) { # Strip leading newlines and any =cut markings $baddoc =~ s/\n(=cut\s*\n)+(\s*\n)*$/\n/m; $baddoc =~ s/^\n+//; $baddoc = "=for bad\n\n$baddoc"; } my $baddoc_function_pod = <<"EOD" ; XXX=head2 $name XXX=for sig Signature: ($sig) $doc $baddoc XXX=cut EOD $baddoc_function_pod =~ s/^XXX=/=/gms; return $baddoc_function_pod; } ), ################## # Done with Docs # ################## # Notes # Suffix 'NS' means, "Needs Substitution". In other words, the string # associated with a key that has the suffix "NS" must be run through a # Substitute or Substitute::Usual # The substituted version should then replace "NS" with "Subd" # So: FreeCodeNS -> FreeCodeSubd PDL::PP::Rule::Returns->new("StructName", "__privtrans"), PDL::PP::Rule::Returns->new("ParamStructName", "__params"), PDL::PP::Rule::Croak->new([qw(P2Child GenericTypes)], 'Cannot have both P2Child and GenericTypes defined'), PDL::PP::Rule->new([qw(Pars HaveThreading CallCopy GenericTypes DefaultFlow AllFuncHeader RedoDimsFuncHeader)], ["P2Child","Name","StructName"], sub { my (undef,$name,$sname) = @_; ("PARENT(); [oca]CHILD();",0,0,[PDL::Types::ppdefs_all()],1, pp_line_numbers(__LINE__-1,"\tpdl *__it = $sname->pdls[1];\n\tpdl *__parent = $sname->pdls[0];\n"), pp_line_numbers(__LINE__-1,"PDL->hdr_childcopy($sname);\n$sname->dims_redone = 1;\n"), ); }), # Question: where is ppdefs defined? # Answer: Core/Types.pm # PDL::PP::Rule->new("GenericTypes", [], 'Sets GenericTypes flag to all real types known to PDL::Types', sub {[PDL::Types::ppdefs()]}), PDL::PP::Rule->new("ExtraGenericSwitches", "FTypes", 'Makes ExtraGenericSwitches identical to FTypes if the latter exists and the former does not', sub {return $_[0]}), PDL::PP::Rule::Returns->new("ExtraGenericSwitches", [], 'Sets ExtraGenericSwitches to an empty hash if it does not already exist', {}), PDL::PP::Rule::InsertName->new("VTableName", 'pdl_${name}_vtable'), PDL::PP::Rule::Returns->new("Priv", "AffinePriv", 'PDL_Indx incs[$CHILD(ndims)];PDL_Indx offs; '), PDL::PP::Rule::Returns->new("IsAffineFlag", "AffinePriv", "PDL_ITRANS_ISAFFINE"), PDL::PP::Rule::Returns::Zero->new("IsAffineFlag"), PDL::PP::Rule::Returns->new("TwoWayFlag", "TwoWay", "PDL_ITRANS_TWOWAY"), PDL::PP::Rule::Returns::Zero->new("TwoWayFlag"), PDL::PP::Rule::Returns->new("DefaultFlowFlag", "DefaultFlow", "PDL_ITRANS_DO_DATAFLOW_ANY"), PDL::PP::Rule::Returns::Zero->new("DefaultFlowFlag"), PDL::PP::Rule->new("RedoDims", ["EquivPDimExpr",\"EquivDimCheck"], sub { my($pdimexpr,$dimcheck) = @_; $pdimexpr =~ s/\$CDIM\b/i/g; PDL::PP::pp_line_numbers(__LINE__-1, ' int i,cor; '.$dimcheck.' $SETNDIMS($PARENT(ndims)); $DOPRIVALLOC(); $PRIV(offs) = 0; for(i=0; i<$CHILD(ndims); i++) { cor = '.$pdimexpr.'; $CHILD(dims[i]) = $PARENT(dims[cor]); $PRIV(incs[i]) = $PARENT(dimincs[cor]); } $SETDIMS(); $SETDELTATHREADIDS(0); $PRIV(dims_redone) = 1; '); }), PDL::PP::Rule->new("Code", ["EquivCPOffsCode","BadFlag"], "create Code from EquivCPOffsCode", # NOTE: EQUIVCPOFFS and EQUIVCPTRUNC both suffer from the macro-block # wart of C preprocessing. They look like statements but sometimes # process into blocks, so if/then/else constructs can get broken. # Either (1) use blocks for if/then/else, or (2) get excited and # use the "do {BLOCK} while(0)" block-to-statement conversion construct # in the substitution. I'm too Lazy. --CED 27-Jan-2003 sub { my $good = shift; my $bflag = shift; my $bad = $good; # parse 'good' code $good =~ s/\$EQUIVCPOFFS\(([^()]+),([^()]+)\)/\$PP(CHILD)[$1] = \$PP(PARENT)[$2]/g; $good =~ s/\$EQUIVCPTRUNC\(([^()]+),([^()]+),([^()]+)\)/\$PP(CHILD)[$1] = ($3) ? 0 : \$PP(PARENT)[$2]/g; return $good if !$bflag; # parse 'bad' code $bad =~ s/\$EQUIVCPOFFS\(([^()]+),([^()]+)\)/if( \$PPISBAD(PARENT,[$2]) ) { \$PPSETBAD(CHILD,[$1]); } else { \$PP(CHILD)[$1] = \$PP(PARENT)[$2]; }/g; $bad =~ s/\$EQUIVCPTRUNC\(([^()]+),([^()]+),([^()]+)\)/ if( ($3) || \$PPISBAD(PARENT,[$2]) ) { \$PPSETBAD(CHILD,[$1]); } else {\$PP(CHILD)[$1] = \$PP(PARENT)[$2]; }/g; PDL::PP::pp_line_numbers(__LINE__-1, 'if ( $PRIV(bvalflag) ) { ' . $bad . ' } else { ' . $good . '}'); }), PDL::PP::Rule->new("BackCode", ["EquivCPOffsCode","BadFlag"], "create BackCode from EquivCPOffsCode", # If there is an EquivCPOffsCode and: # no bad-value support ==> use that # bad value support ==> write a bit of code that does # if ( $PRIV(bvalflag) ) { bad-EquivCPOffsCode } # else { good-EquivCPOffsCode } # # Note: since EquivCPOffsCode doesn't (or I haven't seen any that # do) use 'loop %{' or 'threadloop %{', we can't rely on # PDLCode to automatically write code like above, hence the # explicit definition here. # # Note: I *assume* that bad-Equiv..Code == good-Equiv..Code *EXCEPT* # that we re-define the meaning of the $EQUIVCPOFFS macro to # check for bad values when copying things over. # This means having to write less code. # # Since PARENT & CHILD need NOT be the same type we cannot just copy # values from one to the other - we have to check for the presence # of bad values, hence the expansion for the $bad code # # Some operators (notably range) also have an out-of-range flag; they use # the macro EQUIVCPTRUNC instead of EQUIVCPOFFS. # $EQUIVCPTRUNC does the same as EQUIVCPOFFS but accepts a # child-out-of-bounds flag. If the out-of-bounds flag is set, the # forward code puts BAD/0 into the child, and reverse code refrains # from copying. # --CED 27-Jan-2003 # # this just reverses PARENT & CHILD in the expansion of # the $EQUIVCPOFFS macro (ie compared to Code from EquivCPOffsCode) sub { my ($good, $bflag) = @_; my $bad = $good; # parse 'good' code $good =~ s/\$EQUIVCPOFFS\(([^()]+),([^()]+)\)/\$PP(PARENT)[$2] = \$PP(CHILD)[$1]/g; $good =~ s/\$EQUIVCPTRUNC\(([^()]+),([^()]+),([^()]+)\)/if(!($3)) \$PP(PARENT)[$2] = \$PP(CHILD)[$1] /g; return $good if !$bflag; # parse 'bad' code $bad =~ s/\$EQUIVCPOFFS\(([^()]+),([^()]+)\)/if( \$PPISBAD(CHILD,[$1]) ) { \$PPSETBAD(PARENT,[$2]); } else { \$PP(PARENT)[$2] = \$PP(CHILD)[$1]; }/g; $bad =~ s/\$EQUIVCPTRUNC\(([^()]+),([^()]+),([^()]+)\)/if(!($3)) { if( \$PPISBAD(CHILD,[$1]) ) { \$PPSETBAD(PARENT,[$2]); } else { \$PP(PARENT)[$2] = \$PP(CHILD)[$1]; } } /g; PDL::PP::pp_line_numbers(__LINE__-1, 'if ( $PRIV(bvalflag) ) { ' . $bad . ' } else { ' . $good . '}'); }), PDL::PP::Rule::Returns::Zero->new("Affine_Ok", "EquivCPOffsCode"), PDL::PP::Rule::Returns::One->new("Affine_Ok"), PDL::PP::Rule::Returns::NULL->new("ReadDataFuncName", "AffinePriv"), PDL::PP::Rule::Returns::NULL->new("WriteBackDataFuncName", "AffinePriv"), PDL::PP::Rule::InsertName->new("NewXSName", '_${name}_int'), PDL::PP::Rule::Returns::One->new("HaveThreading"), # Parameters in the 'a(x,y); [o]b(y)' format, with # fixed nos of real, unthreaded-over dims. # Also "Other pars", the parameters which are usually not pdls. PDL::PP::Rule->new("SignatureObj", ["Pars","BadFlag","OtherPars"], sub { PDL::PP::Signature->new(@_) }), # Set CallCopy flag for simple functions (2-arg with 0-dim signatures) # This will copy the $object->copy method, instead of initialize # for PDL-subclassed objects # PDL::PP::Rule->new("CallCopy", ["SignatureObj", "Name"], sub { my ($sig, $Name, $hasp2c) = @_; my $noDimmedArgs = $sig->dims_count; my $noArgs = @{$sig->names}; # Check for 2-arg function with 0-dim signatures return 0 if !($noDimmedArgs == 0 and $noArgs == 2); # Check to see if output arg is _not_ explicitly typed: !$sig->objs->{$sig->names->[1]}{FlagTyped}; }), PDL::PP::Rule->new(["InplaceCode","InplaceCheck"], ["SignatureObj","Inplace"], 'Insert code (just after HdrCode) to ensure the routine can be done inplace', # insert code, after the autogenerated xs argument processing code # produced by VarArgsXSHdr and AFTER any in HdrCode # - this code flags the routine as working inplace, # # Inplace can be supplied several values # => 1 # assumes fn has an input and output ndarray (eg 'a(); [o] b();') # => [ 'a' ] # assumes several input ndarrays in sig, so 'a' labels which # one is to be marked inplace # => [ 'a', 'b' ] # input ndarray is a(), output ndarray is 'b' sub { my ( $sig, $arg ) = @_; return '' if !$arg; confess "Inplace array-ref (@$arg) > 2 elements" if ref($arg) eq "ARRAY" and @$arg > 2; # find input and output ndarrays my @out = $sig->names_out; my @in = $sig->names_in; my $in = @in == 1 ? $in[0] : undef; my $out = @out == 1 ? $out[0] : undef; if ( ref($arg) eq "ARRAY" and @$arg) { $in = $$arg[0]; $out = $$arg[1] if @$arg > 1; } confess "ERROR: Inplace does not know name of input ndarray\n" unless defined $in; confess "ERROR: Inplace does not know name of output ndarray\n" unless defined $out; ( PDL::PP::pp_line_numbers(__LINE__-1, "PDL_XS_INPLACE($in, $out)\n"), PDL::PP::pp_line_numbers(__LINE__-1, "PDL_XS_INPLACE_CHECK($in)\n"), ); }), PDL::PP::Rule::Returns::EmptyString->new("InplaceCode", []), PDL::PP::Rule::Returns::EmptyString->new("InplaceCheck", []), PDL::PP::Rule::Returns::EmptyString->new("HdrCode", [], 'Code that will be inserted at the end of the autogenerated xs argument processing code VargArgsXSHdr'), PDL::PP::Rule->new("VarArgsXSHdr", ["Name","SignatureObj", "HdrCode","InplaceCode","InplaceCheck",\"CallCopy",\"OtherParsDefaults"], 'XS code to process input arguments based on supplied Pars argument to pp_def; not done if GlobalNew or PMCode supplied', sub { my($name,$sig, $hdrcode,$inplacecode,$inplacecheck,$callcopy,$defaults) = @_; my $optypes = $sig->otherobjs(1); my @args = $sig->alldecls(0, 1); my %other = map +($_ => exists($$optypes{$_})), @args; if (keys %{ $defaults ||= {} } < keys %other) { my $default_seen = ''; for (@args) { $default_seen = $_ if exists $defaults->{$_}; confess "got default-less arg '$_' after default-ful arg '$default_seen'" if $default_seen and !exists $defaults->{$_}; } } my $ci = ' '; # current indenting my $pars = join "\n",map "$ci$_ = 0;", $sig->alldecls(1, 0); my %out = map +($_=>1), $sig->names_out_nca; my %outca = map +($_=>1), $sig->names_oca; my %tmp = map +($_=>1), $sig->names_tmp; # remember, otherpars *are* input vars my $nout = grep $_, values %out; my $noutca = grep $_, values %outca; my $nother = grep $_, values %other; my $ntmp = grep $_, values %tmp; my $ntot = @args; my $nmaxonstack = $ntot - $noutca; my $nin = $ntot - ($nout + $noutca); my $ninout = $nin + $nout; my $nallout = $nout + $noutca; my $ndefault = keys %$defaults; my $usageargs = join ",", map exists $defaults->{$_} ? "$_=$defaults->{$_}" : $_, grep !$tmp{$_}, @args; # Generate declarations for SV * variables corresponding to pdl * output variables. # These are used in creating output variables. One variable (ex: SV * outvar1_SV;) # is needed for each output and output create always argument my $svdecls = join "\n", map "${ci}SV *${_}_SV = NULL;", $sig->names_out; my $clause_inputs = ''; my %already_read; my $cnt = 0; foreach my $x (@args) { last if $out{$x} || $outca{$x} || $other{$x}; $already_read{$x} = 1; $clause_inputs .= "$ci$x = PDL->SvPDLV(ST($cnt));\n"; $cnt++; } my @create = (); # The names of variables which need to be created by calling # the 'initialize' perl routine from the correct package. $ci = ' '; # Current indenting # clause for reading in all variables my $clause1 = $inplacecheck; $cnt = 0; foreach my $x (@args) { if ($other{$x}) { # other par $clause1 .= "$ci$x = " . typemap($x, $$optypes{$x}, "ST($cnt)") . ";\n"; $cnt++; } elsif ($outca{$x}) { push (@create, $x); } else { $clause1 .= "$ci$x = PDL->SvPDLV(". ($out{$x} ? "${x}_SV = " : ''). "ST($cnt));\n" if !$already_read{$x}; $cnt++; } } # Add code for creating output variables via call to 'initialize' perl routine $clause1 .= callPerlInit (\@create, $ci, $callcopy); @create = (); # clause for reading in input and creating output vars my $clause3 = ''; my $defaults_rawcond = $ndefault ? "items == ($nin-$ndefault)" : ''; $cnt = 0; foreach my $x (@args) { if ($other{$x}) { my $setter = typemap($x, $$optypes{$x}, "ST($cnt)"); $clause3 .= "$ci$x = " . (exists $defaults->{$x} ? "($defaults_rawcond) ? ($defaults->{$x}) : ($setter)" : $setter) . ";\n"; $cnt++; } elsif ($out{$x} || $outca{$x}) { push (@create, $x); } else { $clause3 .= "$ci$x = PDL->SvPDLV(ST($cnt));\n" if !$already_read{$x}; $cnt++; } } # Add code for creating output variables via call to 'initialize' perl routine $clause3 .= callPerlInit (\@create, $ci, $callcopy); @create = (); my $defaults_cond = $ndefault ? " || $defaults_rawcond" : ''; $clause3 = <new("VarArgsXSReturn","GlobalNew",undef), PDL::PP::Rule->new("VarArgsXSReturn", ["SignatureObj"], "Generate XS trailer to return output variables or leave them as modified input variables", sub { my @outs = $_[0]->names_out; # names of output variables (in calling order) my $clause1 = join ';', map "ST($_) = $outs[$_]_SV", 0 .. $#outs; PDL::PP::pp_line_numbers(__LINE__-1, "PDL_XS_RETURN($clause1)"); }), PDL::PP::Rule->new("NewXSHdr", ["NewXSName","SignatureObj"], sub { my($name,$sig) = @_; my $shortpars = join ',', $sig->alldecls(0, 1); my $longpars = join "\n", map "\t$_", $sig->alldecls(1, 1); return<new("RunFuncName", 'pdl_${name}_run'), PDL::PP::Rule->new("NewXSCHdrs", ["RunFuncName","SignatureObj","GlobalNew"], sub { my($name,$sig,$gname) = @_; my $longpars = join ",", $sig->alldecls(1, 0); my $opening = 'pdl_error PDL_err = {0, NULL, 0};'; my $closing = 'return PDL_err;'; return ["pdl_error $name($longpars) {$opening","$closing}", "PDL->$gname = $name;"]; }), PDL::PP::Rule->new(["RunFuncCall","RunFuncHdr"],["RunFuncName","SignatureObj"], sub { my ($func_name,$sig) = @_; my $shortpars = join ',', $sig->alldecls(0, 0); my $longpars = join ",", $sig->alldecls(1, 0); (PDL::PP::pp_line_numbers(__LINE__-1, "PDL->barf_if_error($func_name($shortpars));"), "pdl_error $func_name($longpars)"); }), PDL::PP::Rule->new("NewXSMakeNow", ["SignatureObj"], sub { join '', map PDL::PP::pp_line_numbers(__LINE__-1, "$_ = PDL->make_now($_);\n"), @{ $_[0]->names } }), PDL::PP::Rule->new("IgnoreTypesOf", ["FTypes","SignatureObj"], sub { my ($ftypes, $sig) = @_; my ($pnames, $pobjs) = ($sig->names_sorted, $sig->objs); $_->{FlagIgnore} = 1 for grep $ftypes->{$_->{Name}}, @$pobjs{@$pnames}; +{map +($_,1), keys %$ftypes}; }), PDL::PP::Rule::Returns->new("IgnoreTypesOf", {}), PDL::PP::Rule->new("NewXSCoerceMustNS", "FTypes", sub { my($ftypes) = @_; join '', map PDL::PP::pp_line_numbers(__LINE__, "$_->datatype = $ftypes->{$_};"), sort keys %$ftypes; }), PDL::PP::Rule::Substitute::Usual->new("NewXSCoerceMustSubd", "NewXSCoerceMustNS"), PDL::PP::Rule->new("NewXSTypeCoerceNS", ["StructName"], sub { PDL::PP::pp_line_numbers(__LINE__, <type_coerce($_[0])); EOF }), PDL::PP::Rule::Substitute::Usual->new("NewXSTypeCoerceSubd", "NewXSTypeCoerceNS"), PDL::PP::Rule->new("NewXSSetTransPDLs", ["SignatureObj","StructName"], sub { my($sig,$trans) = @_; join '', map PDL::PP::pp_line_numbers(__LINE__, "$trans->pdls[$_->[0]] = $_->[2];\n"), grep !$_->[1], $sig->names_sorted_tuples; }), PDL::PP::Rule->new("NewXSExtractTransPDLs", ["SignatureObj","StructName"], sub { my($sig,$trans) = @_; join '', map PDL::PP::pp_line_numbers(__LINE__, "$_->[2] = $trans->pdls[$_->[0]];\n"), grep !$_->[1], $sig->names_sorted_tuples; }), PDL::PP::Rule->new("NewXSRunTrans", ["StructName"], sub { my($trans) = @_; PDL::PP::pp_line_numbers(__LINE__, "PDL_RETERROR(PDL_err, PDL->make_trans_mutual($trans));\n"); }), PDL::PP::Rule->new(PDL::PP::Code::make_args("Code"), sub { PDL::PP::Code->new(@_, undef, undef); }), PDL::PP::Rule->new(PDL::PP::Code::make_args("BackCode"), sub { PDL::PP::Code->new(@_, undef, 1); }), # Compiled representations i.e. what the RunFunc function leaves # in the params structure. By default, copies of the parameters # but in many cases (e.g. slice) a benefit can be obtained # by parsing the string in that function. # If the user wishes to specify their own MakeComp code and Comp content, # The next definitions allow this. PDL::PP::Rule->new("CompObj", ["BadFlag","Comp"], sub { PDL::PP::Signature->new('', @_) }), PDL::PP::Rule->new("CompObj", "SignatureObj", sub { @_ }), # provide default PDL::PP::Rule->new("MakeCompOther", "SignatureObj", sub { $_[0]->getcopy }), PDL::PP::Rule->new("MakeCompTotal", ["MakeCompOther", \"MakeComp"], sub { join "\n", grep $_, @_ }), PDL::PP::Rule->new("CompStructOther", "SignatureObj", sub {$_[0]->getcomp}), PDL::PP::Rule->new("CompStructComp", [qw(CompObj Comp)], sub {$_[0]->getcomp}), PDL::PP::Rule->new("CompStruct", ["CompStructOther", \"CompStructComp"], sub { join "\n", grep $_, @_ }), PDL::PP::Rule::MakeComp->new("MakeCompiledReprNS", ["MakeCompTotal","CompObj"], "COMP"), PDL::PP::Rule->new("CompFreeCodeOther", "SignatureObj", sub {$_[0]->getfree("COMP")}), PDL::PP::Rule->new("CompFreeCodeComp", [qw(CompObj Comp)], sub {$_[0]->getfree("COMP")}), PDL::PP::Rule->new("CompFreeCode", ["CompFreeCodeOther", \"CompFreeCodeComp"], sub { join "\n", grep $_, @_ }), PDL::PP::Rule->new(["StructDecl","ParamStructType"], ["CompStruct","Name"], sub { my($comp,$name) = @_; return ('', '') if !$comp; my $ptype = "pdl_params_$name"; (PDL::PP::pp_line_numbers(__LINE__-1, qq{typedef struct $ptype {\n$comp} $ptype;}), $ptype); }), PDL::PP::Rule::Substitute->new("MakeCompiledReprSubd", "MakeCompiledReprNS"), PDL::PP::Rule->new("DefaultRedoDims", ["StructName"], sub { "PDL_RETERROR(PDL_err, PDL->redodims_default($_[0]));" }), PDL::PP::Rule->new("DimsSetters", ["SignatureObj"], sub { join "\n", sort map $_->get_initdim, $_[0]->dims_values }), PDL::PP::Rule->new("RedoDimsFuncName", ["Name", \"RedoDims", \"RedoDimsCode", "DimsSetters"], sub { (scalar grep $_ && /\S/, @_[1..$#_]) ? "pdl_$_[0]_redodims" : 'NULL'}), PDL::PP::Rule::Returns->new("RedoDimsCode", [], 'Code that can be inserted to set the size of output ndarrays dynamically based on input ndarrays; is parsed', ''), PDL::PP::Rule->new(PDL::PP::Code::make_args("RedoDimsCode"), 'makes the parsed representation from the supplied RedoDimsCode', sub { return '' if !$_[0]; PDL::PP::Code->new(@_, 1, undef); }), PDL::PP::Rule->new("RedoDims", ["DimsSetters","ParsedRedoDimsCode","DefaultRedoDims"], 'makes the redodims function from the various bits and pieces', sub { join "\n", grep $_ && /\S/, @_ }), PDL::PP::Rule::Returns::EmptyString->new("Priv"), PDL::PP::Rule->new("PrivObj", ["BadFlag","Priv"], sub { PDL::PP::Signature->new('', @_) }), PDL::PP::Rule->new("NTPrivFreeCode", "PrivObj", sub {$_[0]->getfree("PRIV")}), PDL::PP::Rule->new("FreeCodeNS", ["StructName","CompFreeCode","NTPrivFreeCode"], sub { (grep $_, @_[1..$#_]) ? PDL::PP::pp_line_numbers(__LINE__-1, "PDL_FREE_CODE($_[0], destroy, $_[1], $_[2])"): ''}), PDL::PP::Rule::Substitute::Usual->new("FreeCodeSubd", "FreeCodeNS"), PDL::PP::Rule::Returns::EmptyString->new("NewXSCoerceMustSubd"), PDL::PP::Rule::MakeComp->new("NewXSCoerceMustCompNS", "NewXSCoerceMustSubd", "FOO"), PDL::PP::Rule::Substitute->new("NewXSCoerceMustCompSubd", "NewXSCoerceMustCompNS"), PDL::PP::Rule->new("NewXSFindBadStatusNS", "FindBadStatusCode", sub {@_}), PDL::PP::Rule->new("NewXSFindBadStatusNS", ["StructName"], "Rule to find the bad value status of the input ndarrays", sub { PDL::PP::pp_line_numbers(__LINE__, <trans_check_pdls($_[0])); char \$BADFLAGCACHE() = PDL->trans_badflag_from_inputs($_[0]); EOF }), PDL::PP::Rule->new("NewXSCopyBadStatusNS", ["CopyBadStatusCode"], "Use CopyBadStatusCode if given", sub { my ($badcode) = @_; confess "PDL::PP ERROR: CopyBadStatusCode contains '\$PRIV(bvalflag)'; replace with \$BADFLAGCACHE()" if $badcode =~ m/\$PRIV(bvalflag)/; $badcode; }), PDL::PP::Rule->new("NewXSCopyBadStatusNS", ["SignatureObj"], "Rule to copy the bad value status to the output ndarrays", # note: this is executed before the trans_mutual call # is made, since the state may be changed by the # Code section sub { my ( $sig ) = @_; return '' if @{$sig->names} == (my @outs = $sig->names_out); # no input pdls, no badflag copying needed PDL::PP::pp_line_numbers(__LINE__, join '', "if (\$BADFLAGCACHE()) {\n", (map " \$SETPDLSTATEBAD($_);\n", @outs), "}\n"); }), # expand macros in ...BadStatusCode # PDL::PP::Rule::Substitute::Usual->new("NewXSFindBadStatusSubd", "NewXSFindBadStatusNS"), PDL::PP::Rule::Substitute::Usual->new("NewXSCopyBadStatusSubd", "NewXSCopyBadStatusNS"), PDL::PP::Rule->new("NewXSStructInit0", ["StructName","VTableName","ParamStructName","ParamStructType"], "Rule to create and initialise the private trans structure", sub { my( $sname, $vtable, $pname, $ptype ) = @_; PDL::PP::pp_line_numbers(__LINE__, <create_trans(&$vtable); @{[$ptype ? " $ptype *$pname = $sname->params;" : ""]} EOF }), PDL::PP::Rule->new(["RunFunc"], ["RunFuncHdr", "NewXSStructInit0", "NewXSSetTransPDLs", "NewXSFindBadStatusSubd", # NewXSMakeNow, # this is unnecessary since families never got implemented "NewXSTypeCoerceSubd", "NewXSExtractTransPDLs", "MakeCompiledReprSubd", "NewXSCoerceMustCompSubd", "NewXSRunTrans", "NewXSCopyBadStatusSubd", ], "Generate C function with idiomatic arg list to maybe call from XS", sub { my ($xs_c_header, @bits) = @_; my $opening = 'pdl_error PDL_err = {0, NULL, 0};'; my $closing = 'return PDL_err;'; PDL::PP::pp_line_numbers __LINE__-1, join '', "$xs_c_header {\n$opening\n", @bits, "$closing\n}\n"; }), # internal usage, not XS - NewXSCHdrs only set if GlobalNew PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"], ["NewXSHdr", "NewXSCHdrs", "RunFuncCall"], "Non-varargs XS code when GlobalNew given", sub {(undef,(make_xs_code('CODE:',' XSRETURN(0);',@_))[1..2])}), # if PMCode supplied, no var-args stuff PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"], ["PMCode","NewXSHdr", \"NewXSCHdrs", "RunFuncCall"], "Non-varargs XS code when PMCode given", sub {make_xs_code('CODE:',' XSRETURN(0);',@_[1..$#_])}), PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"], [qw(VarArgsXSHdr), \"NewXSCHdrs", qw(RunFuncCall VarArgsXSReturn)], "Rule to print out XS code when variable argument list XS processing is enabled", sub {make_xs_code('','',@_)}), PDL::PP::Rule::MakeComp->new("RedoDimsCodeNS", ["RedoDims", "PrivObj"], "PRIV"), PDL::PP::Rule::Substitute->new("RedoDimsCodeSubd", "RedoDimsCodeNS"), PDL::PP::Rule->new(make_vfn_args("RedoDims")), PDL::PP::Rule::MakeComp->new("ReadDataCodeNS", "ParsedCode", "FOO"), PDL::PP::Rule::Substitute->new("ReadDataCodeSubd", "ReadDataCodeNS"), PDL::PP::Rule::InsertName->new("ReadDataFuncName", 'pdl_${name}_readdata'), PDL::PP::Rule->new(make_vfn_args("ReadData")), PDL::PP::Rule::MakeComp->new("WriteBackDataCodeNS", "ParsedBackCode", "FOO"), PDL::PP::Rule::Substitute->new("WriteBackDataCodeSubd", "WriteBackDataCodeNS"), PDL::PP::Rule::InsertName->new("WriteBackDataFuncName", "BackCode", 'pdl_${name}_writebackdata'), PDL::PP::Rule::Returns::NULL->new("WriteBackDataFuncName", "Code"), PDL::PP::Rule->new(make_vfn_args("WriteBackData")), PDL::PP::Rule->new("FreeFuncName", ["FreeCodeSubd","Name"], sub {$_[0] ? "pdl_$_[1]_free" : 'NULL'}), PDL::PP::Rule->new(make_vfn_args("Free", ", char destroy")), PDL::PP::Rule::Returns::Zero->new("NoPthread"), # assume we can pthread, unless indicated otherwise PDL::PP::Rule->new("VTableDef", ["VTableName","ParamStructType","RedoDimsFuncName","ReadDataFuncName", "WriteBackDataFuncName","FreeFuncName", "SignatureObj","Affine_Ok","HaveThreading","NoPthread","Name", "GenericTypes","IsAffineFlag","TwoWayFlag","DefaultFlowFlag", "BadFlag"], sub { my($vname,$ptype,$rdname,$rfname,$wfname,$ffname, $sig,$affine_ok,$havethreading, $noPthreadFlag, $name, $gentypes, $affflag, $revflag, $flowflag, $badflag) = @_; my ($pnames, $pobjs) = ($sig->names_sorted, $sig->objs); my $nparents = 0 + grep {! $pobjs->{$_}->{FlagW}} @$pnames; my $aff = ($affine_ok ? "PDL_TPDL_VAFFINE_OK" : 0); my $npdls = scalar @$pnames; my $join_flags = join(", ",map {$pobjs->{$pnames->[$_]}->{FlagPhys} ? 0 : $aff} 0..$npdls-1) || '0'; my @op_flags; push @op_flags, 'PDL_TRANS_DO_THREAD' if $havethreading; push @op_flags, 'PDL_TRANS_BADPROCESS' if $badflag; push @op_flags, 'PDL_TRANS_BADIGNORE' if defined $badflag and !$badflag; push @op_flags, 'PDL_TRANS_NO_PARALLEL' if $noPthreadFlag; my $op_flags = join('|', @op_flags) || '0'; my $iflags = join('|', grep $_, $affflag, $revflag, $flowflag) || '0'; my $gentypes_txt = join(", ", (map PDL::Type->new($_)->sym, @$gentypes), '-1'); my @realdims = map 0+@{$_->{IndObjs}}, @$pobjs{@$pnames}; my $realdims = join(", ", @realdims) || '0'; my $parnames = join(",",map qq|"$_"|, @$pnames) || '""'; my $parflags = join(",\n ",map join('|', $_->cflags)||'0', @$pobjs{@$pnames}) || '0'; my $partypes = join(", ", map defined()?$_->sym:-1, map $_->{Type}, @$pobjs{@$pnames}) || '-1'; my $i = 0; my @starts = map { my $ci = $i; $i += $_; $ci } @realdims; my $realdim_ind_start = join(", ", @starts) || '0'; my @rd_inds = map $_->get_index, map @{$_->{IndObjs}}, @$pobjs{@$pnames}; my $realdim_inds = join(", ", @rd_inds) || '0'; my @indnames = $sig->ind_names_sorted; my $indnames = join(",", map qq|"$_"|, @indnames) || '""'; my $sizeof = $ptype ? "sizeof($ptype)" : '0'; PDL::PP::pp_line_numbers(__LINE__, <new('PMFunc', 'Name', 'Sets PMFunc to default symbol table manipulations', sub { my ($name) = @_; $::PDL_IFBEGINWRAP[0].'*'.$name.' = \&'.$::PDLOBJ. '::'.$name.";\n".$::PDL_IFBEGINWRAP[1] } ), ]; } 1; PDL-2.074/Basic/Gen/PP/0000755000175000017500000000000014200406301014132 5ustar osboxesosboxesPDL-2.074/Basic/Gen/PP/CType.pm0000644000175000017500000000700714165550106015535 0ustar osboxesosboxes# Represent any C type. # Type contains the size of arrays, which is either constant # or resolved (into an object) from resolveobj. package PDL::PP::CType; use strict; use warnings; use Carp; # new PDL::PP::CType(resolveobj,str) sub new { my $this = bless {},shift; $this->parsefrom(shift) if @_; return $this; } sub stripptrs { my($this,$str) = @_; if($str =~ s/^\s*(\w+)\s*$/$1/g) { $this->{ProtoName} = $str; return []; } # Now, recall the different C syntaxes. First priority is a pointer: return [["PTR"], @{$this->stripptrs($1)}] if $str =~ /^\s*\*(.*)$/; return $this->stripptrs($1) if $str =~ /^\s*\(.*\)\s*$/; # XXX Should try to see if a funccall. return [["ARR",$2], @{$this->stripptrs($1)}] if $str =~ /^(.*)\[([^]]*)\]\s*$/; Carp::confess("Invalid C type '$str'"); } # XXX Correct to *real* parsing. This is only a subset. sub parsefrom { my($this,$str) = @_; # First, take the words in the beginning $str =~ /^\s*((?:\w+\b\s*)+)([^[].*)$/; $this->{Base} = $1; $this->{Chain} = $this->stripptrs($2); } sub get_decl { my($this,$name,$opts) = @_; for(@{$this->{Chain}}) { my ($type, $arg) = @$_; if($type eq "PTR") {$name = "*$name"} elsif($type eq "ARR") { if($opts->{VarArrays2Ptrs}) { $name = "*$name"; } else { $name = "($name)[$arg]"; } } else { confess("Invalid decl @$_") } } return "$this->{Base} $name"; } # Useful when parsing argument decls sub protoname { return shift->{ProtoName} } sub get_copy { my($this,$from,$to) = @_; return "($to) = ($from);" if !@{$this->{Chain}}; # strdup loses portability :( return "($to) = malloc(strlen($from)+1); strcpy($to,$from);" if $this->{Base} =~ /^\s*char\s*$/; return "($to) = newSVsv($from);" if $this->{Base} =~ /^\s*SV\s*$/; my $code = $this->get_malloc($to,$from); return "($to) = ($from);" if !defined $code; # pointer my ($deref0,$deref1,$prev,$close) = ($from,$to); my $no = 0; for(@{$this->{Chain}}) { my ($type, $arg) = @$_; if($type eq "PTR") {confess("Cannot copy pointer, must be array");} elsif($type eq "ARR") { $no++; $arg = "$this->{ProtoName}_count" if $this->is_array; $prev .= PDL::PP::pp_line_numbers(__LINE__-1, " if(!$deref0) {$deref1=0;} else {int __malloc_ind_$no; for(__malloc_ind_$no = 0; __malloc_ind_$no < $arg; __malloc_ind_$no ++) {"); $deref0 = $deref0."[__malloc_ind_$no]"; $deref1 = $deref1."[__malloc_ind_$no]"; $close .= "}}"; } else { confess("Invalid decl @$_") } } $code .= "$prev $deref1 = $deref0; $close"; return $code; } sub get_free { my($this,$from) = @_; return "" if !@{$this->{Chain}} or $this->{Chain}[0][0] eq 'PTR'; return "free($from);" if $this->{Base} =~ /^\s*char\s*$/; return "SvREFCNT_dec($from);" if $this->{Base} =~ /^\s*SV\s*$/; croak("Can only free one layer!\n") if @{$this->{Chain}} > 1; "free($from);"; } sub need_malloc { my($this) = @_; grep /(ARR|PTR)/, map $_->[0], @{$this->{Chain}}; } # returns with the array string - undef if a pointer not needing malloc sub get_malloc { my($this,$assignto) = @_; my $str = ""; for(@{$this->{Chain}}) { my ($type, $arg) = @$_; if($type eq "PTR") {return} elsif($type eq "ARR") { $arg = "$this->{ProtoName}_count" if $this->is_array; $str .= PDL::PP::pp_line_numbers(__LINE__-1, "$assignto = malloc(sizeof(*$assignto) * $arg);\n"); } else { confess("Invalid decl (@$_)") } } return $str; } sub is_array { my ($self) = @_; @{$self->{Chain}} && @{$self->{Chain}[0]} && $self->{Chain}[0][0] eq 'ARR' && !$self->{Chain}[0][1]; } 1; PDL-2.074/Basic/Gen/PP/Signature.pm0000644000175000017500000001514714200157611016450 0ustar osboxesosboxespackage PDL::PP::Signature; use strict; use warnings; use PDL::PP::PdlParObj; use PDL::PP::Dims; use Carp; =head1 NAME PDL::PP::Signature - Internal module to handle signatures =head1 DESCRIPTION Internal module to handle signatures =head1 SYNOPSIS use PDL::PP::Signature; =cut # Eliminate whitespace entries sub nospacesplit {grep /\S/, split $_[0],$_[1]} sub new { my ($type,$str,$bvalflag,$otherpars) = @_; $bvalflag ||= 0; my $this = bless {}, $type; my @objects = map PDL::PP::PdlParObj->new($_,$bvalflag, $this), nospacesplit ';',$str; $this->{Names} = [ map $_->name, @objects ]; $this->{Objects} = { map +($_->name => $_), @objects }; my @objects_sorted = ((grep !$_->{FlagW}, @objects), (grep $_->{FlagW}, @objects)); $objects_sorted[$_]{Number} = $_ for 0..$#objects_sorted; $this->{NamesSorted} = [ map $_->name, @objects_sorted ]; $this->{DimsObj} = my $dimsobj = PDL::PP::PdlDimsObj->new; $_->add_inds($dimsobj) for @objects; my (%ind2use, %ind2obj); for my $o (@objects) { for my $io (@{$o->{IndObjs}}) { push @{$ind2use{$io->name}}, $o; $ind2obj{$io->name} = $io; } } $this->{Ind2Use} = \%ind2use; $this->{Ind2Obj} = \%ind2obj; $this->{IndNamesSorted} = [ sort keys %ind2use ]; my $i=0; my %ind2index = map +($_=>$i++), @{$this->{IndNamesSorted}}; $this->{Ind2Index} = \%ind2index; $ind2obj{$_}->set_index($ind2index{$_}) for sort keys %ind2index; @$this{qw(OtherNames OtherObjs)} = $this->_otherPars_nft($otherpars||''); $this; } sub _otherPars_nft { my ($sig,$otherpars) = @_; my $dimobjs = $sig && $sig->dims_obj; my(@names,%types,$type); # support 'int ndim => n;' syntax for (nospacesplit(';',$otherpars)) { if (/^\s*([^=]+)\s*=>\s*(\S+)\s*$/) { my ($ctype,$dim) = ($1,$2); $ctype =~ s/\s+$//; # get rid of trailing ws print "OtherPars: setting dim '$dim' from '$ctype'\n" if $::PP_VERBOSE; $type = PDL::PP::CType->new($ctype); croak "can't set unknown dimension '$dim' from '$otherpars'" unless defined($dimobjs->{$dim}); $dimobjs->{$dim}->set_from($type); } elsif(/^\s*\(\s*void\s*\)/) { # suppressing unused param warning - skip next; } else { $type = PDL::PP::CType->new($_); } my $name = $type->protoname; croak "Invalid OtherPars name: $name" if $PDL::PP::PdlParObj::INVALID_PAR{$name}; push @names,$name; $types{$name} = $type; } return (\@names,\%types); } *with = \&new; =head1 AUTHOR Copyright (C) Tuomas J. Lukka 1997 (lukka@husc.harvard.edu) and by Christian Soeller (c.soeller@auckland.ac.nz). 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 sub names { $_[0]{Names} } sub names_sorted { $_[0]{NamesSorted} } sub names_sorted_tuples { my ($count, @names) = (0, @{$_[0]{NamesSorted}}); map [$count++, $_[0]{Objects}{$_}{FlagTemp}, $_], @names; } sub objs { $_[0]{Objects} } sub names_in { my $o=$_[0]->objs; grep !$o->{$_}{FlagOut} && !$o->{$_}{FlagTemp}, @{$_[0]{Names}} } sub names_out { my $o=$_[0]->objs; grep $o->{$_}{FlagOut}, @{$_[0]{Names}} } sub names_oca { my $o=$_[0]->objs; grep $o->{$_}{FlagCreateAlways}, @{$_[0]{Names}} } sub names_out_nca { my $o=$_[0]->objs; grep $o->{$_}{FlagOut} && !$o->{$_}{FlagCreateAlways}, @{$_[0]{Names}} } sub names_tmp { my $o=$_[0]->objs; grep $o->{$_}{FlagTemp}, @{$_[0]{Names}} } sub dims_obj { $_[0]->{DimsObj} } sub dims_count { scalar keys %{$_[0]{DimsObj}} } sub dims_values { values %{$_[0]{DimsObj}} } sub ind_used { $_[0]{Ind2Use}{$_[1]} } sub ind_obj { $_[0]{Ind2Obj}{$_[1]} } sub ind_names_sorted { @{$_[0]{IndNamesSorted}} } sub ind_index { $_[0]{Ind2Index}{$_[1]} } sub othernames { my ($self, $for_xs) = @_; return $self->{OtherNames} if $for_xs; my $objs = $self->otherobjs($for_xs); my @raw_names = @{$self->{OtherNames}}; [ map $objs->{$_}->is_array ? ($_, "${_}_count") : $_, @raw_names ]; } sub otherobjs { my ($self, $for_xs) = @_; return $self->{OtherObjs} if $for_xs; my $objs = $self->{OtherObjs}; my @raw_names = @{$self->{OtherNames}}; +{ map $objs->{$_}->is_array ? ($_=>$objs->{$_}, "${_}_count"=>PDL::PP::CType->new("PDL_Indx ${_}_count")) : ($_=>$objs->{$_}), @raw_names }; } sub allnames { [(grep !$_[0]{Objects}{$_}{FlagTemp}, @{$_[0]{Names}}), @{$_[0]->othernames($_[1])}] } sub allobjs { my $pdltype = PDL::PP::CType->new("pdl *__foo__"); +{ ( map +($_,$pdltype), @{$_[0]{Names}} ), %{$_[0]->otherobjs($_[1])} }; } sub alldecls { my ($self, $long, $for_xs) = @_; return @{$self->allnames($for_xs)} if !$long; my $objs = $self->allobjs($for_xs); map $objs->{$_}->get_decl($_, {VarArrays2Ptrs=>1}), @{$self->allnames($for_xs)}; } sub getcomp { my ($self) = @_; my $objs = $self->otherobjs(0); join '', map "$_;", grep $_, map $objs->{$_}->get_decl($_, {VarArrays2Ptrs=>1}), @{$self->othernames(0)}; } sub getfree { my ($self,$symbol) = @_; my $objs = $self->otherobjs(0); join '', map $objs->{$_}->get_free("\$$symbol($_)", { VarArrays2Ptrs => 1 }), @{$self->othernames(0)}; } sub getcopy { my ($self) = @_; my $objs = $self->otherobjs(0); PDL::PP::pp_line_numbers(__LINE__, join '', map $objs->{$_}->get_copy($_,"\$COMP($_)"), @{$self->othernames(0)} ); } sub realdims { my $this = shift; [ map scalar @{$this->{Objects}{$_}{RawInds}}, @{$this->{Names}} ]; } sub creating { my $this = shift; croak "you must perform a checkdims before calling creating" unless defined $this->{Create}; return $this->{Create}; } sub checkdims { my $this = shift; # we have to recreate to keep defaults currently $this->{Dims} = PDL::PP::PdlDimsObj->new; $this->{Objects}{$_}->add_inds($this->{Dims}) for @{$this->{Names}}; my $n = @{$this->{Names}}; croak "not enough pdls to match signature" unless $#_ >= $n-1; my @pdls = @_[0..$n-1]; if ($PDL::debug) { print "args: ". join(' ,',map { "[".join(',',$_->dims)."]," } @pdls) . "\n"} my $i = 0; my @creating = map $this->{Objects}{$_}->perldimcheck($pdls[$i++]), @{$this->{Names}}; $i = 0; for (@{$this->{Names}}) { push @creating, $this->{Objects}{$_}->getcreatedims if $creating[$i++]; } $this->{Create} = \@creating; $i = 0; my $corr = 0; for (@{$this->{Names}}) { $corr = $this->{Objects}{$_}->finalcheck($pdls[$i++]); next unless $#$corr>-1; my ($j,$str) = (0,""); for (@$corr) {$str.= ":,"x($_->[0]-$j)."(0),*$_->[1],"; $j=$_->[0]+1 } chop $str; $_[$i-1] = $pdls[$i-1]->slice($str); } } 1; PDL-2.074/Basic/Gen/PP/Dims.pm0000644000175000017500000000335614165550026015411 0ustar osboxesosboxes############################################## package PDL::PP::PdlDimsObj; # Hold more dims use strict; use warnings; use Carp; sub new { my($type) = @_; bless {},$type; } sub get_indobj_make { my($this,$expr) = @_; $expr =~ /^([a-zA-Z0-9]+)(?:=([0-9]+))?$/ or confess "Invalid index expr '$expr'\n"; my $name = $1; my $val = $2; my $indobj; if(defined $this->{$name}) { $indobj = $this->{$name}; } else { $indobj = PDL::PP::Ind->new($name); $this->{$name}=$indobj; } if(defined $val) { $indobj->add_value($val); } return $indobj; } ##################################################################### # # Encapsulate one index. package PDL::PP::Ind; use Carp; sub new { my($type,$name) = @_; bless {Name => $name},$type; } # set the value of an index, also used by perl level threading sub add_value { my($this,$val) = @_; croak("index values for $this->{Name} must be positive") unless $val > 0; return $this->{Value} = $val if !defined $this->{Value} or $this->{Value} == -1 or $this->{Value} == 1; croak "For index $this->{Name} conflicting values $this->{Value} and $val given\n" if $val != 1 && $val != $this->{Value}; } # This index will take its size value from outside parameter ... sub set_from { my($this,$otherpar) = @_; $this->{From} = $otherpar; } sub name {$_[0]->{Name}} # where it occurs in the C arrays that track it (at least name and size) sub set_index { my ($this, $i) = @_; $this->{Index} = $i; } sub get_index {$_[0]->{Index}} sub get_initdim { my($this) = @_; my $init = $this->{Value} // ($this->{From} ? "\$COMP(".$this->{From}{ProtoName}.")" : undef); return if !defined $init; $this->get_size." = $init;" } sub get_size { my($this) = @_; "\$PRIV(ind_sizes)[@{[$this->get_index]}]" } 1; PDL-2.074/Basic/Gen/PP/dump.pp0000644000175000017500000000410714160015533015452 0ustar osboxesosboxes# These are suspended for now... # use blib; # For Types.pm # require './PP.pm'; open PP, "PP.pm" or die "can't open PP.pm"; $str = join '',; $str =~ m|\@PDL::PP::EXPORT\s*=\s*qw/([^/]*)/|s; $str = $1; # Get the contents of the qw// $pm = ' =head1 NAME PDL::PP::Dump -- dump pp_xxx calls to stdout =head1 SYNOPSIS perl -MPDL::PP::Dump Basic/Ops/ops.pd =head1 DESCRIPTION The most basic PP script debugger thinkable. =head1 AUTHOR Christian Soeller . =cut package PDL::PP::Dump; use Exporter; @ISA = Exporter; @EXPORT = qw('.$str.q|); my $typecheck =0; sub import { my ($pack,$arg) = @_; $typecheck =1 if defined $arg && $arg =~ /^typecheck$/i; @_ = ($pack); goto &Exporter::import; } sub printargs { my $name = shift; print "$name("; print join ',',map("'$_'",@_); print ");\n"; } for (@EXPORT) { if ($_ !~ /pp_def/) { my $def = "sub $_ { printargs($_,\@_) unless \$typecheck }"; # print "defining =>\n$def\n"; eval($def); } } sub pp_def { my($name,%hash) = @_; use PDL::Types ':All'; if ($typecheck) { my @alltypes = ppdefs_all; my $jointypes = join '',@alltypes; my $types = exists $hash{GenericTypes} ? $hash{GenericTypes} : [@alltypes]; for my $key (qw/Code BackCode/) { if (exists $hash{$key}) { while ($hash{$key} =~ s/\$T([a-zA-Z]+)\s*\(([^)]*)\)//) { my ($mactypes,$alternatives) = ($1,$2); # print "type macro ($mactypes) in $name\n"; my @mactypes = split '', $mactypes; print "$name has extra types in macro: $mactypes vs $jointypes\n" unless $mactypes =~ /^\s*[$jointypes]+\s*$/; for my $gt (@$types) { print "$name has no Macro for generic type $gt (has $mactypes)" unless grep {$gt eq $_} @mactypes; } } } } } else { print "pp_def('$name',\n"; foreach (sort keys(%hash)) { if ($_ =~ /(Generic)*Types/) { print "$_ => [" . join(',',@{$hash{$_}}) . "]\n"; } else { print "$_ =>\n'".$hash{$_}."',\n"; } } print ");\n"; } } 1; |; print $pm; PDL-2.074/Basic/Gen/PP/PdlParObj.pm0000644000175000017500000002002614160015533016315 0ustar osboxesosboxespackage PDL::PP::PdlParObj; use strict; use warnings; use Carp; use PDL::Types ':All'; our %INVALID_PAR = map +($_=>1), qw( I ); # split regex $re separated arglist # but ignore bracket-protected bits # (i.e. text that is within matched brackets) my $prebrackreg = qr/^([^\(\{\[]*)/; sub splitprotected ($$) { require Text::Balanced; my ($re,$txt) = @_; return () if !defined $txt || $txt =~ /^\s*$/; my ($got,$pre) = (1,''); my @chunks = (''); my $ct = 0; # infinite loop protection while ($got && $txt =~ /[({\[]/ && $ct++ < 1000) { # print "iteration $ct\n"; ($got,$txt,$pre) = Text::Balanced::extract_bracketed($txt,'{}()[]',$prebrackreg); my @partialargs = split $re, $pre, -1; $chunks[-1] .= shift @partialargs if @partialargs; push @chunks, @partialargs; $chunks[-1] .= $got; } confess "possible infinite parse loop, splitting '$txt' " if $ct >= 1000; my @partialargs = split $re, $txt, -1; $chunks[-1] .= shift @partialargs if @partialargs; push @chunks, @partialargs if @partialargs; # print STDERR "args found: $#chunks\n"; # print STDERR "splitprotected $txt on $re: [",join('|',@chunks),"]\n"; return @chunks; } my $typeregex = join '|', map $_->ppforcetype, types; my $complex_regex = join '|', qw(real complex); our $pars_re = qr/^ \s*(?:($complex_regex|$typeregex)\b([+]*)|)\s* # $1,2: first option then plus (?: \[([^]]*)\] # $3: The initial [option] part )?\s* (\w+) # $4: The name \(([^)]*)\) # $5: The indices /x; my %flag2info = ( io => [[qw(FlagW)]], nc => [[qw(FlagNCreat)]], o => [[qw(FlagOut FlagCreat FlagW)]], oca => [[qw(FlagOut FlagCreat FlagW FlagCreateAlways)]], t => [[qw(FlagTemp FlagCreat FlagW)]], phys => [[qw(FlagPhys)]], real => [[qw(FlagReal)]], complex => [[qw(FlagComplex)]], (map +($_->ppforcetype => [[qw(FlagTyped)], 'Type']), types), ); my %flag2c = qw( FlagReal PDL_PARAM_ISREAL FlagComplex PDL_PARAM_ISCOMPLEX FlagTyped PDL_PARAM_ISTYPED FlagTplus PDL_PARAM_ISTPLUS FlagCreat PDL_PARAM_ISCREAT FlagCreateAlways PDL_PARAM_ISCREATEALWAYS FlagOut PDL_PARAM_ISOUT FlagTemp PDL_PARAM_ISTEMP FlagW PDL_PARAM_ISWRITE FlagPhys PDL_PARAM_ISPHYS FlagIgnore PDL_PARAM_ISIGNORE ); sub new { my($type,$string,$badflag,$sig) = @_; $badflag ||= 0; my $this = bless {Number => "PDL_UNDEF_NUMBER", BadFlag => $badflag, Sig => $sig},$type; # Parse the parameter string. Note that the regexes for this match were # originally defined here, but were moved to PDL::PP for FullDoc parsing. $string =~ $pars_re or confess "Invalid pdl def $string (regex $pars_re)\n"; my($opt1,$opt_plus,$opt2,$name,$inds) = map $_ // '', ($1,$2,$3,$4,$5); print "PDL: '$opt1$opt_plus', '$opt2', '$name', '$inds'\n" if $::PP_VERBOSE; croak "Invalid Pars name: $name" if $INVALID_PAR{$name}; # Set my internal variables $this->{Name} = $name; $this->{Flags} = [(split ',',$opt2),($opt1?$opt1:())]; for(@{$this->{Flags}}) { confess("Invalid flag $_ given for $string\n") unless my ($set, $store) = @{ $flag2info{$_} || [] }; $this->{$store} = $_ if $store; $this->{$_} = 1 for @$set; } if ($this->{FlagTyped} && $opt_plus) { $this->{FlagTplus} = 1; } $this->{Type} &&= PDL::Type->new($this->{Type}); if($this->{FlagNCreat}) { delete $this->{FlagCreat}; delete $this->{FlagCreateAlways}; } $this->{RawInds} = [map{ s/\s//g; # Remove spaces $_; } split ',', $inds]; return $this; } sub cflags { my ($this) = @_; map $flag2c{$_}, grep $this->{$_}, sort keys %flag2c; } sub name {return (shift)->{Name}} sub add_inds { my($this,$dimsobj) = @_; $this->{IndObjs} = [map {$dimsobj->get_indobj_make($_)} @{$this->{RawInds}}]; my %indcount; $this->{IndCounts} = [ map { 0+($indcount{$_->name}++); } @{$this->{IndObjs}} ]; $this->{IndTotCounts} = [ map { ($indcount{$_->name}); } @{$this->{IndObjs}} ]; } # do the dimension checking for perl level threading # assumes that IndObjs have been created sub perldimcheck { my ($this,$pdl) = @_; croak ("can't create ".$this->name) if $pdl->isnull && !$this->{FlagCreat}; return 1 if $pdl->isnull; my $rdims = @{$this->{RawInds}}; croak ("not enough dimensions for ".$this->name) if ($pdl->threadids)[0] < $rdims; my @dims = $pdl->dims; my ($i,$ind) = (0,undef); for $ind (@{$this->{IndObjs}}) { $ind->add_value($dims[$i++]); } return 0; # not creating } sub finalcheck { my ($this,$pdl) = @_; return [] if $pdl->isnull; my @corr = (); my @dims = $pdl->dims; my ($i,$ind) = (0,undef); for $ind (@{$this->{IndObjs}}) { push @corr,[$i-1,$ind->{Value},$dims[$i-1]] if $dims[$i++] != $ind->{Value}; } return [@corr]; } # get index sizes for a parameter that has to be created sub getcreatedims { my $this = shift; return map { croak "can't create: index size ".$_->name." not initialised" if !defined($_->{Value}) || $_->{Value} < 1; $_->{Value} } @{$this->{IndObjs}}; } sub adjusted_type { my ($this, $generic) = @_; confess "adjusted_type given undefined generic type\n" if !defined $generic; return $generic->realversion if $this->{FlagReal}; return $generic->complexversion if $this->{FlagComplex}; return $generic unless $this->{FlagTyped}; return $this->{Type}->numval > $generic->numval ? $this->{Type} : $generic if $this->{FlagTplus}; $this->{Type}; } sub get_nname{ my($this) = @_; "(\$PRIV(pdls[$this->{Number}]))"; } sub get_nnflag { my($this) = @_; "(\$PRIV(vtable->per_pdl_flags[$this->{Number}]))"; } sub get_incname { my($this,$ind,$for_local) = @_; return "inc_sizes[PDL_INC_ID(__privtrans->vtable,$this->{Number},$ind)]" if !$for_local; if($this->{IndTotCounts}[$ind] > 1) { "__inc_".$this->{Name}."_".($this->{IndObjs}[$ind]->name).$this->{IndCounts}[$ind]; } else { "__inc_".$this->{Name}."_".($this->{IndObjs}[$ind]->name); } } sub get_incregisters { my($this) = @_; if(scalar(@{$this->{IndObjs}}) == 0) {return "";} (join '',map { my $x = $_; my ($name, $for_local) = map $this->get_incname($x, $_), 0, 1; "register PDL_Indx $for_local = __privtrans->$name; (void)$for_local;\n"; } (0..$#{$this->{IndObjs}}) ) } # Print an access part. sub do_access { my($this,$inds,$context) = @_; my $pdl = $this->{Name}; # Parse substitutions into hash my %subst = map {/^\s*(\w+)\s*=>\s*(\S*)\s*$/ or confess "Invalid subst $_\n"; ($1,$2)} splitprotected ',',$inds; # Generate the text my $text; $text = "(${pdl}_datap)"."["; $text .= join '+','0',map { $this->do_indterm($pdl,$_,\%subst,$context); } (0..$#{$this->{IndObjs}}); $text .= "]"; # If not all substitutions made, the user probably made a spelling # error. Barf. if(scalar(keys %subst) != 0) { confess("Substitutions left: ".(join ',',sort keys %subst)."\n"); } $text; } sub do_pdlaccess { my($this) = @_; PDL::PP::pp_line_numbers(__LINE__-1, '$PRIV(pdls['.$this->{Number}.'])'); } sub do_pointeraccess { my($this) = @_; return $this->{Name}."_datap"; } sub do_physpointeraccess { my($this) = @_; return $this->{Name}."_physdatap"; } sub do_indterm { my($this,$pdl,$ind,$subst,$context) = @_; # Get informed my $indname = $this->{IndObjs}[$ind]->name; my $indno = $this->{IndCounts}[$ind]; my $indtot = $this->{IndTotCounts}[$ind]; # See if substitutions my $substname = ($indtot>1 ? $indname.$indno : $indname); my $incname = $indname.($indtot>1 ? $indno : ""); my $index; if(defined $subst->{$substname}) {$index = delete $subst->{$substname};} else { # No => get the one from the nearest context. for(reverse @$context) { if($_->[0] eq $indname) {$index = $_->[1]; last;} } } if(!defined $index) {confess "Access Index not found: $pdl, $ind, $indname On stack:".(join ' ',map {"($_->[0],$_->[1])"} @$context)."\n" ;} return "(".($this->get_incname($ind,1))."*". "PP_INDTERM(".$this->{IndObjs}[$ind]->get_size().", $index))"; } sub get_xsdatapdecl { my($this,$ctype) = @_; my $pdl = $this->get_nname; my $flag = $this->get_nnflag; my $name = $this->{Name}; my $macro = "PDL_DECLARE_PARAMETER".($this->{BadFlag} ? "_BADVAL" : ""); "$macro($ctype, $flag, $name, $pdl)"; } 1; PDL-2.074/Basic/Gen/PP/PDLCode.pm0000644000175000017500000005423314200051241015710 0ustar osboxesosboxes# This file provides a class that parses the Code -member # of the PDL::PP code. # # This is what makes the nice loops go around etc. # package PDL::PP::Code; use strict; use warnings; use Carp; sub get_pdls {my($this) = @_; return ($this->{ParNames},$this->{ParObjs});} my @code_args_always = qw(BadFlag SignatureObj GenericTypes ExtraGenericSwitches HaveThreading Name); sub make_args { my ($which) = @_; ("Parsed$which", [$which,\"Bad$which",@code_args_always]); } # Do the appropriate substitutions in the code. sub new { my($class,$code,$badcode, $handlebad, $sig,$generictypes,$extrageneric,$havethreading,$name, $dont_add_thrloop, $backcode ) = @_; my $parnames = $sig->names_sorted; die "Error: missing name argument to PDL::PP::Code->new call!\n" unless defined $name; confess "Error: empty or undefined GenericTypes!\n" unless @{$generictypes || []}; $badcode //= $code if $handlebad; # last two arguments may not be supplied # # "backcode" is a flag to the PDL::PP::Threadloop class indicating thre threadloop # is for writeback code (typically used for writeback of data from child to parent PDL $dont_add_thrloop ||= !$havethreading; # two have identical (though inverted) meaning so only track one # C++ style comments # # This regexp isn't perfect because it doesn't cope with # literal string constants. # $code =~ s,//.*?\n,,g; if ($::PP_VERBOSE) { print "Processing code for $name\n"; print "DONT_ADD_THRLOOP!\n" if $dont_add_thrloop; print "EXTRAGEN: {" . join(" ", map "$_=>$$extrageneric{$_}", sort keys %$extrageneric) . "}\n"; print "ParNAMES: ",(join ',',@$parnames),"\n"; print "GENTYPES: ", @$generictypes, "\n"; print "HandleBad: $handlebad\n"; } my $this = bless { IndObjs => $sig->dims_obj, ParNames => $parnames, ParObjs => $sig->objs, Sig => $sig, Gencurtype => [], # stack to hold GenType in generic loops ftypes_vars => {}, ftypes_type => undef, Generictypes => $generictypes, # so that MacroAccess can check it Name => $name, }, $class; # First, separate the code into an array of C fragments (strings), # variable references (strings starting with $) and # loops (array references, 1. item = variable. # my ( $threadloops, $coderef, $sizeprivs ) = $this->separate_code( "{\n$code\n}" ); # Now, if there is no explicit threadlooping in the code, # enclose everything into it. if(!$threadloops && !$dont_add_thrloop) { print "Adding threadloop...\n" if $::PP_VERBOSE; my $nc = $coderef; $coderef = $backcode ? PDL::PP::BackCodeThreadLoop->new() : PDL::PP::ThreadLoop->new(); push @{$coderef},$nc; } # repeat for the bad code, then stick good and bad into # a BadSwitch object which creates the necessary # 'if (bad) { badcode } else { goodcode }' code # # NOTE: amalgamate sizeprivs from good and bad code # if ( $handlebad && ($code ne $badcode || $badcode =~ /PDL_BAD_CODE|PDL_IF_BAD/) ) { print "Processing 'bad' code...\n" if $::PP_VERBOSE; my ( $bad_threadloops, $bad_coderef, $bad_sizeprivs ) = $this->separate_code( "{\n$badcode\n}" ); if(!$bad_threadloops && !$dont_add_thrloop) { print "Adding 'bad' threadloop...\n" if $::PP_VERBOSE; my $nc = $bad_coderef; if( !$backcode ){ # Normal readbackdata threadloop $bad_coderef = PDL::PP::ThreadLoop->new(); } else{ # writebackcode threadloop $bad_coderef = PDL::PP::BackCodeThreadLoop->new(); } push @{$bad_coderef},$nc; } my $good_coderef = $coderef; $coderef = PDL::PP::BadSwitch->new( $good_coderef, $bad_coderef ); # amalgamate sizeprivs from Code/BadCode segments # (sizeprivs is a simple hash, with each element # containing a string - see PDL::PP::Loop) while ( my ( $bad_key, $bad_str ) = each %$bad_sizeprivs ) { my $str = $$sizeprivs{$bad_key}; die "ERROR: sizeprivs problem in PP/PDLCode.pm (BadVal stuff)\n" if defined $str and $str ne $bad_str; $$sizeprivs{$bad_key} = $bad_str; # copy over } } # if: $handlebad print "SIZEPRIVSX: ",(join ',',%$sizeprivs),"\n" if $::PP_VERBOSE; # Enclose it all in a genericloop. my $nc = $coderef; $coderef = PDL::PP::GenericSwitch->new($generictypes, undef, [grep {!$extrageneric->{$_}} @$parnames],'$PRIV(__datatype)'); push @{$coderef},$nc; # Do we have extra generic loops? # If we do, first reverse the hash: my %glh; for(sort keys %$extrageneric) { push @{$glh{$extrageneric->{$_}}},$_; } my $no = 0; for(sort keys %glh) { my $nc = $coderef; $coderef = PDL::PP::GenericSwitch->new($generictypes,$no++, $glh{$_},$_); push @$coderef,$nc; } my $pobjs = $sig->objs; # Then, in this form, put it together what we want the code to actually do. print "SIZEPRIVS: ",(join ',',%$sizeprivs),"\n" if $::PP_VERBOSE; $this->{Code} = (join '',sort values %$sizeprivs). ($dont_add_thrloop?'':PDL::PP::pp_line_numbers __LINE__, join "\n", 'PDL_COMMENT("threadloop declarations")', 'int __thrloopval;', 'register PDL_Indx __tind0,__tind1; PDL_COMMENT("counters along dim")', 'register PDL_Indx __tnpdls = $PRIV(pdlthread).npdls;', 'PDL_COMMENT("dims here are how many steps along those dims")', (map "register PDL_Indx __tinc0_$parnames->[$_] = PDL_THR_INC(\$PRIV(pdlthread).incs,__tnpdls,$_,0);", 0..$#$parnames), (map "register PDL_Indx __tinc1_$parnames->[$_] = PDL_THR_INC(\$PRIV(pdlthread).incs,__tnpdls,$_,1);", 0..$#$parnames), ). $this->params_declare. join('',map $_->get_incregisters, @$pobjs{sort keys %$pobjs}). $coderef->get_str($this,[]) ; $this->{Code}; } # new() sub params_declare { my ($this) = @_; my ($ord,$pdls) = $this->get_pdls; my @decls = map $_->get_xsdatapdecl("PDL_PARAMTYPE_".$_->name), map $pdls->{$_}, @$ord; my @param_names = map "PDL_PARAMTYPE_$_", @$ord; PDL::PP::pp_line_numbers(__LINE__, <{Name}(@{[join ',', @param_names]}) \\ @{[join " \\\n", @decls]} EOF } sub func_name { $_[1] ? "writebackdata" : "readdata" } sub threadloop_start { my ($this, $funcname) = @_; my ($ord,$pdls) = $this->get_pdls; <{$ord->[$_]}->do_pointeraccess." += __offsp[$_];\n", 0..$#$ord ]}, (@{[ join "", map "\t,".$pdls->{$ord->[$_]}->do_pointeraccess." += __tinc1_$ord->[$_] - __tinc0_$ord->[$_] * __tdims0\n", 0..$#$ord ]}), (@{[ join "", map "\t,".$pdls->{$ord->[$_]}->do_pointeraccess." += __tinc0_$ord->[$_]\n", 0..$#{$ord} ]}) ) EOF } sub threadloop_end { my ($this) = @_; my ($ord,$pdls) = $this->get_pdls(); <{$ord->[$_]}->do_pointeraccess." -= __tinc1_$ord->[$_] * __tdims1 + __offsp[$_];\n", 0..$#$ord ]} ) EOF } sub sig {$_[0]->{Sig}} # This sub determines the index name for this index. # For example, a(x,y) and x0 becomes [x,x0] sub make_loopind { my($this,$ind) = @_; my $orig = $ind; while(!$this->{IndObjs}{$ind}) { if(!((chop $ind) =~ /[0-9]/)) { confess("Index not found for $_ ($ind)!\n"); } } return [$ind,$orig]; } my %access2class = ( GENERIC => 'PDL::PP::GentypeAccess', PPSYM => 'PDL::PP::PpsymAccess', ); sub process { my ($this, $code, $stack_ref, $threadloops_ref, $sizeprivs) = @_; while($code) { # Parse next statement $code =~ s/^(.*?) # First, some noise is allowed. This may be bad. ( \$(ISBAD|ISGOOD|SETBAD)\s*\(\s*\$?[a-zA-Z_]\w*\s*\([^)]*\)\s*\) # $ISBAD($a(..)), ditto for ISGOOD and SETBAD |\$[a-zA-Z_]\w*\s*\([^)]*\) # $a(...): access |\bloop\s*\([^)]+\)\s*%\{ # loop(..) %{ |\btypes\s*\([^)]+\)\s*%\{ # types(..) %{ |\bthreadloop\s*%\{ # threadloop %{ |%} # %} |$)//xs or confess("Invalid program $code"); my $control = $2; # Store the user code. # Some day we shall parse everything. push @{$stack_ref->[-1]},$1; # Then, our control. if (!$control) { print("No \$2!\n") if $::PP_VERBOSE; next; } if($control =~ /^loop\s*\(([^)]+)\)\s*%\{/) { my $ob = PDL::PP::Loop->new([split ',',$1], $sizeprivs,$this); print "SIZEPRIVSXX: $sizeprivs,",(join ',',%$sizeprivs),"\n" if $::PP_VERBOSE; push @{$stack_ref->[-1]},$ob; push @$stack_ref,$ob; } elsif($control =~ /^types\s*\(([^)]+)\)\s*%\{/) { my $ob = PDL::PP::Types->new($1,$this); push @{$stack_ref->[-1]},$ob; push @$stack_ref,$ob; } elsif($control =~ /^threadloop\s*%\{/) { my $ob = PDL::PP::ThreadLoop->new; push @{$stack_ref->[-1]},$ob; push @$stack_ref,$ob; $$threadloops_ref++; } elsif($control =~ /^%}/) { pop @$stack_ref; } else { my ($rest, @add) = $this->expand($control.$code); push @{$stack_ref->[-1]}, @add; $code = $rest; } } # while: $code } # my ( $threadloops, $coderef, $sizeprivs ) = $this->separate_code( $code ); # # separates the code into an array of C fragments (strings), # variable references (strings starting with $) and # loops (array references, 1. item = variable. # sub separate_code { my ( $this, $code ) = @_; # First check for standard code errors: catch_code_errors($code); my @stack = my $coderef = PDL::PP::Block->new; my $threadloops = 0; my $sizeprivs = {}; $this->process($code, \@stack, \$threadloops, $sizeprivs); ( $threadloops, $coderef, $sizeprivs ); } # sub: separate_code() sub expand { my ($this, $text) = @_; my (undef, $pdl, $inds, $rest) = PDL::PP::Rule::Substitute::macro_extract($text); my @add; if($pdl =~ /^T/) {@add = PDL::PP::MacroAccess->new($pdl,$inds, $this->{Generictypes},$this->{Name});} elsif(my $c = $access2class{$pdl}) {@add = $c->new($pdl,$inds)} elsif($pdl =~ /^(PP|)(ISBAD|ISGOOD|SETBAD)(VAR|)$/) { my ($opcode, $name) = ($2); my $get = $1 || $3; if (!$get) { $inds =~ s/^\$?([a-zA-Z_]\w*)\s*//; # $ is optional $name = $1; $inds = substr $inds, 1, -1; # chop off brackets } elsif ($get eq 'PP') { ($name, $inds) = split /\s*,\s*/, $inds; } else { ($inds, $name) = $inds =~ /(.*)\s*,\s*(\w+)/; } @add = PDL::PP::BadAccess->new($opcode,$get,$name,$inds,$this); } elsif($this->{ParObjs}{$pdl}) {@add = PDL::PP::Access->new($pdl,$inds)} else { @add = "\$$pdl("; # assumption: the only "control" that will happen in macro args is another macro $this->process($inds, [\@add], undef, undef); push @add, ")"; } ($rest, @add); } # This is essentially a collection of regexes that look for standard code # errors and croaks with an explanation if they are found. sub catch_code_errors { my $code_string = shift; # Look for constructs like # loop %{ # which is invalid - you need to specify the dimension over which it # should loop report_error('Expected dimension name after "loop" and before "%{"', $1) if $code_string =~ /(.*\bloop\s*%\{)/s; } # Report an error as precisely as possible. If they have #line directives # in the code string, use that in the reporting; otherwise, use standard # Carp mechanisms my $line_re = qr/#\s*line\s+(\d+)\s+"([^"]*)"/; sub report_error { my ($message, $code) = @_; # Just croak if they didn't supply a #line directive: confess($message) if $code !~ $line_re; # Find the line at which the error occurred: my $line = 0; my $filename; LINE: foreach (split /\n/, $code) { $line++; if (/$line_re/) { $line = $1; $filename = $2; } } die "$message at $filename line $line\n"; } ##################################################################### # # Encapsulate the parsing code objects # # All objects have two methods: # new - constructor # get_str - get the string to be put into the xsub. package PDL::PP::Block; sub new { my($type) = @_; bless [],$type; } sub myoffs { 0 } sub myprelude {} sub mypostlude {} sub get_str { my ($this,$parent,$context) = @_; my $str = $this->myprelude($parent,$context); $str .= $this->get_str_int($parent,$context)//''; $str .= $this->mypostlude($parent,$context)//''; return $str; } sub get_str_int { my ( $this, $parent, $context ) = @_; my $nth=0; my $str = ""; MYLOOP: while(1) { my $it = $this->can('myitemstart') && $this->myitemstart($parent,$nth); last MYLOOP if $nth and !$it; $str .= $it//''; $str .= join '', $this->get_contained($parent,$context); $str .= $it if $it = $this->can('myitemend') && $this->myitemend($parent,$nth); $nth++; } return $str; } # get_str_int() sub get_contained { my ($this, $parent, $context) = @_; map ref($_) ? $_->get_str($parent, $context) : $_, @$this[$this->myoffs..$#$this]; } ########################### # # Deal with bad code # - ie create something like # if ( badflag ) { badcode } else { goodcode } # package PDL::PP::BadSwitch; our @ISA = "PDL::PP::Block"; sub new { my($type,$good,$bad) = @_; return bless [$good,$bad], $type; } sub get_str { my ($this,$parent,$context) = @_; my $good = $this->[0]; my $bad = $this->[1]; my $str = PDL::PP::pp_line_numbers(__LINE__, <get_str($parent,$context) ]} #undef PDL_BAD_CODE #undef PDL_IF_BAD } else { PDL_COMMENT("** else do 'good' Code **") #define PDL_IF_BAD(t,f) f @{[ $good->get_str($parent,$context) ]} #undef PDL_IF_BAD } EOF } package PDL::PP::Loop; our @ISA = "PDL::PP::Block"; sub new { my($type,$args,$sizeprivs,$parent) = @_; my $this = bless [$args],$type; for(@{$this->[0]}) { print "SIZP $sizeprivs, $_\n" if $::PP_VERBOSE; my $i = $parent->make_loopind($_); my $i_size = $parent->sig->ind_obj($i->[0])->get_size; $sizeprivs->{$i->[0]} = "register PDL_Indx __$i->[0]_size = $i_size;\n"; print "SP :",(join ',',%$sizeprivs),"\n" if $::PP_VERBOSE; } return $this; } sub myoffs { return 1; } sub myprelude { my($this,$parent,$context) = @_; my $text = ""; push @$context, map { my $i = $parent->make_loopind($_); # Used to be $PRIV(.._size) but now we have it in a register. $text .= PDL::PP::pp_line_numbers(__LINE__, <[0]_size); $_++) { EOF $i; } @{$this->[0]}; $text; } sub mypostlude { my($this,$parent,$context) = @_; splice @$context, - ($#{$this->[0]}+1); return join '', map PDL::PP::pp_line_numbers(__LINE__-1, "}} PDL_COMMENT(\"Close $_\")"), @{$this->[0]}; } package PDL::PP::GenericSwitch; our @ISA = "PDL::PP::Block"; # make the typetable from info in PDL::Types use PDL::Types ':All'; my @typetable = map [$_->ppsym, $_], types(); sub get_generictyperecs { my($types) = @_; my %wanted; @wanted{@$types} = (); [ map $_->[1], grep exists $wanted{$_->[0]}, @typetable ]; } # Types: BSULFD sub new { my ($type,$types,$name,$varnames,$whattype) = @_; my %vars; @vars{@$varnames} = (); bless [get_generictyperecs($types), $name, \%vars, $whattype], $type; } sub myoffs {4} sub myprelude { my ($this,$parent,$context) = @_; push @{$parent->{Gencurtype}}, undef; # so that $GENERIC can get at it die "ERROR: need to rethink NaN support in GenericSwitch\n" if defined $this->[1] and $parent->{ftypes_type}; qq[PDL_COMMENT("Start generic loop")\n\tswitch($this->[3]) {\n]; } my @GENTYPE_ATTRS = qw(integer real unsigned); sub myitemstart { my ($this,$parent,$nth) = @_; my $item = $this->[0][$nth] || return ""; $parent->{Gencurtype}[-1] = $item; @$parent{qw(ftypes_type ftypes_vars)} = ($item, $this->[2]) if defined $this->[1]; my ($ord,$pdls) = $parent->get_pdls; my @param_ctypes = map $pdls->{$_}->adjusted_type($item)->ctype, @$ord; my $decls = keys %{$this->[2]} == @$ord ? PDL::PP::pp_line_numbers(__LINE__-1, "\t\tPDL_DECLARE_PARAMS_$parent->{Name}(@{[join ',', @param_ctypes]})\n") : join '', map $_->get_xsdatapdecl($_->adjusted_type($item)->ctype), map $parent->{ParObjs}{$_}, sort keys %{$this->[2]}; my @gentype_decls = map "#define PDL_IF_GENTYPE_".uc($_)."(t,f) ". ($item->$_ ? 't' : 'f')."\n", @GENTYPE_ATTRS; join '', PDL::PP::pp_line_numbers(__LINE__-1, "case @{[$item->sym]}: {\n"), @gentype_decls, $decls; } sub myitemend { my ($this,$parent,$nth) = @_; my $item = $this->[0][$nth] || return ""; join '', "\n", (map "#undef PDL_IF_GENTYPE_".uc($_)."\n", @GENTYPE_ATTRS), PDL::PP::pp_line_numbers(__LINE__-1, "} break;\n"); } sub mypostlude { my($this,$parent,$context) = @_; pop @{$parent->{Gencurtype}}; # and clean up the Gentype stack $parent->{ftypes_type} = undef if defined $this->[1]; my $supported = join '', map $_->ppsym, @{$this->[0]}; "\n\tdefault:return PDL->make_error(PDL_EUSERERROR, \"PP INTERNAL ERROR in $parent->{Name}: unhandled datatype(%d), only handles ($supported)! PLEASE MAKE A BUG REPORT\\n\", $this->[3]);}\n"; } #### # # This relies on PP.pm making sure that initthreadstruct always sets # up the two first dimensions even when they are not necessary. # package PDL::PP::ThreadLoop; use Carp; our @ISA = "PDL::PP::Block"; sub new { my $type = shift; bless [],$type; } sub myoffs { return 0; } sub myprelude { my($this,$parent,$context, $backcode) = @_; $parent->threadloop_start($parent->func_name($backcode)); } # Should possibly fold out thread.dims[0] and [1]. sub mypostlude {my($this,$parent,$context) = @_; $parent->threadloop_end; } # Simple subclass of ThreadLoop to implement writeback code # # package PDL::PP::BackCodeThreadLoop; use Carp; our @ISA = "PDL::PP::ThreadLoop"; sub myprelude { my($this,$parent,$context, $backcode) = @_; # Set backcode flag if not defined. This will make the parent # myprelude emit proper writeback code $backcode = 1 unless defined($backcode); $this->SUPER::myprelude($parent, $context, $backcode); } ########################### # # Encapsulate a types() switch # package PDL::PP::Types; use Carp; use PDL::Types ':All'; our @ISA = "PDL::PP::Block"; my %types = map +($_=>1), ppdefs_all; # BSUL.... sub new { my($type,$ts,$parent) = @_; my @bad = grep !$types{$_}, my @ts = split '', $ts; confess "Invalid type access (@bad) in '$ts'!" if @bad; bless [+{map +($_=>1), @ts}],$type; } sub myoffs { return 1; } sub get_str { my ($this,$parent,$context) = @_; confess "types() outside a generic loop" unless defined(my $type = $parent->{Gencurtype}[-1]); return '' if !$this->[0]{$type->ppsym}; join '', $this->get_contained($parent,$context); } package PDL::PP::Access; use Carp; sub new { my($type,$pdl,$inds,$parent) = @_; bless [$pdl,$inds],$type; } sub get_str { my($this,$parent,$context) = @_; $parent->{ParObjs}{$this->[0]}->do_access($this->[1],$context) if defined($parent->{ParObjs}{$this->[0]}); } ########################### # Encapsulate a check on whether a value is good or bad # handles both checking (good/bad) and setting (bad) package PDL::PP::BadAccess; use Carp; sub new { my ( $type, $opcode, $get, $name, $inds, $parent ) = @_; die "\nIt looks like you have tried a \$${opcode}() macro on an\n" . " unknown ndarray <$name($inds)>\n" unless defined($parent->{ParObjs}{$name}); bless [$opcode, $get, $name, $inds], $type; } sub _isbad { "PDL_ISBAD($_[0],$_[1],$_[2])" } our %ops = ( ISBAD => \&_isbad, ISGOOD => sub {'!'.&_isbad}, SETBAD => sub{join '=', @_[0,1]}, ); my %getters = ( '' => sub {my ($obj, $inds, $context)=@_; $obj->do_access($inds,$context)}, PP => sub {my ($obj, $inds)=@_; $obj->do_physpointeraccess.$inds}, VAR => sub {my ($obj, $inds)=@_; $inds}, ); sub get_str { my ($this,$parent,$context) = @_; my ($opcode, $get, $name, $inds) = @$this; confess "generic type access outside a generic loop in $name" unless defined $parent->{Gencurtype}[-1]; print "PDL::PP::BadAccess sent [$opcode] [$name] [$inds]\n" if $::PP_VERBOSE; die "ERROR: unknown check <$opcode> sent to PDL::PP::BadAccess\n" unless defined( my $op = $ops{$opcode} ); die "ERROR: something screwy in PDL::PP::BadAccess (PP/PDLCode.pm)\n" unless defined( my $obj = $parent->{ParObjs}{$name} ); my $lhs = $getters{$get}->($obj, $inds, $context); my $rhs = "${name}_badval"; print "DBG: [$lhs $op $rhs]\n" if $::PP_VERBOSE; my $type = exists $parent->{ftypes_vars}{$name} ? $parent->{ftypes_type} : $obj->adjusted_type($parent->{Gencurtype}[-1]); $op->($lhs, $rhs, $type->ppsym); } package PDL::PP::MacroAccess; use Carp; use PDL::Types ':All'; my $types = join '',ppdefs_all; sub new { my ($type, $pdl, $inds, $gentypes, $name) = @_; $pdl =~ /^\s*T([A-Z]+)\s*$/ or confess("Macroaccess wrong in $name (allowed types $types): was '$pdl'\n"); my @ilst = split '', $1; my @lst = split ',', $inds, -1; confess "Macroaccess: different nos of args $pdl $inds\n" if @lst != @ilst; my %type2value; @type2value{@ilst} = @lst; confess "$name has no Macro for generic type $_ (has $pdl)\n" for grep !exists $type2value{$_}, @$gentypes; my %gts; @gts{@$gentypes} = (); warn "Macro for unsupported generic type identifier $_\n" for grep !exists $gts{$_}, @ilst; bless [\%type2value, $name], $type; } sub get_str { my ($this, $parent, $context) = @_; my ($type2value, $name) = @{$this}; confess "generic type access outside a generic loop in $name" unless defined $parent->{Gencurtype}[-1]; $type2value->{$parent->{Gencurtype}[-1]->ppsym}; } package PDL::PP::GentypeAccess; use Carp; sub new { my($type,$pdl,$inds) = @_; bless [$inds],$type; } sub get_str {my($this,$parent,$context) = @_; confess "generic type access outside a generic loop" unless defined(my $type = $parent->{Gencurtype}[-1]); return $type->ctype if !$this->[0]; my $pobj = $parent->{ParObjs}{$this->[0]} // confess "not a defined parname"; $pobj->adjusted_type($type)->ctype; } package PDL::PP::PpsymAccess; use Carp; sub new { my($type,$pdl,$inds) = @_; bless [$inds],$type; } sub get_str {my($this,$parent,$context) = @_; confess "generic type access outside a generic loop" unless defined(my $type = $parent->{Gencurtype}[-1]); return $type->ppsym if !$this->[0]; my $pobj = $parent->{ParObjs}{$this->[0]} // confess "not a defined parname"; $pobj->adjusted_type($type)->ctype; } 1; PDL-2.074/Basic/Gen/Makefile.PL0000644000175000017500000000130114146003631015570 0ustar osboxesosboxesuse strict; use warnings; use ExtUtils::MakeMaker; use ExtUtils::MakeMaker::Config; my @pms = map {($_ => '$(INST_LIBDIR)/'.$_)} (<*.pm>, , 'PP/Dump.pm'); push @pms, ('pptemplate.pod' => '$(INST_LIBDIR)/pptemplate.pod'); undef &MY::postamble; # suppress warning *MY::postamble = sub { <<'EOF'; PP/Dump.pm: PP/dump.pp $(PERL) PP$(DFSEP)dump.pp > PP$(DFSEP)Dump.pm.tmp $(MV) PP$(DFSEP)Dump.pm.tmp PP$(DFSEP)Dump.pm pptemplate.pod: pptemplate $(PERLRUN) -MPod::Select -e "podselect('pptemplate');" > pptemplate.pod EOF }; WriteMakefile(NAME => "PDL::PP", PM => {@pms}, 'EXE_FILES' => ['pptemplate'], clean => {FILES => "PP/Dump.pm PP/Dump.pm.tmp pptemplate.pod"}, NO_MYMETA => 1, ); PDL-2.074/Basic/Gen/pptemplate0000755000175000017500000000777114014062163015737 0ustar osboxesosboxes#!perl -w sub names { my ($module) = @_; my $name = (split '::', $module)[-1]; my $pdname = lc $name . '.pd'; return ($name,$pdname); } sub pdtmpl { return join '', ; } sub pdMakefile { my ($module,$name,$pdname,$internal) = @_; my $coredev = $internal ? 'PDL::Core::Dev->import()' : 'use PDL::Core::Dev'; my $int = $internal ? '_int' : ''; return << "EOM"; # Use this as a template for the Makefile.PL for # any external PDL module. use ExtUtils::MakeMaker; $coredev; \@pack = (["$pdname",$name,$module]); \%hash = pdlpp_stdargs$int(\@pack); # \$hash{'OPTIMIZE'} = '-g'; # If you want to debug, uncomment this. # \$hash{INC} .= " -I/usr/local/include"; # uncomment as required # \$hash{LIBS}[0] .= " -L/usr/local/lib -lmylib "; # uncomment as required WriteMakefile(\%hash); # Add genpp rule # add other makefile additions as required (see also ExtUtils::MakeMaker) sub MY::postamble { pdlpp_postamble$int(\@pack); } EOM } sub usage { die << "EOU"; usage: $0 [option] modulename Options: -i internal mode - template for module that is in the PDL distribution EOU } use Getopt::Std; getopts('i'); usage unless $#ARGV > -1; ($module,$name,$pdname) = ($ARGV[0],names $ARGV[0]); die "Makefile.PL exists; move out of the way if you want to proceed" if -f 'Makefile.PL'; die "$pdname exists; move out of the way if you want to proceed" if -f $pdname; open $mkfl, '>Makefile.PL' or die "couldn't open Makefile.PL for writing"; open $pdfl, ">$pdname" or die "couldn't open $pdname for writing"; print $mkfl pdMakefile($module,$name,$pdname,$opt_i); close $mkfl; print $pdfl pdtmpl; close $pdfl; =head1 NAME pptemplate - script to generate Makefile.PL and PP file skeleton =head1 SYNOPSIS # generate Makefile.PL and mymodule.pd in CWD pptemplate PDL::MyModule; =head1 DESCRIPTION The B script is the easiest way to start a new module for PDL that contains PP code (see also L). The usage is simply pptemplate modulename; As a result pptemplate will generate a perl Makefile for the new module (F) that contains the minimal structure to generate a module from PP code and also a skeleton file for your new module. The file will be called F if you called C as pptemplate PDL::CleverAlgs::Mymod; I suppose you can work out the naming rule C<;)>. If not resort to experimentation or the source code. C will refuse to overwrite existing files of the same name to avoid accidents. Move them out of the way if you really want to scrap them. =head2 Options Currently there is only the C<-i> option which switches C into the so called I. It should only be used when you are starting a new module within the main PDL tree that is supposed to be part of the PDL distribution and the normal PDL build process, e.g. cd PDL/IO; mkdir Mpthree; cd Mpthree; pptemplate -i PDL::IO::Mpthree; =head1 BUGS Maybe C<;)>. Feedback and bug reports are welcome. =head1 COPYRIGHT Copyright (c) 2001, Christian Soeller. All Rights Reserved. This module is free software. It may be used, redistributed and/or modified under the same terms as PDL itself (see L). =cut __END__ # template auto generated by pptemplate # uncomment commands, copy and fill in as needed # see also the PDL::PP manpage # pp_bless(''); # package namespace of pp_def'ed functions # defaults to 'PDL' # pp_add_boot(''); # code to add to the XS boot section # pp_addhdr(''); # add C code to the section preceding # the first MODULE keyword # pp_addpm(''); # add perl code to the perl module that PP will create # pp_add_exported(''); # add the list of function names # to the list of exported functions # pp_addxs(''); # add plain XS code to the XS section # pp_add_isa(qw//); # inheritance business: add arglist to modules @ISA # pp_def('name', Code => ''); # minimal pp_def to define function pp_done(); # you will need this to finish pp processing PDL-2.074/Basic/Gen/Inline/0000755000175000017500000000000014200406301015031 5ustar osboxesosboxesPDL-2.074/Basic/Gen/Inline/MakePdlppInstallable.pm0000644000175000017500000000531614166072017021442 0ustar osboxesosboxespackage Inline::MakePdlppInstallable; # just a dummy package package # have to break this up so the # CPAN indexer doesn't barf Inline; use strict; use warnings; #============================================================================== # override the original Inline::install method # to allow Inline::Pdlpp code to be installed # # this is a hack ! # # we put the modified function into its own little file # to keep the runtime impact at a minimum # # use as follows in modules containing inlined PDL::PP code: # # use Inline::MakePdlppInstallable; # use Inline Pdlpp => .... # # hopefully Inline will establishe a proper mechanism soon # to allow installation of non-C modules -- at least Brian Ingerson # promised to put it on the TODO list #============================================================================== # copied verbatim from Inline 0.43 apart from language_id check below { no warnings 'redefine'; sub install { my ($module, $DIRECTORY); my $o = shift; # print STDERR "in redefined Inline::install\n"; croak M64_install_not_c($o->{API}{language_id}) unless uc($o->{API}{language_id}) eq 'C' || uc($o->{API}{language_id}) eq 'PDLPP'; # also allow Pdlpp ! croak M36_usage_install_main() if ($o->{API}{pkg} eq 'main'); croak M37_usage_install_auto() if $o->{CONFIG}{AUTONAME}; croak M38_usage_install_name() unless $o->{CONFIG}{NAME}; croak M39_usage_install_version() unless $o->{CONFIG}{VERSION}; croak M40_usage_install_badname($o->{CONFIG}{NAME}, $o->{API}{pkg}) unless $o->{CONFIG}{NAME} eq $o->{API}{pkg}; # $o->{CONFIG}{NAME} =~ /^$o->{API}{pkg}::\w(\w|::)+$/ # ); my ($mod_name, $mod_ver, $ext_name, $ext_ver) = ($o->{API}{pkg}, $ARGV[0], @{$o->{CONFIG}}{qw(NAME VERSION)}); croak M41_usage_install_version_mismatch($mod_name, $mod_ver, $ext_name, $ext_ver) unless ($mod_ver eq $ext_ver); $o->{INLINE}{INST_ARCHLIB} = $ARGV[1]; $o->{API}{version} = $o->{CONFIG}{VERSION}; $o->{API}{module} = $o->{CONFIG}{NAME}; my @modparts = split(/::/,$o->{API}{module}); $o->{API}{modfname} = $modparts[-1]; $o->{API}{modpname} = join('/',@modparts); $o->{API}{suffix} = $o->{INLINE}{ILSM_suffix}; $o->{API}{build_dir} = ( $o->{INLINE}{DIRECTORY} . '/build/' . $o->{API}{modpname} ); $o->{API}{directory} = $o->{INLINE}{DIRECTORY}; my $cwd = Cwd::cwd(); $o->{API}{install_lib} = "$cwd/$o->{INLINE}{INST_ARCHLIB}"; $o->{API}{location} = "$o->{API}{install_lib}/auto/" . "$o->{API}{modpname}/$o->{API}{modfname}.$o->{INLINE}{ILSM_suffix}"; unshift @::INC, $o->{API}{install_lib}; $o->{INLINE}{object_ready} = 0; } } 1; PDL-2.074/Basic/Gen/Inline/Pdlpp.pm0000644000175000017500000003423014160015533016460 0ustar osboxesosboxespackage Inline::Pdlpp; use strict; use warnings; use Config; use Data::Dumper; use Carp; use Cwd qw(cwd abs_path); use PDL::Core::Dev; $Inline::Pdlpp::VERSION = '0.4'; use base qw(Inline::C); #============================================================================== # Register this module as an Inline language support module #============================================================================== sub register { return { language => 'Pdlpp', aliases => ['pdlpp','PDLPP'], type => 'compiled', suffix => $Config{dlext}, }; } # handle BLESS, INTERNAL, NOISY - pass everything else up to Inline::C sub validate { my $o = shift; $o->{ILSM} ||= {}; $o->{ILSM}{XS} ||= {}; # Shouldn't use internal linking for Inline stuff, normally $o->{ILSM}{INTERNAL} = 0 unless defined $o->{ILSM}{INTERNAL}; $o->{ILSM}{MAKEFILE} ||= {}; if (not $o->UNTAINT) { $o->{ILSM}{MAKEFILE}{INC} = PDL::Core::Dev::PDL_INCLUDE(); } $o->{ILSM}{AUTO_INCLUDE} ||= ' '; # not '' as Inline::C does ||= my @pass_along; while (@_) { my ($key, $value) = (shift, shift); if ($key eq 'INTERNAL' or $key eq 'PACKAGE' or $key eq 'BLESS' ) { $o->{ILSM}{$key} = $value; next; } if ($key eq 'NOISY') { $o->{CONFIG}{BUILD_NOISY} = $value; next; } push @pass_along, $key, $value; } $o->SUPER::validate(@pass_along); } sub add_list { goto &Inline::C::add_list } sub add_string { goto &Inline::C::add_string } sub add_text { goto &Inline::C::add_text } #============================================================================== # Parse and compile C code #============================================================================== sub build { my $o = shift; # $o->parse; # no parsing in pdlpp $o->get_maps; # get the typemaps $o->write_PD; # $o->write_Inline_headers; # shouldn't need this one either $o->write_Makefile_PL; $o->compile; } #============================================================================== # Return a small report about the C code.. #============================================================================== sub info { my $o = shift; my $txt = <pd_generate . "\n*** end PP file ****\n"; } sub config { my $o = shift; } #============================================================================== # Write the PDL::PP code into a PD file #============================================================================== sub write_PD { my $o = shift; my $modfname = $o->{API}{modfname}; my $module = $o->{API}{module}; $o->mkpath($o->{API}{build_dir}); open my $fh, ">", "$o->{API}{build_dir}/$modfname.pd" or croak $!; print $fh $o->pd_generate; close $fh; } #============================================================================== # Generate the PDL::PP code (piece together a few snippets) #============================================================================== sub pd_generate { my $o = shift; return join "\n", ($o->pd_includes, $o->pd_code, $o->pd_boot, $o->pd_bless, $o->pd_done, ); } sub pd_includes { my $o = shift; return << "END"; pp_addhdr << 'EOH'; $o->{ILSM}{AUTO_INCLUDE} EOH END } sub pd_code { my $o = shift; return $o->{API}{code}; } sub pd_boot { my $o = shift; if (defined $o->{ILSM}{XS}{BOOT} and $o->{ILSM}{XS}{BOOT}) { return <{ILSM}{XS}{BOOT} EOB END } return ''; } sub pd_bless { my $o = shift; if (defined $o->{ILSM}{BLESS} and $o->{ILSM}{BLESS}) { return <{ILSM}{BLESS}; END } return ''; } sub pd_done { return <SUPER::get_maps; push @{$o->{ILSM}{MAKEFILE}{TYPEMAPS}}, PDL::Core::Dev::PDL_TYPEMAP(); } #============================================================================== # Generate the Makefile.PL #============================================================================== sub write_Makefile_PL { my $o = shift; my ($modfname,$module,$pkg) = @{$o->{API}}{qw(modfname module pkg)}; my $coredev_suffix = $o->{ILSM}{INTERNAL} ? '_int' : ''; my @pack = [ "$modfname.pd", $modfname, $module ]; my $stdargs_func = $o->{ILSM}{INTERNAL} ? \&pdlpp_stdargs_int : \&pdlpp_stdargs; my %hash = $stdargs_func->(@pack); delete $hash{VERSION_FROM}; my %options = ( %hash, VERSION => $o->{API}{version} || "0.00", %{$o->{ILSM}{MAKEFILE}}, NAME => $o->{API}{module}, INSTALLSITEARCH => $o->{API}{install_lib}, INSTALLDIRS => 'site', INSTALLSITELIB => $o->{API}{install_lib}, MAN3PODS => {}, PM => {}, ); my @postamblepack = ("$modfname.pd", $modfname, $module); push @postamblepack, $o->{ILSM}{PACKAGE} if $o->{ILSM}{PACKAGE}; local $Data::Dumper::Terse = 1; local $Data::Dumper::Indent = 1; open my $fh, ">", "$o->{API}{build_dir}/Makefile.PL" or croak; print $fh <SUPER::compile; } sub fix_make { } # our Makefile.PL doesn't need this 1; __END__ =head1 NAME Inline::Pdlpp - Write PDL Subroutines inline with PDL::PP =head1 DESCRIPTION C is a module that allows you to write PDL subroutines in the PDL::PP style. The big benefit compared to plain C is that you can write these definitions inline in any old perl script (without the normal hassle of creating Makefiles, building, etc). Since version 0.30 the Inline module supports multiple programming languages and each language has its own support module. This document describes how to use Inline with PDL::PP (or rather, it will once these docs are complete C<;)>. For more information on Inline in general, see L. Some example scripts demonstrating C usage can be found in the F directory. C is a subclass of L. Most Kudos goes to Brian I. =head1 Usage You never actually use C directly. It is just a support module for using C with C. So the usage is always: use Inline Pdlpp => ...; or bind Inline Pdlpp => ...; =head1 Examples Pending availability of full docs a few quick examples that illustrate typical usage. =head2 A simple example # example script inlpp.pl use PDL; # must be called before (!) 'use Inline Pdlpp' calls use Inline Pdlpp; # the actual code is in the __Pdlpp__ block below $x = sequence 10; print $x->inc,"\n"; print $x->inc->dummy(1,10)->tcumul,"\n"; __DATA__ __Pdlpp__ pp_def('inc', Pars => 'i();[o] o()', Code => '$o() = $i() + 1;', ); pp_def('tcumul', Pars => 'in(n);[o] mul()', Code => '$mul() = 1; loop(n) %{ $mul() *= $in(); %}', ); # end example script If you call this script it should generate output similar to this: prompt> perl inlpp.pl Inline running PDL::PP version 2.2... [1 2 3 4 5 6 7 8 9 10] [3628800 3628800 3628800 3628800 3628800 3628800 3628800 3628800 3628800 3628800] Usage of C in general is similar to C. In the absence of full docs for C you might want to compare L. =head2 Code that uses external libraries, etc The script below is somewhat more complicated in that it uses code from an external library (here from Numerical Recipes). All the relevant information regarding include files, libraries and boot code is specified in a config call to C. For more experienced Perl hackers it might be helpful to know that the format is similar to that used with L. The keywords are largely equivalent to those used with C. Please see below for further details on the usage of C, C, C and C. use PDL; # this must be called before (!) 'use Inline Pdlpp' calls use Inline Pdlpp => Config => INC => "-I$ENV{HOME}/include", LIBS => "-L$ENV{HOME}/lib -lnr -lm", # code to be included in the generated XS AUTO_INCLUDE => <<'EOINC', #include #include "nr.h" /* for poidev */ #include "nrutil.h" /* for err_handler */ static void nr_barf(char *err_txt) { fprintf(stderr,"Now calling croak...\n"); croak("NR runtime error: %s",err_txt); } EOINC # install our error handler when loading the Inline::Pdlpp code BOOT => 'set_nr_err_handler(nr_barf);'; use Inline Pdlpp; # the actual code is in the __Pdlpp__ block below $x = zeroes(10) + 30;; print $x->poidev(5),"\n"; __DATA__ __Pdlpp__ pp_def('poidev', Pars => 'xm(); [o] pd()', GenericTypes => [L,F,D], OtherPars => 'long idum', Code => '$pd() = poidev((float) $xm(), &$COMP(idum));', ); =head1 Pdlpp Configuration Options For information on how to specify Inline configuration options, see L. This section describes each of the configuration options available for Pdlpp. Most of the options correspond either to MakeMaker or XS options of the same name. See L and L. =head2 AUTO_INCLUDE Specifies extra statements to automatically included. They will be added onto the defaults. A newline char will be automatically added. Does essentially the same as a call to C. For short bits of code C is probably syntactically nicer. use Inline Pdlpp => Config => AUTO_INCLUDE => '#include "yourheader.h"'; =head2 BLESS Same as C command. Specifies the package (i.e. class) to which your new Ied methods will be added. Defaults to C if omitted. use Inline Pdlpp => Config => BLESS => 'PDL::MyPackage'; cf L, equivalent for L. =head2 BOOT Specifies C code to be executed in the XS BOOT section. Corresponds to the XS parameter. Does the same as the C command. Often used to execute code only once at load time of the module, e.g. a library initialization call. =head2 CC Specify which compiler to use. =head2 CCFLAGS Specify extra compiler flags. =head2 INC Specifies an include path to use. Corresponds to the MakeMaker parameter. use Inline Pdlpp => Config => INC => '-I/inc/path'; =head2 LD Specify which linker to use. =head2 LDDLFLAGS Specify which linker flags to use. NOTE: These flags will completely override the existing flags, instead of just adding to them. So if you need to use those too, you must respecify them here. =head2 LIBS Specifies external libraries that should be linked into your code. Corresponds to the MakeMaker parameter. use Inline Pdlpp => Config => LIBS => '-lyourlib'; or use Inline Pdlpp => Config => LIBS => '-L/your/path -lyourlib'; =head2 MAKE Specify the name of the 'make' utility to use. =head2 MYEXTLIB Specifies a user compiled object that should be linked in. Corresponds to the MakeMaker parameter. use Inline Pdlpp => Config => MYEXTLIB => '/your/path/yourmodule.so'; =head2 OPTIMIZE This controls the MakeMaker OPTIMIZE setting. By setting this value to '-g', you can turn on debugging support for your Inline extensions. This will allow you to be able to set breakpoints in your C code using a debugger like gdb. =head2 PACKAGE Controls into which package the created XSUBs from L go. E.g.: use Inline Pdlpp => 'DATA', => PACKAGE => 'Other::Place'; will put the created routines into C, not the calling package (which is the default). Note this differs from L, which is where Ls go. =head2 TYPEMAPS Specifies extra typemap files to use. Corresponds to the MakeMaker parameter. use Inline Pdlpp => Config => TYPEMAPS => '/your/path/typemap'; =head2 NOISY Show the output of any compilations going on behind the scenes. Turns on C in L. =head1 BUGS =head2 Cing inline scripts Beware that there is a problem when you use the __DATA__ keyword style of Inline definition and want to C your script containing inlined code. For example # myscript.pl contains inlined code # in the __DATA__ section perl -e 'do "myscript.pl";' One or more DATA sections were not processed by Inline. According to Brian Ingerson (of Inline fame) the workaround is to include an Cinit> call in your script, e.g. use PDL; use Inline Pdlpp; Inline->init; # perl code __DATA__ __Pdlpp__ # pp code =head2 C and C There is currently an undesired interaction between L and C. Since PP code generally contains expressions of the type C<$var()> (to access ndarrays, etc) L recognizes those incorrectly as slice expressions and does its substitutions. For the moment (until hopefully the parser can deal with that) it is best to explicitly switch L off before the section of inlined Pdlpp code. For example: use PDL::NiceSlice; use Inline::Pdlpp; $x = sequence 10; $x(0:3)++; $x->inc; no PDL::NiceSlice; __DATA__ __C__ ppdef (...); # your full pp definition here =head1 ACKNOWLEDGEMENTS Brian Ingerson for creating the Inline infrastructure. =head1 AUTHOR Christian Soeller =head1 SEE ALSO L L L L =head1 COPYRIGHT Copyright (c) 2001. Christian Soeller. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as PDL itself. See http://pdl.perl.org =cut PDL-2.074/Basic/Gen/Inline/Makefile.PL0000644000175000017500000000040314146003631017010 0ustar osboxesosboxesuse strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'Inline', VERSION_FROM => 'Pdlpp.pm', PREREQ_PM => {'Inline' => 0.43}, PM => { map {($_ => '$(INST_LIBDIR)/Inline/'.$_)} <*.pm> }, NO_MYMETA => 1, ); PDL-2.074/Basic/Lite.pm0000644000175000017500000000214614146003631014350 0ustar osboxesosboxes=head1 NAME PDL::Lite - minimum PDL module OO loader =head1 DESCRIPTION Loads the smallest possible set of modules for PDL to work, importing only those functions always defined by L) into the current namespace (C, C, C and C). This is the absolute minimum set for PDL. Access to other functions is by method syntax, viz: $x = PDL->pdl(1, 2, 3, 4, 5); $x->wibble(42); =head1 SYNOPSIS use PDL::Lite; # Is equivalent to the following: use PDL::Core ''; use PDL::Ops ''; use PDL::Primitive ''; use PDL::Ufunc ''; use PDL::Basic ''; use PDL::Slices ''; use PDL::Bad ''; use PDL::Lvalue; =cut package PDL::Lite; use strict; use warnings; use PDL::Core qw(pdl piddle barf null); use PDL::Ops ''; use PDL::Primitive ''; use PDL::Ufunc ''; use PDL::Basic ''; use PDL::Slices ''; use PDL::Bad ''; require PDL; # for VERSION use PDL::Lvalue; our $VERSION = $PDL::VERSION; our @ISA = qw( PDL::Exporter ); our @EXPORT = qw( piddle pdl null barf ); # Only stuff always exported! our %EXPORT_TAGS = ( Func => [@EXPORT], ); ;# Exit with OK status 1; PDL-2.074/Basic/Matrix.pm0000644000175000017500000002141614165550463014733 0ustar osboxesosboxes=head1 NAME PDL::Matrix -- a convenience matrix class for column-major access =head1 VERSION This document refers to version PDL::Matrix 0.5 of PDL::Matrix =head1 SYNOPSIS use PDL::Matrix; $m = mpdl [[1,2,3],[4,5,6]]; $m = PDL::Matrix->pdl([[1,2,3],[4,5,6]]); $m = msequence(4,3); @dimsa = $x->mdims; # 'dims' is not overloaded $v = vpdl [0,1,2,3] $v = vzeroes(4); =head1 DESCRIPTION =head2 Overview This package tries to help people who want to use PDL for 2D matrix computation with lots of indexing involved. It provides a PDL subclass so one- and two-dimensional ndarrays that are used as vectors resp and matrices can be typed in using traditional matrix convention. If you want to know more about matrix operation support in PDL, you want to read L or L. The original pdl class refers to the first index as the first row, the second index as the first column of a matrix. Consider print $B = sequence(3,2) [ [0 1 2] [3 4 5] ] which gives a 2x3 matrix in terms of the matrix convention, but the constructor used (3,2). This might get more confusing when using slices like sequence(3,2)->slice("1:2,(0)") : with traditional matrix convention one would expect [2 4] instead of [1 2]. This subclass PDL::Matrix overloads the constructors and indexing functions of pdls so that they are compatible with the usual matrix convention, where the first dimension refers to the row of a matrix. So now, the above example would be written as print $B = PDL::Matrix->sequence(3,2) # or $B = msequence(3,2) [ [0 1] [2 3] [4 5] ] Routines like L or L can be used without any changes. Furthermore one can construct and use vectors as n x 1 matrices without mentioning the second index '1'. =head2 Implementation C works by overloading a number of PDL constructors and methods such that first and second args (corresponding to first and second dims of corresponding matrices) are effectively swapped. It is not yet clear if PDL::Matrix achieves a consistent column-major look-and-feel in this way. =head1 NOTES As of version 0.5 (rewrite by CED) the matrices are stored in the usual way, just constructed and stringified differently. That way indexing and everything else works the way you think it should. =head1 FUNCTIONS =cut package PDL::Matrix; use strict; use warnings; use PDL::Exporter; use Carp; our @EXPORT_OK; our %EXPORT_TAGS = (Func=>\@EXPORT_OK); our @ISA = qw/PDL::Exporter PDL/; our $VERSION = "0.5"; $VERSION = eval $VERSION; #######################################################################= ######### # # overloads use overload( '""' => \&string, 'x' => sub {my $foo = $_[0]->null(); &PDL::Primitive::matmult(@_[1,0],$foo); $foo;} ); sub string { my ($me,@a) = shift; return $me->SUPER::string(@a) unless($me->ndims > 0); $me = $me->dummy(1,1) unless($me->ndims > 1); $me->transpose->SUPER::string(@a); } # --------> constructors =head2 mpdl, PDL::Matrix::pdl =for ref constructs an object of class PDL::Matrix which is an ndarray child class. =for example $m = mpdl [[1,2,3],[4,5,6]]; $m = PDL::Matrix->pdl([[1,2,3],[4,5,6]]); =cut sub pdl { my $class = shift; my $pdl = $class->SUPER::pdl(@_)->transpose; bless $pdl, ref $class || $class; } =head2 mzeroes, mones, msequence =for ref constructs a PDL::Matrix object similar to the ndarray constructors zeroes, ones, sequence. =cut for my $func (qw /pdl zeroes ones sequence dims/) { push @EXPORT_OK, "m$func"; eval " sub m$func { PDL::Matrix->$func(\@_) }; "; } =head2 vpdl =for ref constructs an object of class PDL::Matrix which is of matrix dimensions (n x 1) =for example print $v = vpdl [0,1]; [ [0] [1] ] =cut sub vpdl { my $pdl = PDL->pdl(@_); bless $pdl, __PACKAGE__; } push @EXPORT_OK, "vpdl"; =head2 vzeroes, vones, vsequence =for ref constructs a PDL::Matrix object with matrix dimensions (n x 1), therefore only the first scalar argument is used. =for example print $v = vsequence(2); [ [0] [1] ] =cut for my $func (qw /zeroes ones sequence/) { push @EXPORT_OK, "v$func"; my $code = << "EOE"; sub v$func { my \@arg = \@_; ref(\$arg[0]) ne 'PDL::Type' ? (\@arg = (\$arg[0],1)) : (\@arg = (\$arg[0],\$arg[1],1)); PDL::Matrix->$func(\@arg); } EOE # print "evaluating $code\n"; eval $code; } eval "use PDL::Slatec"; my $has_slatec = ($@ ? 0 : 1); sub inv { my $self = shift; croak "inv: PDL::Slatec not available" unless $has_slatec; return $self->matinv; } =head2 kroneckerproduct =for ref returns kroneckerproduct of two matrices. This is not efficiently implemented. =for example print kroneckerproduct(msequence(2,2),mones(2,2)) [ [0 0 1 1] [0 0 1 1] [2 2 3 3] [2 2 3 3] ] =cut # returns kroneckerproduct of two matrices sub kroneckerproduct { my @arg = @_; my ($r0,$c0) = $arg[0]->mdims; my ($r1,$c1) = $arg[1]->mdims; my $out = mzeroes($r0*$r1,$c0*$c1); for (my $i=0;$i<$r0;$i++) { for (my $j=0;$j<$c0;$j++) { ($_ = $out->slice(($i*$r1).":".(($i+1)*$r1-1).",". ($j*$c1).":".(($j+1)*$c1-1)) ) .= $arg[0]->at($i,$j) * $arg[1]; } } return $out; } push @EXPORT_OK, "kroneckerproduct"; sub rotate { my ($self,@args) = @_; return $self->transpose->SUPER::rotate(@args)->transpose; } sub msumover { my ($mpdl) = @_; return PDL::sumover(transpose($mpdl)->xchg(0,2)); } push @EXPORT_OK, "msumover"; =head2 det_general =for ref returns a generalized determinant of a matrix. If the matrix is not regular, one can specify the rank of the matrix and the corresponding subdeterminant is returned. This is implemented using the C function. =for example print msequence(3,3)->determinant(2) # determinant of # regular 2x2 submatrix -24 =cut # sub det_general { my ($mpdl,$rank) = @_; my $eigenvalues = (PDL::Math::eigens($mpdl))[1]; my @sort = list(PDL::Ufunc::qsorti(abs($eigenvalues))); $eigenvalues = $eigenvalues->dice([@sort[-$rank..-1]]); PDL::Ufunc::dprod($eigenvalues); } =head2 trace =for ref returns the trace of a matrix (sum of diagonals) =cut sub trace { my ($mpdl) = @_; $mpdl->diagonal(0,1)->sum; } # this has to be overloaded so that the PDL::slice # is called and not PDL::Matrix::slice :-( sub dummy($$;$) { my ($pdl,$dim) = @_; $dim = $pdl->getndims+1+$dim if $dim < 0; barf ("too high/low dimension in call to dummy, allowed min/max=0/" . $_[0]->getndims) if $dim>$pdl->getndims || $dim < 0; $_[2] = 1 if ($#_ < 2); $pdl->PDL::slice((','x$dim)."*$_[2]"); } # now some of my very own helper functions... # stupid function to print a PDL::Matrix object in Maple code sub stringifymaple { my ($self,@args) = @_; my ($dimR,$dimC) = mdims($self); my $s; $s .= $args[0].":=" unless $args[0] eq ""; if (defined($dimR)) { $s .= "matrix($dimR,$dimC,["; for(my $i=0;$i<$dimR;++$i) { $s .= "["; for(my $j=0;$j<$dimC;++$j) { $s .= $self->at($i,$j); $s .= "," if $j+1<$dimC; } $s .= "]"; $s .= "," if $i+1<$dimR; } $s .= "])"; } else { $s = "vector($dimC,["; for(my $i=0;$i<$dimC;++$i) { $s .= $self->at($i); $s .= "," if $i+1<$dimC; } $s .= "])"; } return $s; } sub printmaple { print stringifymaple(@_).";\n"; } # stupid function to print a PDL::Matrix object in (La)TeX code sub stringifyTeX { my ($self,@args) = @_; my ($dimR,$dimC) = mdims($self); my $s; $s .= $args[0]."=" unless $args[0] eq ""; $s .= "\\begin{pmatrix}\n"; for(my $i=0;$i<$dimR;++$i) { for(my $j=0;$j<$dimC;++$j) { $s .= $self->at($i,$j); $s .= " & " if $j+1<$dimC; } $s .= " \\\\ \n" if $i+1<$dimR; } $s .= "\n \\end{pmatrix}\n"; return $s; } sub printTeX { print stringifyTeX(@_)."\n"; } 1; =head1 BUGS AND PROBLEMS Because we change the way ndarrays are constructed, not all pdl operators may be applied to ndarray-matrices. The inner product is not redefined. We might have missed some functions/methods. Internal consistency of our approach needs yet to be established. Because PDL::Matrix changes the way slicing behaves, it breaks many operators, notably those in MatrixOps. =head1 TODO check all PDL functions, benchmarks, optimization, lots of other things ... =head1 AUTHOR(S) Stephan Heuel (stephan@heuel.org), Christian Soeller (c.soeller@auckland.ac.nz). =head1 COPYRIGHT 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 PDL-2.074/Basic/AutoLoader.pm0000644000175000017500000002052214165336206015520 0ustar osboxesosboxes=head1 NAME PDL::AutoLoader - MatLab style AutoLoader for PDL =head1 SYNOPSIS use PDL::AutoLoader; $x = func1(...); # Load file func1.pdl $y = func2(...); # Load file func2.pdl $PDL::AutoLoader::Rescan = 1; # Enable re-scanning =head1 DESCRIPTION This module implements a MatLab style AutoLoader for PDL. If an unknown function C is called, PDL looks for a file called C. If it finds one, it compiles the file and calls the function C. The list of directories to search in is given by the shell environment variable C. This is a colon-separated list of directories. On MSWindows systems, is it a I -separated list of directories. For example, in csh: setenv PDLLIB "/home/joe/pdllib:/local/pdllib" B: This variable is unrelated to Perl's C. If you add a leading '+' on a directory name, PDL will search the entire directory tree below that point. Internally, PDL stores the directory list in the variable C<@PDLLIB>, which can be modified at run time. For example, in csh: setenv PDLLIB "+/home/joe/PDL" will search /home/joe/PDL and all its subdirectories for .pdl files. =head2 AUTO-SCANNING The variable C<$PDL::AutoLoader::Rescan> controls whether files are automatically re-scanned for changes at the C or C command line. If C<$PDL::AutoLoader::Rescan == 1> and the file is changed then the new definition is reloaded auto-matically before executing the C or C command line. Which means in practice you can edit files, save changes and have C or C see the changes automatically. The default is '0' - i.e. to have this feature disabled. As this feature is only pertinent to the PDL shell it imposes no overhead on PDL scripts. Yes Bob you can have your cake and eat it too! Note: files are only re-evaled if they are determined to have been changed according to their date/time stamp. No doubt this interface could be improved upon some more. :-) =head2 Sample file: sub foo { # file 'foo.pdl' - define the 'foo' function my $x=shift; return sqrt($x**2 + $x**3 + 2); } 1; # File returns true (i.e. loaded successfully) =head1 AUTHOR Copyright(C) 1997 Karl Glazebrook (kgb@aaoepp.aao.gov.au); several extensions by Craig DeForest (deforest@boulder.swri.edu) 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. =head1 BUGS No doubt this interface could be improved upon some more. :-) Will probably be quite slow if C<$PDL::AutoLoader::Rescan == 1> and thousands of functions have been autoloaded. There could be a race condition in which the file changes while the internal autoloader code is being executed but it should be harmless. Probably has not been tested enough! =head1 SEE ALSO For an alternative approach to managing a personal collaction of modules and functions, see L. =cut use strict; use warnings; our @PDLLIB; BEGIN{ if (defined $ENV{"PDLLIB"}) { if ( $^O eq 'MSWin32' ) { # win32 flavors @PDLLIB = (".",split(';',$ENV{"PDLLIB"})); s/"//g for @PDLLIB; } else { # unixen systems @PDLLIB = (".",split(':',$ENV{"PDLLIB"})); } @PDLLIB = grep length, @PDLLIB; } $PDL::AutoLoader::Rescan=0; %PDL::AutoLoader::FileInfo = (); } # Code to reload stuff if changed sub PDL::AutoLoader::reloader { return unless $PDL::AutoLoader::Rescan; # Now check functions and reload if changed my ($file, $old_t); for my $func (sort keys %PDL::AutoLoader::FileInfo) { ($file, $old_t) = @{ $PDL::AutoLoader::FileInfo{$func} }; if ( (stat($file))[9]>$old_t ) { # Reload print "Reloading $file as file changed...\n" if $PDL::verbose; PDL::AutoLoader::autoloader_do($file); $PDL::AutoLoader::FileInfo{$func} = [ $file, (stat($file))[9] ]; } } } # Used for Beta, and should probably be used generall in this mod #use File::Spec; sub PDL::AutoLoader::import { # Beta folder support # foreach (@INC) { # $Beta_dir = File::Spec->catfile($_, 'PDL', 'Beta'); # push @PDLLIB, "+$Beta_dir" if -d $Beta_dir; # } my $pkg = (caller())[0]; my $toeval = "package $pkg; no strict; no warnings;\n"; # Make sure that the eval gets NiceSlice if we have it in this level # (it's a drag that preprocessors aren't transitive...) $toeval .= "use PDL::NiceSlice;\n" if(defined $PDL::NiceSlice::VERSION); $toeval .= <<'EOD'; $PDLLIB_CT = 0; push @PERLDL::AUTO, \&PDL::AutoLoader::reloader; sub AUTOLOAD { local @INC = @INC; my @args = @_; $AUTOLOAD =~ /::([^:]*)$/; my $func = $1; # Trap spurious calls from 'use UnknownModule' goto &$AUTOLOAD if ord($func)==0; # Check if the PDLLIB needs to be expanded and, if so, expand it. # This only updates when PDLLIB changes size, which should be OK # for most things but doesn't catch new directories in expanded # directory trees. It seems like an OK compromise between never # catching anything and always thrashing through the directories. if($PDLLIB_CT != scalar(@PDLLIB)) { @PDLLIB_EXPANDED = PDL::AutoLoader::expand_path(@PDLLIB); $PDLLIB_CT = scalar(@PDLLIB); } print "Loading $func.pdl ..." if $PDL::verbose; my $file; my $s = "PDL AutoLoader: Undefined subroutine $func() cannot be autoloaded.\n"; for my $dir (@PDLLIB_EXPANDED) { $file = $dir . "/" . "$func.pdl"; if (-e $file) { print "found $file\n" if $PDL::verbose; PDL::AutoLoader::autoloader_do($file); # Remember autoloaded functions and do some reasonably # smart cacheing of file/directory change times if ($PDL::AutoLoader::Rescan) { $PDL::AutoLoader::FileInfo{$func} = [ $file, (stat($file))[9] ]; } # Now go to the autoload function ##goto &$AUTOLOAD(@args) unless ($@ || !defined(&{$AUTOLOAD})); return &$AUTOLOAD(@args) unless ($@ || !defined(&{$AUTOLOAD})); die $s."\tWhile parsing file `$file':\n$@\n" if($@); die $s."\tFile `$file' doesn't \n\tdefine ${AUTOLOAD}().\n" } } die $s."\tNo file `$func.pdl' was found in your \@PDLLIB path.\n"; } EOD eval $toeval; } # Simple 'do' doesn't work with preprocessing -- this replaces # "do file" and sticks NiceSlice in manually if it's needed (yuck). sub PDL::AutoLoader::autoloader_do { my ($file) = shift; if(defined($PDL::NiceSlice::VERSION)) { print "AutoLoader: NiceSlice enabled...\n" if($PDL::debug); if(open(AUTOLOAD_FILE,"<$file")) { my($script) = PDL::NiceSlice::perldlpp("PDL::NiceSlice", join("",)); eval $script; } } else { print "AutoLoader: no NiceSlice...\n" if($PDL::debug); do $file; } } # Expand directories recursively... sub PDL::AutoLoader::expand_dir { my $dir = shift; return undef if !-d $dir; opendir my($dh), $dir; ($dir, map PDL::AutoLoader::expand_dir($_), grep +(!m/^\./ && ($_="$dir/$_") && (-d $_)), readdir $dh); } =head2 PDL::AutoLoader::expand_path =for ref Expand a compactified path into a dir list You supply a pathlist and leading '+' and '~' characters get expanded into full directories. Normally you don't want to use this -- it's internal to the autoloader -- but some utilities, like the online documentation searcher, need to be able to use it. =cut sub PDL::AutoLoader::expand_path { my @PDLLIB = @_; my @PDLLIB_EXPANDED; print "AutoLoader: Expanding directories from ".join(':',@PDLLIB)."...\n" if($PDL::debug); local $_; foreach $_(@PDLLIB) { # Expand ~{name} and ~ conventions. if(s/^(\+?)\~(\+||[a-zA-Z0-9]*)//) { if($2 eq '+') { # Expand shell '+' to CWD. $_= $1 . ($ENV{'PWD'} || '.'); } elsif(!$2) { # No name mentioned -- use current user. # Ideally would use File::HomeDir->my_home() here $_ = $1 . ( $ENV{'HOME'} || (( getpwnam( getlogin || getpwuid($<) ))[7]) ) . $_; } else { # Name mentioned - try to get that user's home directory. $_ = $1 . ( (getpwnam($2))[7] ) . $_; } } # If there's a leading '+', include all subdirs too. push(@PDLLIB_EXPANDED, s/^\+// ? PDL::AutoLoader::expand_dir($_) : $_ ); } print "AutoLoader: returning ",join(",",@PDLLIB_EXPANDED),"\n" if($PDL::debug); @PDLLIB_EXPANDED; } ;# Exit with OK status 1; PDL-2.074/Basic/Slices/0000755000175000017500000000000014200406301014324 5ustar osboxesosboxesPDL-2.074/Basic/Slices/slices.pd0000644000175000017500000022706214175373763016176 0ustar osboxesosboxesuse PDL::Types qw(ppdefs_all); use strict; use warnings; pp_addpm({At => 'Top'},<< 'EOD'); =head1 NAME PDL::Slices -- Indexing, slicing, and dicing =head1 SYNOPSIS use PDL; $x = ones(3,3); $y = $x->slice('-1:0,(1)'); $c = $x->dummy(2); =head1 DESCRIPTION This package provides many of the powerful PerlDL core index manipulation routines. These routines mostly allow two-way data flow, so you can modify your data in the most convenient representation. For example, you can make a 1000x1000 unit matrix with $x = zeroes(1000,1000); $x->diagonal(0,1) ++; which is quite efficient. See L and L for more examples. Slicing is so central to the PDL language that a special compile-time syntax has been introduced to handle it compactly; see L for details. PDL indexing and slicing functions usually include two-way data flow, so that you can separate the actions of reshaping your data structures and modifying the data themselves. Two special methods, L and L, help you control the data flow connection between related variables. $y = $x->slice("1:3"); # Slice maintains a link between $x and $y. $y += 5; # $x is changed! If you want to force a physical copy and no data flow, you can copy or sever the slice expression: $y = $x->slice("1:3")->copy; $y += 5; # $x is not changed. $y = $x->slice("1:3")->sever; $y += 5; # $x is not changed. The difference between C and C is that sever acts on (and returns) its argument, while copy produces a disconnected copy. If you say $y = $x->slice("1:3"); $c = $y->sever; then the variables C<$y> and C<$c> point to the same object but with C<-Ecopy> they would not. =cut use strict; use warnings; use PDL::Core ':Internal'; use Scalar::Util 'blessed'; EOD =head1 FUNCTIONS =cut # $::PP_VERBOSE=1; pp_addhdr(<<'EOH'); #ifdef _MSC_VER #define strtoll _strtoi64 #endif EOH my $doc = <<'EOD'; =for ref C, C, and C provide rudimentary index indirection. =for example $c = index($source,$ind); $c = index1d($source,$ind); $c = index2d($source2,$ind1,$ind2); use the C<$ind> variables as indices to look up values in C<$source>. The three routines thread slightly differently. =over 3 =item * C uses direct threading for 1-D indexing across the 0 dim of C<$source>. It can thread over source thread dims or index thread dims, but not (easily) both: If C<$source> has more than 1 dimension and C<$ind> has more than 0 dimensions, they must agree in a threading sense. =item * C uses a single active dim in C<$ind> to produce a list of indexed values in the 0 dim of the output - it is useful for collapsing C<$source> by indexing with a single row of values along C<$source>'s 0 dimension. The output has the same number of dims as C<$source>. The 0 dim of the output has size 1 if C<$ind> is a scalar, and the same size as the 0 dim of C<$ind> if it is not. If C<$ind> and C<$source> both have more than 1 dim, then all dims higher than 0 must agree in a threading sense. =item * C works like C but uses separate ndarrays for X and Y coordinates. For more general N-dimensional indexing, see the L syntax or L (in particular C, C, and C). =back These functions are two-way, i.e. after $c = $x->index(pdl[0,5,8]); $c .= pdl [0,2,4]; the changes in C<$c> will flow back to C<$x>. C provids simple threading: multiple-dimensioned arrays are treated as collections of 1-D arrays, so that $x = xvals(10,10)+10*yvals(10,10); $y = $x->index(3); $c = $x->index(9-xvals(10)); puts a single column from C<$x> into C<$y>, and puts a single element from each column of C<$x> into C<$c>. If you want to extract multiple columns from an array in one operation, see L or L. =cut EOD my $index_init_good = 'register PDL_Indx foo = $ind(); if( foo<0 || foo>=$SIZE(n) ) { $CROAK("invalid index %d (valid range 0..%d)", foo,$SIZE(n)-1); }'; my $index_init_bad = 'register PDL_Indx foo = $ind(); if( $ISBADVAR(foo,ind) || foo<0 || foo>=$SIZE(n) ) { $CROAK("invalid index %d (valid range 0..%d)", foo,$SIZE(n)-1); }'; pp_def( 'index', GenericTypes => [ppdefs_all], HandleBad => 1, DefaultFlow => 1, TwoWay => 1, Pars => 'a(n); indx ind(); [oca] c();', Code => $index_init_good . ' $c() = $a(n => foo);', BadCode => $index_init_bad . ' $c() = $a(n => foo);', BackCode => $index_init_good . ' $a(n => foo) = $c();', BadBackCode => $index_init_bad . ' $a(n => foo) = $c();', Doc => $doc, BadDoc => 'index barfs if any of the index values are bad.', ); pp_def( 'index1d', GenericTypes => [ppdefs_all], HandleBad => 1, DefaultFlow => 1, TwoWay => 1, Pars => 'a(n); indx ind(m); [oca] c(m);', Code => q{ PDL_Indx i; for(i=0;i<$SIZE(m);i++) { PDL_Indx foo = $ind(m=>i); if( foo<0 || foo >= $SIZE(n) ) { $CROAK("invalid index %d at pos %d (valid range 0..%d)", foo, i, $SIZE(n)-1); } $c(m=>i) = $a(n=>foo); } }, BadCode => q{ PDL_Indx i; for(i=0;i<$SIZE(m);i++) { PDL_Indx foo = $ind(m=>i); if( $ISBADVAR(foo, ind) ) { $SETBAD(c(m=>i)); } else { if( foo<0 || foo >= $SIZE(n) ) { $CROAK("invalid/bad index %d at pos %d (valid range 0..%d)", foo, i, $SIZE(n)-1); } $c(m=>i) = $a(n=>foo); } } }, BackCode => q{ PDL_Indx i; for(i=0;i<$SIZE(m);i++) { PDL_Indx foo = $ind(m=>i); if( foo<0 || foo >= $SIZE(n) ) { $CROAK("invalid index %d at pos %d (valid range 0..%d)", foo, i, $SIZE(n)-1); } $a(n=>foo) = $c(m=>i); } }, BadBackCode => q{ PDL_Indx i; for(i=0;i<$SIZE(m);i++) { PDL_Indx foo = $ind(m=>i); if( $ISBADVAR(foo, ind) ) { /* do nothing */ } else { if( foo<0 || foo >= $SIZE(n) ) { $CROAK("invalid/bad index %d at pos %d (valid range 0..%d)", foo, i, $SIZE(n)-1); } $a(n=>foo) = $c(m=>i); } } }, Doc => $doc, BadDoc => 'index1d propagates BAD index elements to the output variable.' ); my $index2d_init_good = 'register PDL_Indx fooa,foob; fooa = $inda(); if( fooa<0 || fooa>=$SIZE(na) ) { $CROAK("invalid x-index %d (valid range 0..%d)", fooa,$SIZE(na)-1); } foob = $indb(); if( foob<0 || foob>=$SIZE(nb) ) { $CROAK("invalid y-index %d (valid range 0..%d)", foob,$SIZE(nb)-1); }'; my $index2d_init_bad = 'register PDL_Indx fooa,foob; fooa = $inda(); if( $ISBADVAR(fooa,inda) || fooa<0 || fooa>=$SIZE(na) ) { $CROAK("invalid index 1"); } foob = $indb(); if( $ISBADVAR(foob,indb) || foob<0 || foob>=$SIZE(nb) ) { $CROAK("invalid index 2"); }'; pp_def( 'index2d', GenericTypes => [ppdefs_all], HandleBad => 1, DefaultFlow => 1, TwoWay => 1, Pars => 'a(na,nb); indx inda(); indx indb(); [oca] c();', Code => $index2d_init_good . ' $c() = $a(na => fooa, nb => foob);', BadCode => $index2d_init_bad . '$c() = $a(na => fooa, nb => foob);', BackCode => $index2d_init_good . ' $a(na => fooa, nb => foob) = $c();', BadBackCode => $index2d_init_bad . '$a(na => fooa, nb => foob) = $c();', Doc => $doc, BadDoc => 'index2d barfs if either of the index values are bad.', ); # indexND: CED 2-Aug-2002 pp_add_exported('','indexND indexNDb'); pp_addpm(<<'EOD-indexND'); =head2 indexNDb =for ref Backwards-compatibility alias for indexND =head2 indexND =for ref Find selected elements in an N-D ndarray, with optional boundary handling =for example $out = $source->indexND( $index, [$method] ) $source = 10*xvals(10,10) + yvals(10,10); $index = pdl([[2,3],[4,5]],[[6,7],[8,9]]); print $source->indexND( $index ); [ [23 45] [67 89] ] IndexND collapses C<$index> by lookup into C<$source>. The 0th dimension of C<$index> is treated as coordinates in C<$source>, and the return value has the same dimensions as the rest of C<$index>. The returned elements are looked up from C<$source>. Dataflow works -- propagated assignment flows back into C<$source>. IndexND and IndexNDb were originally separate routines but they are both now implemented as a call to L, and have identical syntax to one another. SEE ALSO: L returns N-D indices into a multidimensional PDL, suitable for feeding to this. =cut sub PDL::indexND { my($source,$index, $boundary) = @_; return PDL::range($source,$index,undef,$boundary); } *PDL::indexNDb = \&PDL::indexND; EOD-indexND pp_addpm(<<'EOD-range'); sub PDL::range { my($source,$ind,$sz,$bound) = @_; # Convert to indx type up front (also handled in rangeb if necessary) my $index = (ref $ind && UNIVERSAL::isa($ind,'PDL') && $ind->type eq 'indx') ? $ind : indx($ind); my $size = defined($sz) ? PDL->pdl($sz) : undef; # Handle empty PDL case: return a properly constructed Empty. if($index->isempty) { my @sdims= $source->dims; splice(@sdims, 0, $index->dim(0) + ($index->dim(0)==0)); # added term is to treat Empty[0] like a single empty coordinate unshift(@sdims, $size->list) if(defined($size)); return PDL->new_from_specification(0 x ($index->ndims-1), @sdims); } $index = $index->dummy(0,1) unless $index->ndims; # Pack boundary string if necessary if(defined $bound) { if(ref $bound eq 'ARRAY') { my ($s,$el); foreach $el(@$bound) { barf "Illegal boundary value '$el' in range" unless( $el =~ m/^([0123fFtTeEpPmM])/ ); $s .= $1; } $bound = $s; } elsif($bound !~ m/^[0123ftepx]+$/ && $bound =~ m/^([0123ftepx])/i ) { $bound = $1; } } no warnings; # shut up about passing undef into rangeb $source->rangeb($index,$size,$bound); } EOD-range =head2 range =cut pp_def( 'rangeb', OtherPars => 'pdl *ind_pdl; SV *size; SV *boundary_sv', Doc => <<'EOD', =for ref Engine for L =for example Same calling convention as L, but you must supply all parameters. C is marginally faster as it makes a direct PP call, avoiding the perl argument-parsing step. =cut =head2 range =for ref Extract selected chunks from a source ndarray, with boundary conditions =for example $out = $source->range($index,[$size,[$boundary]]) Returns elements or rectangular slices of the original ndarray, indexed by the C<$index> ndarray. C<$source> is an N-dimensional ndarray, and C<$index> is an ndarray whose first dimension has size up to N. Each row of C<$index> is treated as coordinates of a single value or chunk from C<$source>, specifying the location(s) to extract. If you specify a single index location, then range is essentially an expensive slice, with controllable boundary conditions. B C<$index> and C<$size> can be ndarrays or array refs such as you would feed to L and its ilk. If C<$index>'s 0th dimension has size higher than the number of dimensions in C<$source>, then C<$source> is treated as though it had trivial dummy dimensions of size 1, up to the required size to be indexed by C<$index> -- so if your source array is 1-D and your index array is a list of 3-vectors, you get two dummy dimensions of size 1 on the end of your source array. You can extract single elements or N-D rectangular ranges from C<$source>, by setting C<$size>. If C<$size> is undef or zero, then you get a single sample for each row of C<$index>. This behavior is similar to L, which is in fact implemented as a call to L. If C<$size> is positive then you get a range of values from C<$source> at each location, and the output has extra dimensions allocated for them. C<$size> can be a scalar, in which case it applies to all dimensions, or an N-vector, in which case each element is applied independently to the corresponding dimension in C<$source>. See below for details. C<$boundary> is a number, string, or list ref indicating the type of boundary conditions to use when ranges reach the edge of C<$source>. If you specify no boundary conditions the default is to forbid boundary violations on all axes. If you specify exactly one boundary condition, it applies to all axes. If you specify more (as elements of a list ref, or as a packed string, see below), then they apply to dimensions in the order in which they appear, and the last one applies to all subsequent dimensions. (This is less difficult than it sounds; see the examples below). =over 3 =item 0 (synonyms: 'f','forbid') B<(default)> Ranges are not allowed to cross the boundary of the original PDL. Disallowed ranges throw an error. The errors are thrown at evaluation time, not at the time of the range call (this is the same behavior as L). =item 1 (synonyms: 't','truncate') Values outside the original ndarray get BAD if you've got bad value support compiled into your PDL and set the badflag for the source PDL; or 0 if you haven't (you must set the badflag if you want BADs for out of bound values, otherwise you get 0). Reverse dataflow works OK for the portion of the child that is in-bounds. The out-of-bounds part of the child is reset to (BAD|0) during each dataflow operation, but execution continues. =item 2 (synonyms: 'e','x','extend') Values that would be outside the original ndarray point instead to the nearest allowed value within the ndarray. See the CAVEAT below on mappings that are not single valued. =item 3 (synonyms: 'p','periodic') Periodic boundary conditions apply: the numbers in $index are applied, strict-modulo the corresponding dimensions of $source. This is equivalent to duplicating the $source ndarray throughout N-D space. See the CAVEAT below about mappings that are not single valued. =item 4 (synonyms: 'm','mirror') Mirror-reflection periodic boundary conditions apply. See the CAVEAT below about mappings that are not single valued. =back The boundary condition identifiers all begin with unique characters, so you can feed in multiple boundary conditions as either a list ref or a packed string. (The packed string is marginally faster to run). For example, the four expressions [0,1], ['forbid','truncate'], ['f','t'], and 'ft' all specify that violating the boundary in the 0th dimension throws an error, and all other dimensions get truncated. If you feed in a single string, it is interpreted as a packed boundary array if all of its characters are valid boundary specifiers (e.g. 'pet'), but as a single word-style specifier if they are not (e.g. 'forbid'). B The output threads over both C<$index> and C<$source>. Because implicit threading can happen in a couple of ways, a little thought is needed. The returned dimension list is stacked up like this: (index thread dims), (index dims (size)), (source thread dims) The first few dims of the output correspond to the extra dims of C<$index> (beyond the 0 dim). They allow you to pick out individual ranges from a large, threaded collection. The middle few dims of the output correspond to the size dims specified in C<$size>, and contain the range of values that is extracted at each location in C<$source>. Every nonzero element of C<$size> is copied to the dimension list here, so that if you feed in (for example) C<$size = [2,0,1]> you get an index dim list of C<(2,1)>. The last few dims of the output correspond to extra dims of C<$source> beyond the number of dims indexed by C<$index>. These dims act like ordinary thread dims, because adding more dims to C<$source> just tacks extra dims on the end of the output. Each source thread dim ranges over the entire corresponding dim of C<$source>. B: Dataflow is bidirectional. B: Here are basic examples of C operation, showing how to get ranges out of a small matrix. The first few examples show extraction and selection of individual chunks. The last example shows how to mark loci in the original matrix (using dataflow). pdl> $src = 10*xvals(10,5)+yvals(10,5) pdl> print $src->range([2,3]) # Cut out a single element 23 pdl> print $src->range([2,3],1) # Cut out a single 1x1 block [ [23] ] pdl> print $src->range([2,3], [2,1]) # Cut a 2x1 chunk [ [23 33] ] pdl> print $src->range([[2,3]],[2,1]) # Trivial list of 1 chunk [ [ [23] [33] ] ] pdl> print $src->range([[2,3],[0,1]], [2,1]) # two 2x1 chunks [ [ [23 1] [33 11] ] ] pdl> # A 2x2 collection of 2x1 chunks pdl> print $src->range([[[1,1],[2,2]],[[2,3],[0,1]]],[2,1]) [ [ [ [11 22] [23 1] ] [ [21 32] [33 11] ] ] ] pdl> $src = xvals(5,3)*10+yvals(5,3) pdl> print $src->range(3,1) # Thread over y dimension in $src [ [30] [31] [32] ] pdl> $src = zeroes(5,4); pdl> $src->range(pdl([2,3],[0,1]),pdl(2,1)) .= xvals(2,2,1) + 1 pdl> print $src [ [0 0 0 0 0] [2 2 0 0 0] [0 0 0 0 0] [0 0 1 1 0] ] B: It's quite possible to select multiple ranges that intersect. In that case, modifying the ranges doesn't have a guaranteed result in the original PDL -- the result is an arbitrary choice among the valid values. For some things that's OK; but for others it's not. In particular, this doesn't work: pdl> $photon_list = new PDL::RandVar->sample(500)->reshape(2,250)*10 pdl> histogram = zeroes(10,10) pdl> histogram->range($photon_list,1)++; #not what you wanted The reason is that if two photons land in the same bin, then that bin doesn't get incremented twice. (That may get fixed in a later version...) B: If C<$index> has too many dimensions compared to C<$source>, then $source is treated as though it had dummy dimensions of size 1, up to the required number of dimensions. These virtual dummy dimensions have the usual boundary conditions applied to them. If the 0 dimension of C<$index> is ludicrously large (if its size is more than 5 greater than the number of dims in the source PDL) then range will insist that you specify a size in every dimension, to make sure that you know what you're doing. That catches a common error with range usage: confusing the initial dim (which is usually small) with another index dim (perhaps of size 1000). If the index variable is Empty, then range() always returns the Empty PDL. If the index variable is not Empty, indexing it always yields a boundary violation. All non-barfing conditions are treated as truncation, since there are no actual data to return. B: Because C isn't an affine transformation (it involves lookup into a list of N-D indices), it is somewhat memory-inefficient for long lists of ranges, and keeping dataflow open is much slower than for affine transformations (which don't have to copy data around). Doing operations on small subfields of a large range is inefficient because the engine must flow the entire range back into the original PDL with every atomic perl operation, even if you only touch a single element. One way to speed up such code is to sever your range, so that PDL doesn't have to copy the data with each operation, then copy the elements explicitly at the end of your loop. Here's an example that labels each region in a range sequentially, using many small operations rather than a single xvals assignment: ### How to make a collection of small ops run fast with range... $x = $data->range($index, $sizes, $bound)->sever; $aa = $data->range($index, $sizes, $bound); map { $x($_ - 1) .= $_; } (1..$x->nelem); # Lots of little ops $aa .= $x; C is a perl front-end to a PP function, C. Calling C is marginally faster but requires that you include all arguments. DEVEL NOTES * index thread dimensions are effectively clumped internally. This makes it easier to loop over the index array but a little more brain-bending to tease out the algorithm. =cut EOD HandleBad => 1, TwoWay => 1, P2Child => 1, # # rdim: dimensionality of each range (0 dim of index PDL) # # ntsize: number of nonzero size dimensions # sizes: array of range sizes, indexed (0..rdim-1). A zero element means # that the dimension is omitted from the child dim list. # corners: parent coordinates of each corner, running fastest over coord index. # (indexed 0 .. (nitems-1)*(rdim)+rdim-1) # nitems: total number of list elements (product of itdims) # itdim: number of index thread dimensions # itdims: Size of each index thread dimension, indexed (0..itdim-1) # # bsize: Number of independently specified boundary conditions # nsizes: Number of independently specified range dim sizes # boundary: Array containing all the boundary condition specs # indord: Order/size of the indexing dim (0th dim of $index) Comp => 'PDL_Indx rdim; PDL_Indx nitems; PDL_Indx itdim; PDL_Indx ntsize; PDL_Indx bsize; PDL_Indx nsizes; PDL_Indx sizes[$COMP(rdim)]; PDL_Indx itdims[$COMP(itdim)]; PDL_Indx corners[$COMP(rdim) * $COMP(nitems)]; char boundary[$COMP(rdim)]; ', MakeComp => <<'EOD-MakeComp', pdl *size_pdl; PDL_RETERROR(PDL_err, PDL->make_physdims(ind_pdl)); /* Generalized empties are ok, but not in the special 0 dim (the index vector) */ if(ind_pdl->dims[0] == 0) { $CROAK("can't handle Empty indices -- call range instead"); } /*** * Ensure that the index is a PDL_Indx. If there's no loss of information, * just upgrade it -- otherwise, make a temporary copy. */ switch(ind_pdl->datatype) { default: /* Most types: */ ind_pdl = PDL->hard_copy(ind_pdl); /* copy and fall through */ if (!ind_pdl) $CROAK("Error in hard_copy"); case PDL_SB: case PDL_B: case PDL_S: case PDL_US: case PDL_L: case PDL_UL: case PDL_LL: case PDL_ULL: PDL_RETERROR(PDL_err, PDL->converttype(ind_pdl,PDL_IND)); /* convert in place. */ break; case PDL_IND: PDL_RETERROR(PDL_err, PDL->make_physical(ind_pdl)); break; } /*** * Figure sizes of the COMP arrrays and allocate them. */ { PDL_Indx i,nitems; $COMP(rdim) = ind_pdl->ndims ? ind_pdl->dims[0] : 1; for(i=nitems=1; i < ind_pdl->ndims; i++) /* Accumulate item list size */ nitems *= ind_pdl->dims[i]; $COMP(nitems) = nitems; $COMP(itdim) = ind_pdl->ndims ? ind_pdl->ndims - 1 : 0; $DOCOMPALLOC(); } /*** * Fill in the boundary condition array */ { char *bstr; STRLEN blen; bstr = SvPV(boundary_sv,blen); if(blen == 0) { /* If no boundary is specified then every dim gets forbidden */ int i; for (i=0;i<$COMP(rdim);i++) $COMP(boundary[i]) = 0; } else { int i; for(i=0;i<$COMP(rdim);i++) { switch(bstr[i < blen ? i : blen-1 ]) { case '0': case 'f': case 'F': /* forbid */ $COMP(boundary[i]) = 0; break; case '1': case 't': case 'T': /* truncate */ $COMP(boundary[i]) = 1; break; case '2': case 'e': case 'E': /* extend */ $COMP(boundary[i]) = 2; break; case '3': case 'p': case 'P': /* periodic */ $COMP(boundary[i]) = 3; break; case '4': case 'm': case 'M': /* mirror */ $COMP(boundary[i]) = 4; break; default: { /* No need to check if i < blen -- this will barf out the * first time it gets hit. */ $CROAK("Unknown boundary condition '%c' in range",bstr[i]); } break; } // end of switch } } } /*** * Store the sizes of the index-thread dims */ { PDL_Indx i; PDL_Indx nd = ind_pdl->ndims - 1; for(i=0; i < nd ; i++) $COMP(itdims[i]) = ind_pdl->dims[i+1]; } /*** * Check and condition the size ndarray, and store sizes of the ranges */ { PDL_Indx i,ntsize; if( (size == NULL) || (size == &PL_sv_undef) ) { // NO size was passed in, not normally executed even if you passed in no size to range(), // as range() generates a size array... for(i=0;i<$COMP(rdim);i++) $COMP(sizes[i]) = 0; } else { /* Normal case with sizes present in a PDL */ if(!(size_pdl = PDL->SvPDLV(size))) /* assignment */ $CROAK("Unable to convert size to a PDL"); if(size_pdl->nvals == 0) { // no values in the size_pdl - Empty or Null. Just copy 0s to all the range dims for(i=0;i<$COMP(rdim);i++) $COMP(sizes[i]) = 0; } else { // Convert size PDL to PDL_IND to support indices switch(size_pdl->datatype) { default: /* Most types: */ size_pdl = PDL->hard_copy(size_pdl); /* copy and fall through */ if (!size_pdl) $CROAK("Error in hard_copy"); case PDL_SB: case PDL_B: case PDL_S: case PDL_US: case PDL_L: case PDL_UL: case PDL_LL: case PDL_ULL: PDL_RETERROR(PDL_err, PDL->converttype(size_pdl,PDL_IND)); /* convert in place. */ break; case PDL_IND: PDL_RETERROR(PDL_err, PDL->make_physical(size_pdl)); break; } $COMP(nsizes) = size_pdl->nvals; /* Store for later permissiveness check */ /* Copy the sizes, or die if they're the wrong shape */ if(size_pdl->nvals == 1) { for(i=0;i<$COMP(rdim);i++) { $COMP(sizes[i]) = *((PDL_Indx *)(size_pdl->data)); } /* Check for nonnegativity of sizes. The rdim>0 mask ensures that */ /* we don't barf on the Empty PDL (as an index). */ if( $COMP(rdim) > 0 && $COMP(sizes[0]) < 0 ) { $CROAK("Negative range size is not allowed\n"); } } else if( size_pdl->nvals <= $COMP(rdim) && size_pdl->ndims == 1) { for(i=0;i<$COMP(rdim);i++) { $COMP(sizes[i]) = ( (i < size_pdl->nvals) ? ((PDL_Indx *)(size_pdl->data))[i] : 0 ); if($COMP(sizes[i]) < 0) $CROAK("Negative range sizes are not allowed\n"); } } else { $CROAK("Size must match index's 0th dim\n"); } } /* end of nonempty size-ndarray code */ } /* end of defined-size-ndarray code */ /* Insert the number of nontrivial sizes (these get output dimensions) */ for(i=ntsize=0;i<$COMP(rdim);i++) if($COMP(sizes[i])) ntsize++; $COMP(ntsize) = ntsize; } /*** * Stash coordinates of the corners */ PDL_Indx j,k,ioff, iter[$COMP(itdim)]; /* initialize iterator to loop over index threads */ PDL_Indx *cptr = iter; for(k=0;k<$COMP(itdim);k++) *(cptr++) = 0; cptr = $COMP(corners); do { /* accumulate offset into the index from the iterator */ for(k=ioff=0;k<$COMP(itdim);k++) ioff += iter[k] * ind_pdl->dimincs[k+1]; /* Loop over the 0th dim of index, copying coords. */ /* This is the natural place to check for permissive ranging; too */ /* bad we don't have access to the parent ndarray here... */ for(j=0;j<$COMP(rdim);j++) *(cptr++) = ((PDL_Indx *)(ind_pdl->data))[ioff + ind_pdl->dimincs[0] * j]; /* Increment the iterator -- the test increments, the body carries. */ for(k=0; k<$COMP(itdim) && (++(iter[k]))>=($COMP(itdims)[k]) ;k++) iter[k] = 0; } while(k<$COMP(itdim)); EOD-MakeComp RedoDims => <<'EOD-RedoDims' , PDL_Indx stdim = $PARENT(ndims) - $COMP(rdim); PDL_Indx dim,inc; PDL_Indx i,rdvalid; // Speed bump for ludicrous cases if( $COMP(rdim) > $PARENT(ndims)+5 && $COMP(nsizes) != $COMP(rdim)) { $CROAK("Ludicrous number of extra dims in range index; leaving child null.\n (%d implicit dims is > 5; index has %d dims; source has %d dim%s.)\n This often means that your index PDL is incorrect. To avoid this message,\n allocate dummy dims in the source or use %d dims in range's size field.\n",$COMP(rdim)-$PARENT(ndims),$COMP(rdim),$PARENT(ndims),($PARENT(ndims))>1?"s":"",$COMP(rdim)); } if(stdim < 0) stdim = 0; /* Set dimensionality of child */ $CHILD(ndims) = $COMP(itdim) + $COMP(ntsize) + stdim; $SETNDIMS($COMP(itdim)+$COMP(ntsize)+stdim); inc = 1; /* Copy size dimensions to child, crunching as we go. */ dim = $COMP(itdim); for(i=rdvalid=0;i<$COMP(rdim);i++) { if($COMP(sizes[i])) { rdvalid++; $CHILD(dimincs[dim]) = inc; inc *= ($CHILD(dims[dim++]) = $COMP(sizes[i])); /* assignment */ } } /* Copy index thread dimensions to child */ for(dim=0; dim<$COMP(itdim); dim++) { $CHILD(dimincs[dim]) = inc; inc *= ($CHILD(dims[dim]) = $COMP(itdims[dim])); /* assignment */ } /* Copy source thread dimensions to child */ dim = $COMP(itdim) + rdvalid; for(i=0;i <<'EOD-EquivCPOffsCode', PDL_Indx *ip; /* vector iterator */ PDL_Indx *sp; /* size vector including stdims */ PDL_Indx *coords; /* current coordinates */ PDL_Indx k; /* index */ PDL_Indx item; /* index thread iterator */ PDL_Indx pdim = $PDL(PARENT)->ndims; PDL_Indx rdim = $COMP(rdim); PDL_Indx prdim = PDLMIN(rdim,pdim); PDL_Indx iter2[pdim * 2 + rdim]; PDL_Indx *sizes = iter2 + pdim; coords = sizes + pdim; /* Figure out size vector */ for(ip = $COMP(sizes), sp = sizes, k=0; kdims[k]; /* Loop over all the ranges in the index list */ for(item=0; item<$COMP(nitems); item++) { /* initialize in-range iterator to loop within each range */ for(ip = iter2, k=0; k= $PDL(PARENT)->dims[k]) { switch($COMP(boundary[k])) { case 0: /* no boundary breakage allowed */ $CROAK("index out-of-bounds in range (index vector #%ld)",item); break; case 1: /* truncation */ trunc = 1; break; case 2: /* extension -- crop */ ck = (ck >= $PDL(PARENT)->dims[k]) ? $PDL(PARENT)->dims[k]-1 : 0; break; case 3: /* periodic -- mod it */ ck %= $PDL(PARENT)->dims[k]; if(ck < 0) /* Fix mod breakage in C */ ck += $PDL(PARENT)->dims[k]; break; case 4: /* mirror -- reflect off the edges */ ck += $PDL(PARENT)->dims[k]; ck %= ($PDL(PARENT)->dims[k] * 2); if(ck < 0) /* Fix mod breakage in C */ ck += $PDL(PARENT)->dims[k]*2; ck -= $PDL(PARENT)->dims[k]; if(ck < 0) { ck *= -1; ck -= 1; } break; default: $CROAK("Unknown boundary condition in range -- bug alert!"); break; } } coords[k] = ck; } /* Check extra dimensions -- pick up where k left off... */ for( ; k < rdim ; k++) { /* Check for indexing off the end of the dimension list */ PDL_Indx ck = iter2[k] + $COMP(corners[ item * rdim + k ]) ; switch($COMP(boundary[k])) { case 0: /* No boundary breakage allowed -- nonzero corners cause barfage */ if(ck != 0) $CROAK("Too many dims in range index (and you've forbidden boundary violations)"); break; case 1: /* truncation - just truncate if the corner is nonzero */ trunc |= (ck != 0); break; case 2: /* extension -- ignore the corner (same as 3) */ case 3: /* periodic -- ignore the corner */ case 4: /* mirror -- ignore the corner */ ck = 0; break; default: $CROAK("Unknown boundary condition in range -- bug alert!"); break; } } /* Find offsets into the child and parent arrays, from the N-D coords */ /* Note we only loop over real source dims (prdim) to accumulate -- */ /* because the offset is trivial and/or we're truncating for virtual */ /* dims caused by permissive ranging. */ coff = $PDL(CHILD)->dimincs[0] * item; for(k2 = $COMP(itdim), poff = k = 0; k < prdim; k++) { poff += coords[k]*$PDL(PARENT)->dimincs[k]; if($COMP(sizes[k])) coff += iter2[k] * $PDL(CHILD)->dimincs[k2++]; } /* Loop the copy over all the source thread dims (above rdim). */ do { PDL_Indx poff1 = poff; PDL_Indx coff1 = coff; /* Accumulate the offset due to source threading */ for(k2 = $COMP(itdim) + $COMP(ntsize), k = rdim; k < pdim; k++) { poff1 += iter2[k] * $PDL(PARENT)->dimincs[k]; coff1 += iter2[k] * $PDL(CHILD)->dimincs[k2++]; } /* Finally -- make the copy * EQUIVCPTRUNC works like EQUIVCPOFFS but with checking for * out-of-bounds conditions. */ $EQUIVCPTRUNC(coff1,poff1,trunc); /* Increment the source thread iterator */ for( k=$COMP(rdim); k < pdim && (++(iter2[k]) >= $PDL(PARENT)->dims[k]); k++) iter2[k] = 0; } while(k < pdim); /* end of source-thread iteration */ /* Increment the in-range iterator */ for(k = 0; k < $COMP(rdim) && (++(iter2[k]) >= $COMP(sizes[k])); k++) iter2[k] = 0; } while(k < $COMP(rdim)); /* end of main iteration */ } /* end of item do loop */ EOD-EquivCPOffsCode ); =head2 rld =cut pp_def( 'rld', GenericTypes => [ppdefs_all], Pars=>'indx a(n); b(n); [o]c(m);', PMCode =><<'EOD', sub PDL::rld { my ($x,$y) = @_; my ($c); if ($#_ == 2) { $c = $_[2]; } else { # XXX Need to improve emulation of threading in auto-generating c my ($size) = $x->sumover->max->sclr; my (@dims) = $x->dims; shift @dims; $c = $y->zeroes($size,@dims); } &PDL::_rld_int($x,$y,$c); $c; } EOD Code=>' PDL_Indx i,j=0,an; $GENERIC(b) bv; loop (n) %{ an = $a(); bv = $b(); for (i=0;ij) = bv; j++; } %}', Doc => <<'EOD' =for ref Run-length decode a vector Given a vector C<$x> of the numbers of instances of values C<$y>, run-length decode to C<$c>. =for example rld($x,$y,$c=null); =cut EOD ); =head2 rle =cut pp_def( 'rle', GenericTypes => [ppdefs_all], Pars=>'c(n); indx [o]a(m); [o]b(m);', #this RedoDimsCode sets $SIZE(m)==$SIZE(n), but the slice in the PMCode below makes m<=n. RedoDimsCode=>'$SIZE(m)=$PDL(c)->dims[0];', PMCode=><<'EOC', sub PDL::rle { my $c = shift; my ($x,$y) = @_==2 ? @_ : (null,null); PDL::_rle_int($c,$x,$y); my $max_ind = ($c->ndims<2) ? ($x!=0)->sumover-1 : ($x!=0)->clump(1..$x->ndims-1)->sumover->max->sclr-1; return ($x->slice("0:$max_ind"),$y->slice("0:$max_ind")); } EOC Code=>' PDL_Indx j=0; $GENERIC(c) cv, clv; clv = $c(n=>0); $b(m=>0) = clv; $a(m=>0) = 0; loop (n) %{ cv = $c(); if (cv == clv) { $a(m=>j)++; } else { j++; $b(m=>j) = clv = cv; $a(m=>j) = 1; } %} for (j++;j<$SIZE(m);j++) { $a(m=>j) = 0; $b(m=>j) = 0; } ', Doc => <<'EOD' =for ref Run-length encode a vector Given vector C<$c>, generate a vector C<$x> with the number of each element, and a vector C<$y> of the unique values. New in PDL 2.017, only the elements up to the first instance of C<0> in C<$x> are returned, which makes the common use case of a 1-dimensional C<$c> simpler. For threaded operation, C<$x> and C<$y> will be large enough to hold the largest row of C<$y>, and only the elements up to the first instance of C<0> in each row of C<$x> should be considered. =for example $c = floor(4*random(10)); rle($c,$x=null,$y=null); #or ($x,$y) = rle($c); #for $c of shape [10, 4]: $c = floor(4*random(10,4)); ($x,$y) = rle($c); #to see the results of each row one at a time: foreach (0..$c->dim(1)-1){ my ($as,$bs) = ($x(:,($_)),$y(:,($_))); my ($ta,$tb) = where($as,$bs,$as!=0); #only the non-zero elements of $x print $c(:,($_)) . " rle==> " , ($ta,$tb) , "\trld==> " . rld($ta,$tb) . "\n"; } # the inverse of (chance of all 6 3d6 rolls being >= each possible sum) ($nrolls, $ndice, $dmax) = (6, 3, 6); ($x, $x1) = (allaxisvals(($dmax) x $ndice)+1)->sumover->flat->qsort->rle; $y = $x->cumusumover; $yprob1x = $y->slice('-1:0')->double / $y->slice('(-1)'); $z = cat($x1, 1 / $yprob1x**$nrolls)->transpose; =cut EOD ); # the perl wrapper clump is now defined in Core.pm # this is just the low level interface pp_def( '_clump_int', OtherPars => 'int n', P2Child => 1, RedoDims => 'int i; PDL_Indx d1; /* truncate overly long clumps to just clump existing dimensions */ if($COMP(n) > $PARENT(ndims)) $COMP(n) = $PARENT(ndims); if($COMP(n) < -1) $COMP(n) = $PARENT(ndims) + $COMP(n) + 1; PDL_Indx nrem = ($COMP(n) == -1 ? $PARENT(threadids[0]) : $COMP(n)); $SETNDIMS($PARENT(ndims) - nrem + 1); d1=1; for(i=0; i ' PDL_Indx i; for(i=0; i<$PDL(CHILD)->nvals; i++) { $EQUIVCPOFFS(i,i); } ', TwoWay => 1, Doc => 'internal', ); =head2 xchg =cut pp_def( 'xchg', OtherPars => 'PDL_Indx n1; PDL_Indx n2;', TwoWay => 1, P2Child => 1, AffinePriv => 1, EquivDimCheck => 'if ($COMP(n1) <0) $COMP(n1) += $PARENT(threadids[0]); if ($COMP(n2) <0) $COMP(n2) += $PARENT(threadids[0]); if (PDLMIN($COMP(n1),$COMP(n2)) <0 || PDLMAX($COMP(n1),$COMP(n2)) >= $PARENT(threadids[0])) $CROAK("One of dims %d, %d out of range: should be 0<=dim<%d", $COMP(n1),$COMP(n2),$PARENT(threadids[0]));', EquivPDimExpr => '(($CDIM == $COMP(n1)) ? $COMP(n2) : ($CDIM == $COMP(n2)) ? $COMP(n1) : $CDIM)', Doc => <<'EOD', =for ref exchange two dimensions Negative dimension indices count from the end. The command =for example $y = $x->xchg(2,3); creates C<$y> to be like C<$x> except that the dimensions 2 and 3 are exchanged with each other i.e. $y->at(5,3,2,8) == $x->at(5,3,8,2) =cut EOD ); pp_addpm(<< 'EOD'); =head2 reorder =for ref Re-orders the dimensions of a PDL based on the supplied list. Similar to the L method, this method re-orders the dimensions of a PDL. While the L method swaps the position of two dimensions, the reorder method can change the positions of many dimensions at once. =for usage # Completely reverse the dimension order of a 6-Dim array. $reOrderedPDL = $pdl->reorder(5,4,3,2,1,0); The argument to reorder is an array representing where the current dimensions should go in the new array. In the above usage, the argument to reorder C<(5,4,3,2,1,0)> indicates that the old dimensions (C<$pdl>'s dims) should be re-arranged to make the new pdl (C<$reOrderPDL>) according to the following: Old Position New Position ------------ ------------ 5 0 4 1 3 2 2 3 1 4 0 5 You do not need to specify all dimensions, only a complete set starting at position 0. (Extra dimensions are left where they are). This means, for example, that you can reorder() the X and Y dimensions of an image, and not care whether it is an RGB image with a third dimension running across color plane. =for example Example: pdl> $x = sequence(5,3,2); # Create a 3-d Array pdl> p $x [ [ [ 0 1 2 3 4] [ 5 6 7 8 9] [10 11 12 13 14] ] [ [15 16 17 18 19] [20 21 22 23 24] [25 26 27 28 29] ] ] pdl> p $x->reorder(2,1,0); # Reverse the order of the 3-D PDL [ [ [ 0 15] [ 5 20] [10 25] ] [ [ 1 16] [ 6 21] [11 26] ] [ [ 2 17] [ 7 22] [12 27] ] [ [ 3 18] [ 8 23] [13 28] ] [ [ 4 19] [ 9 24] [14 29] ] ] The above is a simple example that could be duplicated by calling C<$x-Exchg(0,2)>, but it demonstrates the basic functionality of reorder. As this is an index function, any modifications to the result PDL will change the parent. =cut sub PDL::reorder { my ($pdl,@newDimOrder) = @_; my $arrayMax = $#newDimOrder; #Error Checking: if( $pdl->getndims < scalar(@newDimOrder) ){ my $errString = "PDL::reorder: Number of elements (".scalar(@newDimOrder).") in newDimOrder array exceeds\n"; $errString .= "the number of dims in the supplied PDL (".$pdl->getndims.")"; barf($errString); } # Check to make sure all the dims are within bounds for my $i(0..$#newDimOrder) { my $dim = $newDimOrder[$i]; if($dim < 0 || $dim > $#newDimOrder) { my $errString = "PDL::reorder: Dim index $newDimOrder[$i] out of range in position $i\n(range is 0-$#newDimOrder)"; barf($errString); } } # Checking that they are all present and also not duplicated is done by thread() [I think] # a quicker way to do the reorder return $pdl->thread(@newDimOrder)->unthread(0); } EOD =head2 mv =cut pp_addhdr(<<'EOF'); #define EQUIVDIM(dima,dimb,cdim,inc) \ ((cdim < PDLMIN(dima,dimb) || cdim > PDLMAX(dima,dimb)) ? \ cdim : ((cdim == dimb) ? dima : cdim + inc)) EOF pp_def( 'mv', OtherPars => 'PDL_Indx n1; PDL_Indx n2;', TwoWay => 1, P2Child => 1, AffinePriv => 1, EquivDimCheck => 'if ($COMP(n1) <0) $COMP(n1) += $PARENT(threadids[0]); if ($COMP(n2) <0) $COMP(n2) += $PARENT(threadids[0]); if (PDLMIN($COMP(n1),$COMP(n2)) <0 || PDLMAX($COMP(n1),$COMP(n2)) >= $PARENT(threadids[0])) $CROAK("One of dims %d, %d out of range: should be 0<=dim<%d", $COMP(n1),$COMP(n2),$PARENT(threadids[0]));', EquivPDimExpr => '( $COMP(n1) == $COMP(n2) ? $CDIM : $COMP(n1) < $COMP(n2) ? EQUIVDIM($COMP(n1),$COMP(n2),$CDIM,1) : EQUIVDIM($COMP(n1),$COMP(n2),$CDIM,-1) )', Doc => << 'EOD', =for ref move a dimension to another position The command =for example $y = $x->mv(4,1); creates C<$y> to be like C<$x> except that the dimension 4 is moved to the place 1, so: $y->at(1,2,3,4,5,6) == $x->at(1,5,2,3,4,6); The other dimensions are moved accordingly. Negative dimension indices count from the end. =cut EOD ); pp_addhdr << 'EOH'; #define sign(x) ( (x) < 0 ? -1 : 1) EOH pp_addpm(<<'EOD' =head2 using =for ref Returns array of column numbers requested =for usage line $pdl->using(1,2); Plot, as a line, column 1 of C<$pdl> vs. column 2 =for example pdl> $pdl = rcols("file"); pdl> line $pdl->using(1,2); =cut *using = \&PDL::using; sub PDL::using { my ($x,@ind)=@_; @ind = list $ind[0] if (blessed($ind[0]) && $ind[0]->isa('PDL')); foreach (@ind) { $_ = $x->slice("($_)"); } @ind; } EOD ); pp_add_exported('', 'using'); pp_addhdr(<*b) return 1; else if(*a==*b) return 0; else return -1; } END ); pp_def( 'diagonal', P2Child => 1, TwoWay => 1, AffinePriv => 1, OtherPars => 'PDL_Indx whichdims[]', MakeComp => pp_line_numbers(__LINE__-1, ' if ($COMP(whichdims_count) < 1) $CROAK("must have at least 1 dimension"); qsort($COMP(whichdims), $COMP(whichdims_count), sizeof(PDL_Indx), cmp_pdll); '), RedoDims => pp_line_numbers(__LINE__-1, ' int nthp,nthc,nthd; int cd = $COMP(whichdims[0]); $SETNDIMS($PARENT(ndims)-$COMP(whichdims_count)+1); $DOPRIVALLOC(); $PRIV(offs) = 0; if ($COMP(whichdims)[$COMP(whichdims_count)-1] >= $PARENT(ndims) || $COMP(whichdims)[0] < 0) $CROAK("dim out of range"); nthd=0; nthc=0; for(nthp=0; nthp<$PARENT(ndims); nthp++) if (nthd < $COMP(whichdims_count) && nthp == $COMP(whichdims)[nthd]) { if (!nthd) { $CHILD(dims)[cd] = $PARENT(dims)[cd]; nthc++; $PRIV(incs)[cd] = 0; } if (nthd && $COMP(whichdims)[nthd] == $COMP(whichdims)[nthd-1]) $CROAK("dims must be unique"); nthd++; /* advance pointer into whichdims */ if($CHILD(dims)[cd] != $PARENT(dims)[nthp]) { $CROAK("Different dims %d and %d", $CHILD(dims)[cd], $PARENT(dims)[nthp]); } $PRIV(incs)[cd] += $PARENT(dimincs)[nthp]; } else { $PRIV(incs)[nthc] = $PARENT(dimincs)[nthp]; $CHILD(dims)[nthc] = $PARENT(dims)[nthp]; nthc++; } $SETDIMS(); '), PMCode => << 'EOD', sub PDL::diagonal { shift->_diagonal_int(my $o=PDL->null, \@_); $o } EOD Doc => << 'EOD', =for ref Returns the multidimensional diagonal over the specified dimensions. The diagonal is placed at the first (by number) dimension that is diagonalized. The other diagonalized dimensions are removed. So if C<$x> has dimensions C<(5,3,5,4,6,5)> then after =for usage $d = $x->diagonal(dim1, dim2,...) =for example $y = $x->diagonal(0,2,5); the ndarray C<$y> has dimensions C<(5,3,4,6)> and C<$y-Eat(2,1,0,1)> refers to C<$x-Eat(2,1,2,0,1,2)>. NOTE: diagonal doesn't handle threadids correctly. XXX FIX pdl> $x = zeroes(3,3,3); pdl> ($y = $x->diagonal(0,1))++; pdl> p $x [ [ [1 0 0] [0 1 0] [0 0 1] ] [ [1 0 0] [0 1 0] [0 0 1] ] [ [1 0 0] [0 1 0] [0 0 1] ] ] =cut EOD ); =head2 lags =cut pp_def( 'lags', Doc => <<'EOD', =for ref Returns an ndarray of lags to parent. Usage: =for usage $lags = $x->lags($nthdim,$step,$nlags); I.e. if C<$x> contains [0,1,2,3,4,5,6,7] then =for example $y = $x->lags(0,2,2); is a (5,2) matrix [2,3,4,5,6,7] [0,1,2,3,4,5] This order of returned indices is kept because the function is called "lags" i.e. the nth lag is n steps behind the original. C<$step> and C<$nlags> must be positive. C<$nthdim> can be negative and will then be counted from the last dim backwards in the usual way (-1 = last dim). =cut EOD P2Child => 1, TwoWay => 1, AffinePriv => 1, OtherPars => join('', map "PDL_Indx $_;", qw(nthdim step n)), RedoDims => ' PDL_Indx i; if ($COMP(nthdim) < 0) /* the usual conventions */ $COMP(nthdim) += $PARENT(ndims); if ($COMP(nthdim) < 0 || $COMP(nthdim) >= $PARENT(ndims)) $CROAK("dim out of range"); if ($COMP(n) < 1) $CROAK("number of lags must be positive"); if ($COMP(step) < 1) $CROAK("step must be positive"); $PRIV(offs) = 0; $SETNDIMS($PARENT(ndims)+1); $DOPRIVALLOC(); for(i=0; i<$COMP(nthdim); i++) { $CHILD(dims)[i] = $PARENT(dims)[i]; $PRIV(incs)[i] = $PARENT(dimincs)[i]; } $CHILD(dims)[i] = $PARENT(dims)[i] - $COMP(step) * ($COMP(n)-1); if ($CHILD(dims)[i] < 1) $CROAK("product of step size and number of lags too large"); $CHILD(dims)[i+1] = $COMP(n); $PRIV(incs)[i] = ($PARENT(dimincs)[i]); $PRIV(incs)[i+1] = - $PARENT(dimincs)[i] * $COMP(step); $PRIV(offs) += ($CHILD(dims)[i+1] - 1) * (-$PRIV(incs)[i+1]); i++; for(; i<$PARENT(ndims); i++) { $CHILD(dims)[i+1] = $PARENT(dims)[i]; $PRIV(incs)[i+1] = $PARENT(dimincs)[i]; } $SETDIMS(); ' ); =head2 splitdim =cut pp_def( 'splitdim', Doc => <<'EOD', =for ref Splits a dimension in the parent ndarray (opposite of L) After =for example $y = $x->splitdim(2,3); the expression $y->at(6,4,m,n,3,6) == $x->at(6,4,m+3*n) is always true (C has to be less than 3). =cut EOD P2Child => 1, TwoWay => 1, OtherPars => join('', map "PDL_Indx $_;", qw(nthdim nsp)), AffinePriv => 1, RedoDims => ' PDL_Indx i = $COMP(nthdim); PDL_Indx nsp = $COMP(nsp); if(nsp == 0) {$CROAK("Cannot split to 0\n");} if(i <0 || i >= $PARENT(ndims)) { $CROAK("nthdim %"IND_FLAG" must not be negative or greater or equal to number of dims %"IND_FLAG"\n", i, $PARENT(ndims)); } if(nsp > $PARENT(dims[i])) { $CROAK("nsp %"IND_FLAG" cannot be greater than dim %"IND_FLAG"\n", nsp, $PARENT(dims[i])); } $PRIV(offs) = 0; $SETNDIMS($PARENT(ndims)+1); $DOPRIVALLOC(); for(i=0; i<$COMP(nthdim); i++) { $CHILD(dims)[i] = $PARENT(dims)[i]; $PRIV(incs)[i] = $PARENT(dimincs)[i]; } $CHILD(dims)[i] = $COMP(nsp); $CHILD(dims)[i+1] = $PARENT(dims)[i] / $COMP(nsp); $PRIV(incs)[i] = $PARENT(dimincs)[i]; $PRIV(incs)[i+1] = $PARENT(dimincs)[i] * $COMP(nsp); i++; for(; i<$PARENT(ndims); i++) { $CHILD(dims)[i+1] = $PARENT(dims)[i]; $PRIV(incs)[i+1] = $PARENT(dimincs)[i]; } $SETDIMS(); ', ); my $rotate_code = ' PDL_Indx i,j; PDL_Indx n_size = $SIZE(n); if (n_size == 0) $CROAK("can not shift zero size ndarray (n_size is zero)"); j = ($shift()) % n_size; if (j < 0) j += n_size; for(i=0; i [ppdefs_all], Doc => <<'EOD', =for ref Shift vector elements along with wrap. Flows data back&forth. =cut EOD Pars=>'x(n); indx shift(); [oca]y(n)', DefaultFlow => 1, TwoWay => 1, Code=>$rotate_code.' $y(n=>j) = $x(n=>i); }', BackCode=>$rotate_code.' $x(n=>i) = $y(n=>j); } ' ); # This is a bit tricky. Hope I haven't missed any cases. pp_def( 'threadI', Doc => <<'EOD', =for ref internal Put some dimensions to a threadid. =for example $y = $x->threadI(0,1,5); # thread over dims 1,5 in id 1 =cut EOD P2Child => 1, TwoWay => 1, AffinePriv => 1, OtherPars => "PDL_Indx id; PDL_Indx whichdims[]", Comp => 'PDL_Indx nrealwhichdims', MakeComp => ' PDL_Indx i,j; $COMP(nrealwhichdims) = 0; for(i=0; i<$COMP(whichdims_count); i++) { for(j=i+1; j<$COMP(whichdims_count); j++) if($COMP(whichdims[i]) == $COMP(whichdims[j]) && $COMP(whichdims[i]) != -1) { $CROAK("duplicate arg %d %d %d", i,j,$COMP(whichdims[i])); } if($COMP(whichdims)[i] != -1) { $COMP(nrealwhichdims) ++; } } ', RedoDims => ' PDL_Indx nthc,i,j,flag; $SETNDIMS($PARENT(ndims)); $DOPRIVALLOC(); $PRIV(offs) = 0; nthc=0; for(i=0; i<$PARENT(ndims); i++) { flag=0; if($PARENT(nthreadids) > $COMP(id) && $COMP(id) >= 0 && i == $PARENT(threadids[$COMP(id)])) { nthc += $COMP(whichdims_count); } for(j=0; j<$COMP(whichdims_count); j++) { if($COMP(whichdims[j] == i)) {flag=1; break;} } if(flag) { continue; } $CHILD(dims[nthc]) = $PARENT(dims[i]); $PRIV(incs[nthc]) = $PARENT(dimincs[i]); nthc++; } for(i=0; i<$COMP(whichdims_count); i++) { int cdim,pdim; cdim = i + ($PARENT(nthreadids) > $COMP(id) && $COMP(id) >= 0? $PARENT(threadids[$COMP(id)]) : $PARENT(ndims)) - $COMP(nrealwhichdims); pdim = $COMP(whichdims[i]); if(pdim == -1) { $CHILD(dims[cdim]) = 1; $PRIV(incs[cdim]) = 0; } else { $CHILD(dims[cdim]) = $PARENT(dims[pdim]); $PRIV(incs[cdim]) = $PARENT(dimincs[pdim]); } } $SETDIMS(); PDL_RETERROR(PDL_err, PDL->reallocthreadids($CHILD_PTR(), PDLMAX($COMP(id)+1, $PARENT(nthreadids)))); for(i=0; i<$CHILD(nthreadids)-1; i++) { $CHILD(threadids[i]) = ($PARENT(nthreadids) > i ? $PARENT(threadids[i]) : $PARENT(ndims)) + (i <= $COMP(id) ? - $COMP(nrealwhichdims) : $COMP(whichdims_count) - $COMP(nrealwhichdims)); } $CHILD(threadids[$CHILD(nthreadids)-1]) = $CHILD(ndims); ', ); =head2 unthread =cut pp_def( 'unthread', Doc => <<'EOD', =for ref All threaded dimensions are made real again. See [TBD Doc] for details and examples. =cut EOD P2Child => 1, TwoWay => 1, AffinePriv => 1, OtherPars => 'int atind;', RedoDims => ' int i; $SETNDIMS($PARENT(ndims)); $DOPRIVALLOC(); $PRIV(offs) = 0; for(i=0; i<$PARENT(ndims); i++) { int corc; if(i<$COMP(atind)) { corc = i; } else if(i < $PARENT(threadids[0])) { corc = i + $PARENT(ndims)-$PARENT(threadids[0]); } else { corc = i - $PARENT(threadids[0]) + $COMP(atind); } $CHILD(dims[corc]) = $PARENT(dims[i]); $PRIV(incs[corc]) = $PARENT(dimincs[i]); } $SETDIMS(); ', ); pp_add_exported('', 'dice dice_axis'); pp_addpm(<<'EOD'); =head2 dice =for ref Dice rows/columns/planes out of a PDL using indexes for each dimension. This function can be used to extract irregular subsets along many dimension of a PDL, e.g. only certain rows in an image, or planes in a cube. This can of course be done with the usual dimension tricks but this saves having to figure it out each time! This method is similar in functionality to the L method, but L requires that contiguous ranges or ranges with constant offset be extracted. ( i.e. L requires ranges of the form C<1,2,3,4,5> or C<2,4,6,8,10>). Because of this restriction, L is more memory efficient and slightly faster than dice =for usage $slice = $data->dice([0,2,6],[2,1,6]); # Dicing a 2-D array The arguments to dice are arrays (or 1D PDLs) for each dimension in the PDL. These arrays are used as indexes to which rows/columns/cubes,etc to dice-out (or extract) from the C<$data> PDL. Use C to select all indices along a given dimension (compare also L). As usual (in slicing methods) trailing dimensions can be omitted implying C'es for those. =for example pdl> $x = sequence(10,4) pdl> p $x [ [ 0 1 2 3 4 5 6 7 8 9] [10 11 12 13 14 15 16 17 18 19] [20 21 22 23 24 25 26 27 28 29] [30 31 32 33 34 35 36 37 38 39] ] pdl> p $x->dice([1,2],[0,3]) # Select columns 1,2 and rows 0,3 [ [ 1 2] [31 32] ] pdl> p $x->dice(X,[0,3]) [ [ 0 1 2 3 4 5 6 7 8 9] [30 31 32 33 34 35 36 37 38 39] ] pdl> p $x->dice([0,2,5]) [ [ 0 2 5] [10 12 15] [20 22 25] [30 32 35] ] As this is an index function, any modifications to the slice will change the parent (use the C<.=> operator). =cut sub PDL::dice { my $self = shift; my @dim_indexes = @_; # array of dimension indexes # Check that the number of dim indexes <= # number of dimensions in the PDL my $no_indexes = scalar(@dim_indexes); my $noDims = $self->getndims; barf("PDL::dice: Number of index arrays ($no_indexes) not equal to the dimensions of the PDL ($noDims") if $no_indexes > $noDims; my $index; my $pdlIndex; my $outputPDL=$self; my $indexNo = 0; # Go thru each index array and dice the input PDL: foreach $index(@dim_indexes){ $outputPDL = $outputPDL->dice_axis($indexNo,$index) unless !ref $index && $index eq 'X'; $indexNo++; } return $outputPDL; } *dice = \&PDL::dice; =head2 dice_axis =for ref Dice rows/columns/planes from a single PDL axis (dimension) using index along a specified axis This function can be used to extract irregular subsets along any dimension, e.g. only certain rows in an image, or planes in a cube. This can of course be done with the usual dimension tricks but this saves having to figure it out each time! =for usage $slice = $data->dice_axis($axis,$index); =for example pdl> $x = sequence(10,4) pdl> $idx = pdl(1,2) pdl> p $x->dice_axis(0,$idx) # Select columns [ [ 1 2] [11 12] [21 22] [31 32] ] pdl> $t = $x->dice_axis(1,$idx) # Select rows pdl> $t.=0 pdl> p $x [ [ 0 1 2 3 4 5 6 7 8 9] [ 0 0 0 0 0 0 0 0 0 0] [ 0 0 0 0 0 0 0 0 0 0] [30 31 32 33 34 35 36 37 38 39] ] The trick to using this is that the index selects elements along the dimensions specified, so if you have a 2D image C will select certain C values - i.e. extract columns As this is an index function, any modifications to the slice will change the parent. =cut sub PDL::dice_axis { my($self,$axis,$idx) = @_; my $ix = ref($self)->topdl($idx); barf("dice_axis: index must be <=1D") if $ix->getndims > 1; return $self->mv($axis,0)->index1d($ix)->mv(0,$axis); } *dice_axis = \&PDL::dice_axis; EOD ############################## # 'slice' is now implemented as a small Perl wrapper around # a PP call. This permits unification of the former slice, # and dice into a single call. At the moment, dicing # is implemented a bit kludgily (it is detected in the Perl # front-end), but it is serviceable. # --CED 12-Sep-2013 pp_def( 'slice', Doc => <<'EOD-slice', =for usage $slice = $data->slice([2,3],'x',[2,2,0],"-1:1:-1", "*3"); =for ref Extract rectangular slices of an ndarray, from a string specifier, an array ref specifier, or a combination. C is the main method for extracting regions of PDLs and manipulating their dimensionality. You can call it directly or via he L source prefilter that extends Perl syntax to include array slicing. C can extract regions along each dimension of a source PDL, subsample or reverse those regions, dice each dimension by selecting a list of locations along it, or basic PDL indexing routine. The selected subfield remains connected to the original PDL via dataflow. In most cases this neither allocates more memory nor slows down subsequent operations on either of the two connected PDLs. You pass in a list of arguments. Each term in the list controls the disposition of one axis of the source PDL and/or returned PDL. Each term can be a string-format cut specifier, a list ref that gives the same information without recourse to string manipulation, or a PDL with up to 1 dimension giving indices along that axis that should be selected. If you want to pass in a single string specifier for the entire operation, you can pass in a comma-delimited list as the first argument. C detects this condition and splits the string into a regular argument list. This calling style is fully backwards compatible with C calls from before PDL 2.006. B If a particular argument to C is a string, it is parsed as a selection, an affine slice, or a dummy dimension depending on the form. Leading or trailing whitespace in any part of each specifier is ignored (though it is not ignored within numbers). =over 3 =item C<< '' >>, C<< : >>, or C<< X >> -- keep The empty string, C<:>, or C cause the entire corresponding dimension to be kept unchanged. =item C<< >> -- selection A single number alone causes a single index to be selected from the corresponding dimension. The dimension is kept (and reduced to size 1) in the output. =item C<< () >> -- selection and collapse A single number in parenthesis causes a single index to be selected from the corresponding dimension. The dimension is discarded (completely eliminated) in the output. =item C<< : >> -- select an inclusive range Two numbers separated by a colon selects a range of values from the corresponding axis, e.g. C<< 3:4 >> selects elements 3 and 4 along the corresponding axis, and reduces that axis to size 2 in the output. Both numbers are regularized so that you can address the last element of the axis with an index of C< -1 >. If, after regularization, the two numbers are the same, then exactly one element gets selected (just like the C<< >> case). If, after regulariation, the second number is lower than the first, then the resulting slice counts down rather than up -- e.g. C<-1:0> will return the entire axis, in reversed order. =item C<< :: >> -- select a range with explicit step If you include a third parameter, it is the stride of the extracted range. For example, C<< 0:-1:2 >> will sample every other element across the complete dimension. Specifying a stride of 1 prevents autoreversal -- so to ensure that your slice is *always* forward you can specify, e.g., C<< 2:$n:1 >>. In that case, an "impossible" slice gets an Empty PDL (with 0 elements along the corresponding dimension), so you can generate an Empty PDL with a slice of the form C<< 2:1:1 >>. =item C<< * >> -- insert a dummy dimension Dummy dimensions aren't present in the original source and are "mocked up" to match dimensional slots, by repeating the data in the original PDL some number of times. An asterisk followed by a number produces a dummy dimension in the output, for example C<< *2 >> will generate a dimension of size 2 at the corresponding location in the output dim list. Omitting the number (and using just an asterisk) inserts a dummy dimension of size 1. =back B If you feed in an ARRAY ref as a slice term, then it can have 0-3 elements. The first element is the start of the slice along the corresponding dim; the second is the end; and the third is the stepsize. Different combinations of inputs give the same flexibility as the string syntax. =over 3 =item C<< [] >> - keep dim intact An empty ARRAY ref keeps the entire corresponding dim =item C<< [ 'X' ] >> - keep dim intact =item C<< [ '*',$n ] >> - generate a dummy dim of size $n If $n is missing, you get a dummy dim of size 1. =item C<< [ $dex, , 0 ] >> - collapse and discard dim C<$dex> must be a single value. It is used to index the source, and the corresponding dimension is discarded. =item C<< [ $start, $end ] >> - collect inclusive slice In the simple two-number case, you get a slice that runs up or down (as appropriate) to connect $start and $end. =item C<< [ $start, $end, $inc ] >> - collect inclusive slice The three-number case works exactly like the three-number string case above. =back B If you pass in a 0- or 1-D PDL as a slicing argument, the corresponding dimension is "diced" -- you get one position along the corresponding dim, per element of the indexing PDL, e.g. C<< $x->slice( pdl(3,4,9)) >> gives you elements 3, 4, and 9 along the 0 dim of C<< $x >>. Because dicing is not an affine transformation, it is slower than direct slicing even though the syntax is convenient. =for example $x->slice('1:3'); # return the second to fourth elements of $x $x->slice('3:1'); # reverse the above $x->slice('-2:1'); # return last-but-one to second elements of $x $x->slice([1,3]); # Same as above three calls, but using array ref syntax $x->slice([3,1]); $x->slice([-2,1]); EOD-slice PMCode => <<'EOD-slice', sub PDL::slice { my ($source, @others) = @_; for my $i(0..$#others) { my $idx = $others[$i]; if (ref $idx eq 'ARRAY') { my @arr = map UNIVERSAL::isa($_, 'PDL') ? $_->flat->at(0) : $_, @{$others[$i]}; $others[$i] = \@arr; next; } next if !( blessed($idx) && $idx->isa('PDL') ); # Deal with dicing. This is lame and slow compared to the # faster slicing, but works okay. We loop over each argument, # and if it's a PDL we dispatch it in the most straightforward # way. Single-element and zero-element PDLs are trivial and get # converted into slices for faster handling later. barf("slice: dicing parameters must be at most 1D (arg $i)\n") if $idx->ndims > 1; my $nlm = $idx->nelem; if($nlm > 1) { #### More than one element - we have to dice (darn it). my $n = $source->getndims; $source = $source->mv($i,0)->index1d($idx)->mv(0,$i); $others[$i] = ''; } elsif($nlm) { #### One element - convert to a regular slice. $others[$i] = $idx->flat->at(0); } else { #### Zero elements -- force an extended empty. $others[$i] = "1:0:1"; } } PDL::_slice_int($source,my $o=$source->initialize,\@others); $o; } EOD-slice P2Child => 1, OtherPars => 'pdl_slice_args *arglist;', # # Comp stash definitions: # nargs - number of args in original call # odim[] - maps argno to output dim (or -1 for squished dims) # idim[] - maps argno to input dim (or -1 for dummy dims) # odim_top - one more than the highest odim encountered # idim_top - one more than the highest idim encountered # start[] - maps argno to start index of slice range (inclusive) # inc[] - maps argno to increment of slice range # end[] - maps argno to end index of slice range (inclusive) # Comp => 'int nargs; PDL_Indx odim[$COMP(nargs)]; PDL_Indx idim[$COMP(nargs)]; PDL_Indx idim_top; PDL_Indx odim_top; PDL_Indx start[$COMP(nargs)]; PDL_Indx inc[$COMP(nargs)]; PDL_Indx end[$COMP(nargs)]; ', AffinePriv => 1, TwoWay => 1, MakeComp => <<'SLICE-MC' int nargs = 0; pdl_slice_args *argsptr = arglist; while (argsptr) nargs++, argsptr = argsptr->next; $COMP(nargs) = nargs; $DOCOMPALLOC(); int i; PDL_Indx idim, odim, imax; argsptr = arglist; for(odim=idim=i=0; istart; $COMP(end)[i] = argsptr->end; $COMP(inc)[i] = argsptr->inc; /* Deal with dimensions */ $COMP(odim)[i] = argsptr->squish ? -1 : odim++; $COMP(idim)[i] = argsptr->dummy ? -1 : idim++; argsptr = argsptr->next; } /* end of arg-parsing loop */ $COMP(idim_top) = idim; $COMP(odim_top) = odim; SLICE-MC , RedoDims => q{ PDL_Indx i; PDL_Indx PDIMS; int o_ndims_extra = PDLMAX(0, $PARENT(ndims) - $COMP(idim_top)); /* slurped dims from the arg parsing, plus any extra thread dims */ $SETNDIMS( $COMP(odim_top) + o_ndims_extra ); $DOPRIVALLOC(); $PRIV(offs) = 0; /* Offset vector to start of slice */ for(i=0; i<$COMP(nargs); i++) { /** Belt-and-suspenders **/ if( ($COMP(idim[i]) < 0) && ($COMP(odim[i]) < 0) ) { PDL->changed($CHILD_PTR(), PDL_PARENTDIMSCHANGED, 0); $CROAK("Hmmm, both dummy and squished -- this can never happen. I quit."); } /** First handle dummy dims since there's no input from the parent **/ if( $COMP(idim[i]) < 0 ) { /* dummy dim - offset or diminc. */ $CHILD( dims[ $COMP(odim[i]) ] ) = $COMP(end[i]) - $COMP(start[i]) + 1; $PRIV( incs[ $COMP(odim[i]) ] ) = 0; } else { /** This is not a dummy dim -- deal with a regular slice along it. **/ /** Get parent dim size for this idim, and/or allow permissive slicing **/ PDL_Indx pdsize = $COMP(idim[i]) < $PARENT(ndims) ? $PARENT(dims)[$COMP(idim)[i]] : 1; PDL_Indx start = $COMP(start)[i]; PDL_Indx end = $COMP(end)[i]; if( /** Trap special case: full slices of an empty dim are empty **/ (pdsize==0 && start==0 && end==-1 && $COMP(inc[i]) == 0) || /* the values given when PDL::slice gets empty ndarray for index */ (start==1 && end==0 && $COMP(inc[i]) == 1) ) { $CHILD(dims)[$COMP(odim)[i]] = 0; $PRIV(incs)[$COMP(odim)[i]] = 0; } else { /** Regularize and bounds-check the start location **/ if(start < 0) start += pdsize; if( start < 0 || start >= pdsize ) { PDL->changed($CHILD_PTR(), PDL_PARENTDIMSCHANGED, 0); if(i >= $PARENT( ndims )) { $CROAK("slice has too many dims (indexes dim %d; highest is %d)",i,$PARENT( ndims )-1); } else { $CROAK("slice starts out of bounds in pos %d (start is %d; source dim %d runs 0 to %d)",i,start,$COMP(idim[i]),pdsize-1); } } if( $COMP(odim[i]) < 0) { /* squished dim - just update the offset. */ /* start is always defined and regularized if we are here here, since */ /* both idim[i] and odim[i] can't be <0 */ $PRIV(offs) += start * $PARENT( dimincs[ $COMP(idim[i]) ] ); } else /* normal operation */ { /** Regularize and bounds-check the end location **/ if(end<0) end += pdsize; if( end < 0 || end >= pdsize ) { PDL->changed($CHILD_PTR(), PDL_PARENTDIMSCHANGED, 0); $CROAK("slice ends out of bounds in pos %d (end is %d; source dim %d runs 0 to %d)",i,end,$COMP(idim[i]),pdsize-1); } /* regularize inc */ PDL_Indx inc = $COMP(inc)[i]; if(!inc) inc = (start <= end) ? 1 : -1; $CHILD( dims )[ $COMP(odim)[i] ] = PDLMAX(0, (end - start + inc) / inc); $PRIV( incs )[ $COMP(odim)[i] ] = $PARENT(dimincs)[ $COMP(idim)[i] ] * inc; $PRIV(offs) += start * $PARENT( dimincs )[ $COMP(idim)[i] ]; } /* end of normal slice case */ } /* end of trapped strange slice case */ } /* end of non-dummy slice case */ } /* end of nargs loop */ /* Now fill in thread dimensions as needed. idim and odim persist from the parsing loop */ /* up above. */ for(i=0; i 'Bot'},<< 'EOD'); =head1 BUGS For the moment, you can't slice one of the zero-length dims of an empty ndarray. It is not clear how to implement this in a way that makes sense. Many types of index errors are reported far from the indexing operation that caused them. This is caused by the underlying architecture: slice() sets up a mapping between variables, but that mapping isn't tested for correctness until it is used (potentially much later). =head1 AUTHOR Copyright (C) 1997 Tuomas J. Lukka. Contributions by Craig DeForest, deforest@boulder.swri.edu. Documentation contributions by David Mertens. 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(); PDL-2.074/Basic/Slices/Makefile.PL0000644000175000017500000000040514112170323016301 0ustar osboxesosboxesuse strict; use warnings; use ExtUtils::MakeMaker; my @pack = (["slices.pd", qw(Slices PDL::Slices)]); my %hash =pdlpp_stdargs_int(@pack); undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.074/Basic/Math/0000755000175000017500000000000014200406301013773 5ustar osboxesosboxesPDL-2.074/Basic/Math/const.c0000644000175000017500000000401214173310620015271 0ustar osboxesosboxes/* Some constant values -- */ #include "mconf.h" /* Many of these values should ideally come from or , which should be included in mconf.h if required */ #ifdef DBL_EPSILON double MACHEP = DBL_EPSILON; #else double MACHEP = 1.11022302462515654042E-16; /* 2**-53 */ #endif #if defined DBL_MIN double UFLOWTHRESH = DBL_MIN; #elif defined MINDOUBLE double UFLOWTHRESH = MINDOUBLE; #else double UFLOWTHRESH = 2.22507385850720138309E-308; /* 2**-1022 */ #endif #ifdef DBL_MAX_10_EXP double MAXLOG = DBL_MAX_10_EXP; #else double MAXLOG = 7.08396418532264106224E2; /* log 2**1022 */ #endif #ifdef DBL_MIN_10_EXP double MINLOG = DBL_MIN_10_EXP; #else double MINLOG = -7.08396418532264106224E2; /* log 2**-1022 */ #endif #if defined MAXDOUBLE double MAXNUM = MAXDOUBLE; #elif defined DBL_MAX double MAXNUM = DBL_MAX; #else double MAXNUM = 1.79769313486231570815E308; /* 2**1024*(1-MACHEP) */ #endif #ifdef M_PI #ifndef PI double PI = M_PI; #endif double PIO2 = M_PI/2; double PIO4 = M_PI/4; double THPIO4 = 0.75*M_PI; double TWOOPI = 2/M_PI; #else #ifndef PI double PI = 3.14159265358979323846; /* pi */ #endif double PIO2 = 1.57079632679489661923; /* pi/2 */ double PIO4 = 7.85398163397448309616E-1; /* pi/4 */ double THPIO4 = 2.35619449019234492885; /* 3*pi/4 */ double TWOOPI = 6.36619772367581343075535E-1; /* 2/pi */ #endif #ifdef M_SQRT2 double SQRT2 = M_SQRT2; /* sqrt(2) */ double SQRTH = M_SQRT2/2; /* sqrt(2)/2 */ #else double SQRT2 = 1.41421356237309504880; /* sqrt(2) */ double SQRTH = 7.07106781186547524401E-1; /* sqrt(2)/2 */ #endif double SQ2OPI = 7.9788456080286535587989E-1; /* sqrt( 2/pi ) */ #ifdef M_LN2 double LOGE2 = M_LN2; double LOGSQ2 = M_LN2/2; /* log(2)/2 */ double LOG2E = 1/M_LN2; /* 1/log(2) */ #else double LOGE2 = 6.93147180559945309417E-1; /* log(2) */ double LOGSQ2 = 3.46573590279972654709E-1; /* log(2)/2 */ double LOG2E = 1.4426950408889634073599; /* 1/log(2) */ #endif PDL-2.074/Basic/Math/quiet_nan.c0000644000175000017500000000034314173310620016131 0ustar osboxesosboxes#include "mconf.h" /* Patch NaN function where no system NaN is available */ double quiet_nan(NANARG_SIGNATURE) { #ifdef NaN double a; return NaN(a); #else double a=0; return 0./a; /* Expect bad value error */ #endif } PDL-2.074/Basic/Math/cpoly.c0000644000175000017500000004563614173310620015312 0ustar osboxesosboxes/* Translated from F77 to C, rjrw 10/04/2000 */ /* replaced 'bool' by 'boolvar' to get it to compile on my linux machine, DJB Aug 02 2000 */ /* algorithm 419 collected algorithms from acm. algorithm appeared in comm. acm, vol. 15, no. 02, p. 097. */ #include #include #include /* #if !defined(WIN32) && !defined(_WIN32) && !defined(__APPLE__) && !defined(__CYGWIN__) #include #endif */ #include /* #define DEBUGMAIN */ /* Set up debugging main, etc. */ #include "cpoly.h" /* Internal routines */ static void noshft(int l1); static int fxshft(int l2, double *zr, double *zi); static int vrshft(int l3, double *zr, double *zi); static int calct(void); static void nexth(int boolvar); static void polyev(int nn, double sr, double si, double pr[], double pi[], double qr[], double qi[], double *pvr, double *pvi); static double errev(int nn, double qr[], double qi[], double ms, double mp); static double cauchy(int nn, double pt[], double q[]); static double scale(int nn, double pt[]); static void cdivid(double ar, double ai, double br, double bi, double *cr, double *ci); static double cmod(double r, double i); static void mcon(void); static int init(int nncr); /* Internal global variables */ static double *pr,*pi,*hr,*hi,*qpr,*qpi,*qhr,*qhi,*shr,*shi; static double sr,si,tr,ti,pvr,pvi,are,mre,eta,infin,smalno,base; static int nn; #ifdef DEBUGMAIN /* driver to test cpoly */ int main() { int fail; double p[50],pi[50],zr[50],zi[50]; int i; printf("Example 1. polynomial with zeros 1,2,...,10.\n"); p[0]=1L; p[1]=-55L; p[2]=1320L; p[3]=-18150L; p[4]=157773L; p[5]=-902055L; p[6] = 3416930L; p[7]=-8409500L; p[8]=12753576L; p[9]=-10628640L; p[10]=3628800L; for (i=0;i<11;i++) pi[i]=0; prtc(11,p,pi); fail = cpoly(p,pi,10,zr,zi); if(fail) printf("cpoly has failed on this example\n"); prtz (10,zr,zi); printf("Example 2. zeros on imaginary axis degree 3.\n"); p[0]=1; p[1]=0; p[2]=-10001.0001L; p[3]=0; pi[0]=0; pi[1]=-10001.0001L; pi[2]=0; pi[3]=1; prtc(4,p,pi); fail = cpoly(p,pi,3,zr,zi); if (fail) printf("cpoly has failed on this example\n"); prtz(3,zr,zi); printf("Example 3. zeros at 1+i,1/2*(1+i)....1/(2**-9)*(1+i)\n"); p[0]=1.0; p[1]=-1.998046875L; p[2]=0.0; p[3]=.7567065954208374L; p[4]=-.2002119533717632L; p[5]=1.271507365163416e-2L; p[6]=0; p[7]=-1.154642632172909e-5L; p[8]=1.584803612786345e-7L; p[9]=-4.652065399568528e-10L; p[10]=0; pi[0]=0; pi[1]=p[1]; pi[2]=2.658859252929688L; pi[3]=-7.567065954208374e-1L; pi[4]=0; pi[5]=p[5]; pi[6]=-7.820779428584501e-4L; pi[7]=-p[7]; pi[8]=0; pi[9]=p[9]; pi[10]=9.094947017729282e-13L; prtc(11,p,pi); fail = cpoly(p,pi,10,zr,zi); if (fail) printf("cpoly has failed on this example\n"); prtz(10,zr,zi); printf("Example 4. multiple zeros\n"); p[0]=1L; p[1]=-10L; p[2]=3L; p[3]=284L; p[4]=-1293L; p[5]=2374L; p[6]=-1587L; p[7]=-920L; p[8]=2204L; p[9]=-1344L; p[10]=288L; pi[0]=0; pi[1]=-10L; pi[2]=100L; pi[3]=-334L; pi[4]=200L; pi[5]=1394L; pi[6] =-3836L; pi[7]=4334L; pi[8]=-2352L; pi[9]=504L; pi[10]=0; prtc(11,p,pi); fail = cpoly(p,pi,10,zr,zi); if (fail) printf("cpoly has failed on this example\n"); prtz(10,zr,zi); printf("Example 5. 12 zeros evenly distributed on a circle of radius 1. centered at 0+2i.\n"); p[0]=1L; p[1]=0; p[2]=-264L; p[3]=0; p[4]=7920L; p[5]=0; p[6]=-59136L; p[7]=0; p[8]=126720L; p[9]=0; p[10]=-67584L; p[11]=0; p[12]=4095L; pi[0]=0; pi[1]=-24L; pi[2]=0; pi[3]=1760L; pi[4]=0; pi[5]=-25344L; pi[6]=0; pi[7]=101376L; pi[8]=0; pi[9]=-112640L; pi[10]=0; pi[11]=24576L; pi[12]=0; prtc(13,p,pi); fail = cpoly(p,pi,12,zr,zi); if(fail) printf("cpoly has failed on this example\n"); prtz(12,zr,zi); return 0; } void prtc(int n, double p[], double q[]) { int i; printf("Coefficients\n"); for (i=0;i eta*10.0*cmod(pr[nm2],pi[nm2])) { cdivid(-pr[n],-pi[n],hr[nm1],hi[nm1],&tr,&ti); for (i=0;i=omp && relstp < .05L) { /* Iteration has stalled, probably a cluster of zeros Do 5 fixed shift steps into the cluster to force one zero to dominate */ b = TRUE; if (relstp < eta) tp = eta; else tp = relstp; r1 = sqrt(tp); r2 = sr*(1.0L+r1)-si*r1; si = sr*r1+si*(1.0L+r1); sr = r2; polyev(nn,sr,si,pr,pi,qpr,qpi,&pvr,&pvi); for (j=0;j<5;j++) { boolvar = calct(); nexth(boolvar); } omp = infin; } else { /* Exit if polynomial value increases significantly */ if (mp*0.1L > omp) return conv; omp = mp; } } else { omp = mp; } } /* Calculate next iterate. */ boolvar = calct(); nexth(boolvar); boolvar = calct(); if (!boolvar) { relstp = cmod(tr,ti)/cmod(sr,si); sr += tr; si += ti; } } return conv; } static int calct(void) /* Computes t = -p(s)/h(s) Returns TRUE if h(s) is essentially zero */ { double hvr,hvi; int n = nn-1, boolvar; /* Evaluate h(s) */ polyev(n,sr,si,hr,hi,qhr,qhi,&hvr,&hvi); boolvar = (cmod(hvr,hvi) <= are*10.0*cmod(hr[n-1],hi[n-1])); if (!boolvar) { cdivid(-pvr,-pvi,hvr,hvi,&tr,&ti); } else { tr = 0.0; ti = 0.0; } return boolvar; } static void nexth(int boolvar) /* Calculates the next shifted h polynomial boolvar - TRUE if h(s) is essentially zero */ { double t1,t2; int j,n = nn-1; if (!boolvar) { for (j=1;j 0.); dx = x; /* Do Newton iteration until x converges to two decimal places */ while (fabs(dx/x) > .005L) { q[0] = pt[0]; for(i=1;i max) max = x; if (x != 0.0 && x < min) min = x; } /* Scale only if there are very large or very small components */ if (min >= lo && max <= hi) return 1.0; x = lo/min; if (x <= 1.0L) { sc = 1.0L/(sqrt(max)*sqrt(min)); } else { sc = x; if (infin/sc > max) sc = 1.0; } l = log(sc)/log(base) + .500; return pow(base,l); } static void cdivid(double ar, double ai, double br, double bi, double *cr, double *ci) /* Complex division c = a/b, avoiding overflow */ { double r,d; if (br == 0.0 && bi == 0.0) { /* division by zero, c = infinity. */ *cr = infin; *ci = infin; } else if (fabs(br) < fabs(bi)) { r = br/bi; d = bi+r*br; *cr = (ar*r+ai)/d; *ci = (ai*r-ar)/d; } else { r = bi/br; d = br+r*bi; *cr = (ar+ai*r)/d; *ci = (ai-ar*r)/d; } return; } static double cmod(double r, double i) /* Modulus of a complex number avoiding overflow */ { double ar,ai,f; ar = fabs(r); ai = fabs(i); if (ar < ai) { f = ar/ai; return ai*sqrt(1.0+f*f); } else if (ar > ai) { f = ai/ar; return ar*sqrt(1.0+f*f); } else { return ar*sqrt(2.0); } } static void mcon() /* mcon provides machine constants used in various parts of the program. The user may either set them directly or use the statements below to compute them. The meaning of the four constants are - eta the maximum relative representation error which can be described as the smallest positive floating-point number such that 1.0d0 + eta is greater than 1.0d0. infin the largest floating-point number smalno the smallest positive floating-point number base the base of the floating-point number system used Let t be the number of base-digits in each floating-point number (double precision). Then eta is either .5*b**(1-t) or b**(1-t) depending on whether rounding or truncation is used. Let m be the largest exponent and n the smallest exponent in the number system. Then infiny is (1-base**(-t))*base**m and smalno is base**n. */ { /* #if !defined(WIN32) && !defined(_WIN32) && !defined(__APPLE__) && !defined(__CYGWIN__) base = 2; eta = DBL_EPSILON; smalno = MINDOUBLE; infin = MAXDOUBLE; #else */ base = 2; eta = DBL_EPSILON; smalno = DBL_MIN; infin = DBL_MAX; /* #endif */ #ifdef IBM360 /* These values for base,t,m,n correspond to the ibm/360. */ int m,n,t; base = 16.0; t = 14; m = 63; n = -65; eta = pow(base,1-t); infin = (base)*(1.0-pow(base,-t))*pow(base,m-1); smalno = pow(base,n+3)/pow(base,3); #endif } static int init(int nncr) { static int nmax=0; if (nmax == 0) { /* Set up once-off constants */ mcon(); /* are, mre - Error bounds on complex addition and multiplication, cf e.g. errev() above */ are = eta; mre = 2.0L*sqrt(2.0L)*eta; } else if (nmax >= nncr) { return TRUE; /* Present arrays are big enough */ } else { /* Free old arrays (no need to preserve contents */ free(shi); free(shr); free(qhi); free(qhr); free(qpi); free(qpr); free(hi); free(hr); free(pi); free(pr); } nmax = nncr; pr = (double *) malloc(nmax*sizeof(double)); pi = (double *) malloc(nmax*sizeof(double)); hr = (double *) malloc(nmax*sizeof(double)); hi = (double *) malloc(nmax*sizeof(double)); qpr = (double *) malloc(nmax*sizeof(double)); qpi = (double *) malloc(nmax*sizeof(double)); qhr = (double *) malloc(nmax*sizeof(double)); qhi = (double *) malloc(nmax*sizeof(double)); shr = (double *) malloc(nmax*sizeof(double)); shi = (double *) malloc(nmax*sizeof(double)); if (!(pr && pi && hr && hi && qpr && qpi && qhr && qhi && shr && shi)) { fprintf(stderr,"Couldn't allocate space for cpoly\n"); return FALSE; } else { return TRUE; } } PDL-2.074/Basic/Math/math.pd0000644000175000017500000002471214200051426015263 0ustar osboxesosboxesuse strict; use warnings; use Config; use PDL::Types qw(ppdefs ppdefs_complex types); require PDL::Core::Dev; my $R = [ppdefs()]; my $F = [map $_->ppsym, grep $_->real && !$_->integer, types()]; my $C = [ppdefs_complex()]; my @Rtypes = grep $_->real, types(); my @Ctypes = grep !$_->real, types(); pp_addpm({At=>'Top'},<<'EOD'); use strict; use warnings; =head1 NAME PDL::Math - extended mathematical operations and special functions =head1 SYNOPSIS use PDL::Math; use PDL::Graphics::TriD; imag3d [SURF2D,bessj0(rvals(zeroes(50,50))/2)]; =head1 DESCRIPTION This module extends PDL with more advanced mathematical functions than provided by standard Perl. All the functions have one input pdl, and one output, unless otherwise stated. Many of the functions are linked from the system maths library or the Cephes maths library (determined when PDL is compiled); a few are implemented entirely in PDL. =cut ### Kludge for backwards compatibility with older scripts ### This should be deleted at some point later than 21-Nov-2003. BEGIN {use PDL::MatrixOps;} EOD # Internal doc util my %doco; sub doco { my @funcs = @_; my $doc = pop @funcs; for (@funcs) { $doco{$_} = $doc } } doco (qw/acos asin atan tan/, <<'EOF'); The usual trigonometric function. EOF doco (qw/cosh sinh tanh acosh asinh atanh/, <<'EOF'); The standard hyperbolic function. EOF doco (qw/ceil floor/, 'Round to integer values in floating-point format.'); doco ('rint', q/=for ref Round to integer values in floating-point format. =for method rint uses the 'round half to even' rounding method (also known as banker's rounding). Half-integers are rounded to the nearest even number. This avoids a slight statistical bias inherent in always rounding half-integers up or away from zero. If you are looking to round half-integers up (regardless of sign), try C. If you want to round half-integers away from zero, try C<< ceil(abs($x)+0.5)*($x<=>0) >>./); doco( 'pow',"Synonym for `**'."); doco ('erf',"The error function."); doco ('erfc',"The complement of the error function."); doco ('erfi',"The inverse of the error function."); doco ('ndtri', "=for ref The value for which the area under the Gaussian probability density function (integrated from minus infinity) is equal to the argument (cf L)."); doco(qw/bessj0 bessj1/, "The regular Bessel function of the first kind, J_n" ); doco(qw/bessy0 bessy1/, "The regular Bessel function of the second kind, Y_n." ); doco( qw/bessjn/, '=for ref The regular Bessel function of the first kind, J_n . This takes a second int argument which gives the order of the function required. '); doco( qw/bessyn/, '=for ref The regular Bessel function of the first kind, Y_n . This takes a second int argument which gives the order of the function required. '); if ($^O !~ /win32/i || $Config{cc} =~ /\bgcc/i) { # doesn't seem to be in the MS VC lib doco( 'lgamma' ,<<'EOD'); =for ref log gamma function This returns 2 ndarrays -- the first set gives the log(gamma) values, while the second set, of integer values, gives the sign of the gamma function. This is useful for determining factorials, amongst other things. EOD } # if: $^O !~ win32 pp_addhdr(' #include #include "protos.h" '); if ($^O =~ /MSWin/) { pp_addhdr(' #include #ifdef _MSC_VER double rint (double); #endif '); } # Standard `-lm' my (@ufuncs1) = qw(acos asin atan cosh sinh tan tanh); # F,D only my (@ufuncs1g) = qw(ceil floor rint); # Any real type # Note: # ops.pd has a power() function that does the same thing # (although it has OtherPars => 'int swap;' as well) # - left this in for now. # my (@bifuncs1) = qw(pow); # Any type # Extended `-lm' my (@ufuncs2) = qw(acosh asinh atanh erf erfc); # F,D only my (@besufuncs) = qw(j0 j1 y0 y1); # " my (@besbifuncs) = qw(jn yn); # " # Need igamma, ibeta, and a fall-back implementation of the above sub code_ufunc { < 1, NoBadifNaN => 1, GenericTypes => [($got_complex ? @$C : ()), @$F], Pars => 'a(); [o]b();', Inplace => 1, Doc => inplace_doc( $func ), Code => code_ufunc($func), ); } # real types foreach my $func (@ufuncs1g) { pp_def($func, HandleBad => 1, NoBadifNaN => 1, Pars => 'a(); [o]b();', Inplace => 1, Doc => inplace_doc( $func ), Code => code_ufunc($func), ); } foreach my $func (@bifuncs1) { my $got_complex = PDL::Core::Dev::got_complex_version($func, 2); pp_def($func, HandleBad => 1, NoBadifNaN => 1, Pars => 'a(); b(); [o]c();', Inplace => [ 'a' ], GenericTypes => [($got_complex ? @$C : ()), @$R], Doc => inplace_doc( $func ), Code => code_bifunc($func), ); } # Functions provided by extended -lm foreach my $func (@ufuncs2) { pp_def($func, HandleBad => 1, NoBadifNaN => 1, GenericTypes => $F, Pars => 'a(); [o]b();', Inplace => 1, Doc => inplace_doc( $func ), Code => code_ufunc($func), ); } foreach my $func (@besufuncs) { my $fname = "bess$func"; pp_def($fname, HandleBad => 1, NoBadifNaN => 1, GenericTypes => $F, Pars => 'a(); [o]b();', Inplace => 1, Doc => inplace_doc( $fname ), Code => code_ufunc($func), ); } foreach my $func (@besbifuncs) { my $fname = "bess$func"; pp_def($fname, HandleBad => 1, NoBadifNaN => 1, GenericTypes => $F, Pars => 'a(); int n(); [o]b();', Inplace => [ 'a' ], Doc => inplace_doc( $fname ), Code => code_bifunc($func,'n','a','b'), ); } if ($^O !~ /win32/i) { pp_def("lgamma", HandleBad => 1, Pars => 'a(); [o]b(); int[o]s()', Doc => $doco{"lgamma"}, Code => ' extern int signgam; PDL_IF_BAD(if ( $ISBAD(a()) ) { $SETBAD(b()); $SETBAD(s()); } else {,) $b() = lgamma($a()); $s() = signgam; PDL_IF_BAD(},) ', # what happens to signgam if $a() is bad? ); } # if: os !~ win32 elsif ($Config{cc} =~ /\bgcc/i) { pp_def("lgamma", HandleBad => 1, Pars => 'a(); [o]b(); int[o]s()', Doc => $doco{"lgamma"}, Code => ' PDL_IF_BAD(if ( $ISBAD(a()) ) { $SETBAD(b()); $SETBAD(s()); } else {,) $b() = lgamma($a()); $s() = tgamma($a()) < 0 ? -1 : 1; PDL_IF_BAD(},) ', # what happens to signgam if $a() is bad? ); } # elsif: cc =~ /\bgcc/i pp_def( 'badmask', Pars => 'a(); b(); [o]c();', Inplace => [ 'a' ], HandleBad => 1, Code => '$c() = isfinite((double) $a()) ? $a() : $b();', BadCode => '$c() = ( isfinite((double) $a()) && $ISGOOD(a()) ) ? $a() : $b();', CopyBadStatusCode => 'if ( a == c && $ISPDLSTATEBAD(a) ) PDL->propagate_badflag( c, 0 ); /* propagate badflag if inplace AND its changed */ $SETPDLSTATEGOOD(c); /* always make sure the output is "good" */ ', Doc => '=for ref Clears all C and C in C<$a> to the corresponding value in C<$b>. badmask can be run with C<$x> inplace: badmask($x->inplace,0); $x->inplace->badmask(0); ', BadDoc => 'If bad values are present, these are also cleared.', ); pp_def( 'isfinite', Pars => 'a(); int [o]mask();', Inplace => 1, HandleBad => 1, Code => '$mask() = isfinite((double) $a()) != 0;', BadCode => '$mask() = isfinite((double) $a()) != 0 && $ISGOOD($a());', CopyBadStatusCode => 'if ( a == mask && $ISPDLSTATEBAD(a) ) PDL->propagate_badflag( mask, 0 ); /* propagate badflag if inplace AND its changed */ $SETPDLSTATEGOOD(mask); /* always make sure the output is "good" */ ', Doc => 'Sets C<$mask> true if C<$a> is not a C or C (either positive or negative). Works inplace.', BadDoc => 'Bad values are treated as C or C.', ); # Extra functions from cephes pp_def( "erfi", HandleBad => 1, NoBadifNaN => 1, GenericTypes => $F, Pars => 'a(); [o]b()', Inplace => 1, Doc => inplace_doc( "erfi" ), Code => 'extern double ndtri(double), SQRTH; $b() = SQRTH*ndtri((1+(double)$a())/2);', BadCode => 'extern double ndtri(double), SQRTH; if ( $ISBAD(a()) ) { $SETBAD(b()); } else { $b() = SQRTH*ndtri((1+(double)$a())/2); }', ); pp_def( "ndtri", HandleBad => 1, NoBadifNaN => 1, GenericTypes => $F, Pars => 'a(); [o]b()', Inplace => 1, Doc => inplace_doc( "ndtri" ), Code => 'extern double ndtri(double); $b() = ndtri((double)$a());', BadCode => 'extern double ndtri(double); if ( $ISBAD(a()) ) { $SETBAD(b()); } else { $b() = ndtri((double)$a()); }', ); pp_def("polyroots", Pars => 'cr(n); ci(n); [o]rr(m); [o]ri(m);', RedoDimsCode => '$SIZE(m) = $PDL(cr)->dims[0]-1;', GenericTypes => ['D'], Code => ' extern int cpoly( double *cr, double *ci, int deg, double *rr, double *ri ); int deg = (int)$SIZE(n)-1; if (cpoly($P(cr), $P(ci), deg, $P(rr), $P(ri))) $CROAK("PDL::Math::polyroots failed"); ', , Doc => ' =for ref Complex roots of a complex polynomial, given coefficients in order of decreasing powers. =for usage ($rr, $ri) = polyroots($cr, $ci); ',); pp_addpm({At=>'Bot'},<<'EOD'); =head1 BUGS Hasn't been tested on all platforms to ensure Cephes versions are picked up automatically and used correctly. =head1 AUTHOR Copyright (C) R.J.R. Williams 1997 (rjrw@ast.leeds.ac.uk), Karl Glazebrook (kgb@aaoepp.aao.gov.au) and Tuomas J. Lukka (Tuomas.Lukka@helsinki.fi). Portions (C) Craig DeForest 2002 (deforest@boulder.swri.edu). 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 PDL copyright notice should be included in the file. =cut EOD pp_done(); PDL-2.074/Basic/Math/protos.h0000644000175000017500000000112414173310401015474 0ustar osboxesosboxes/* * This file was automatically generated by version 1.7 of cextract. * Manual editing not recommended. * * Created: Fri Nov 28 17:00:03 1997 */ #ifndef __CEXTRACT__ extern double j0 ( double x ); extern double y0 ( double x ); extern double jn ( int n, double x ); extern double ndtr ( double a ); extern double j1 ( double x ); extern double y1 ( double x ); extern int mtherr ( char *name, int code ); extern double polevl ( double x, double coef[], int N ); extern double p1evl ( double x, double coef[], int N ); extern double yn ( int n, double x ); #endif /* __CEXTRACT__ */ PDL-2.074/Basic/Math/polevl.c0000644000175000017500000000311414173310620015446 0ustar osboxesosboxes/* polevl.c * p1evl.c * XXX * * Evaluate polynomial * * * * SYNOPSIS: * * int N; * double x, y, coef[N+1], polevl[]; * * y = polevl( x, coef, N ); * * * * DESCRIPTION: * * Evaluates polynomial of degree N: * * 2 N * y = C + C x + C x +...+ C x * 0 1 2 N * * Coefficients are stored in reverse order: * * coef[0] = C , ..., coef[N] = C . * N 0 * * The function p1evl() assumes that coef[N] = 1.0 and is * omitted from the array. Its calling arguments are * otherwise the same as polevl(). * * * SPEED: * * In the interest of speed, there are no checks for out * of bounds arithmetic. This routine is used by most of * the functions in the library. Depending on available * equipment features, the user may wish to rewrite the * program in microcode or assembly language. * */ /* Cephes Math Library Release 2.1: December, 1988 Copyright 1984, 1987, 1988 by Stephen L. Moshier Direct inquiries to 30 Frost Street, Cambridge, MA 02140 */ double polevl( x, coef, N ) double x; double coef[]; int N; { double ans; int i; double *p; p = coef; ans = *p++; i = N; do ans = ans * x + *p++; while( --i ); return( ans ); } /* p1evl() */ /* N * Evaluate polynomial when coefficient of x is 1.0. * Otherwise same as polevl. */ double p1evl( x, coef, N ) double x; double coef[]; int N; { double ans; double *p; int i; p = coef; ans = x + *p++; i = N-1; do ans = ans * x + *p++; while( --i ); return( ans ); } PDL-2.074/Basic/Math/mconf.h0000644000175000017500000001053114173310610015254 0ustar osboxesosboxes/* mconf.h * * Common include file for math routines * * * * SYNOPSIS: * * #include "mconf.h" * * * * DESCRIPTION: * * This file contains definitions for error codes that are * passed to the common error handling routine mtherr() * (which see). * * The file also includes a conditional assembly definition * for the type of computer arithmetic (IEEE, DEC, Motorola * IEEE, or UNKnown). * * For Digital Equipment PDP-11 and VAX computers, certain * IBM systems, and others that use numbers with a 56-bit * significand, the symbol DEC should be defined. In this * mode, most floating point constants are given as arrays * of octal integers to eliminate decimal to binary conversion * errors that might be introduced by the compiler. * * For little-endian computers, such as IBM PC, that follow the * IEEE Standard for Binary Floating Point Arithmetic (ANSI/IEEE * Std 754-1985), the symbol IBMPC should be defined. These * numbers have 53-bit significands. In this mode, constants * are provided as arrays of hexadecimal 16 bit integers. * * Big-endian IEEE format is denoted MIEEE. On some RISC * systems such as Sun SPARC, double precision constants * must be stored on 8-byte address boundaries. Since integer * arrays may be aligned differently, the MIEEE configuration * may fail on such machines. * * To accommodate other types of computer arithmetic, all * constants are also provided in a normal decimal radix * which one can hope are correctly converted to a suitable * format by the available C language compiler. To invoke * this mode, define the symbol UNK. * * An important difference among these modes is a predefined * set of machine arithmetic constants for each. The numbers * MACHEP (the machine roundoff error), MAXNUM (largest number * represented), and several other parameters are preset by * the configuration symbol. Check the file const.c to * ensure that these values are correct for your computer. * * Configurations NANS, INFINITIES, MINUSZERO, and DENORMAL * may fail on many systems. Verify that they are supposed * to work on your computer. */ /* Cephes Math Library Release 2.3: June, 1995 Copyright 1984, 1987, 1989, 1995 by Stephen L. Moshier */ /* For PDL, use system defaults where possible */ #include #if !defined(WIN32) && !defined(_WIN32) && !defined(__APPLE__) /* values.h is gone on OpenBSD(?) and depracated on GNU systems */ /* can we use values.h on all UN*X systems? */ #if defined __GNUC__ #include #else #include #endif /* __GNUC__ */ #endif /* Now include system-specific stuff */ /* Look for system quiet_nan function */ #if defined __sun && ! defined __GNUC__ #include #include #include #define NANARG 1L #define NANARG_SIGNATURE long n #endif #if defined __alpha && ! defined __linux #include #include #endif #ifndef NANARG #define NANARG #define NANARG_SIGNATURE #endif /* Redefine nan so PDL doesn't die when we see one. OK, nasty, but means the C-code is still as in the original */ #define nan() quiet_nan(NANARG) /* Constant definitions for math error conditions */ #ifndef DOMAIN #define DOMAIN 1 /* argument domain error */ #endif #ifndef SING #define SING 2 /* argument singularity */ #endif #ifndef OVERFLOW #define OVERFLOW 3 /* overflow range error */ #endif #ifndef UNDERFLOW #define UNDERFLOW 4 /* underflow range error */ #endif #ifndef TLOSS #define TLOSS 5 /* total loss of precision */ #endif #ifndef PLOSS #define PLOSS 6 /* partial loss of precision */ #endif #ifndef EDOM #define EDOM 33 #endif #ifndef ERANGE #define ERANGE 34 #endif /* Complex numeral. */ typedef struct { double r; double i; } cmplx; /* Long double complex numeral. */ typedef struct { double r; double i; } cmplxl; #define ANSIPROT #include "protos.h" /* Variable for error reporting. See mtherr.c. */ extern int merror; #ifdef MY_QUIET_NAN extern double quiet_nan(NANARG_SIGNATURE); #endif #ifdef MY_INFINITY extern double infinity(); #endif extern double MACHEP; extern double UFLOWTHRESH; extern double MAXLOG; extern double MINLOG; extern double MAXNUM; #ifndef PI extern double PI; #endif extern double PIO2; extern double PIO4; extern double SQRT2; extern double SQRTH; extern double LOG2E; extern double SQ2OPI; extern double LOGE2; extern double LOGSQ2; extern double THPIO4; extern double TWOOPI; PDL-2.074/Basic/Math/ndtri.c0000644000175000017500000001012114173310620015261 0ustar osboxesosboxes/* ndtri.c * * Inverse of Normal distribution function * * * * SYNOPSIS: * * double x, y, ndtri(); * * x = ndtri( y ); * * * * DESCRIPTION: * * Returns the argument, x, for which the area under the * Gaussian probability density function (integrated from * minus infinity to x) is equal to y. * * * For small arguments 0 < y < exp(-2), the program computes * z = sqrt( -2.0 * log(y) ); then the approximation is * x = z - log(z)/z - (1/z) P(1/z) / Q(1/z). * There are two rational functions P/Q, one for 0 < y < exp(-32) * and the other for y up to exp(-2). For larger arguments, * w = y - 0.5, and x/sqrt(2pi) = w + w**3 R(w**2)/S(w**2)). * * * ACCURACY: * * Relative error: * arithmetic domain # trials peak rms * DEC 0.125, 1 5500 9.5e-17 2.1e-17 * DEC 6e-39, 0.135 3500 5.7e-17 1.3e-17 * IEEE 0.125, 1 20000 7.2e-16 1.3e-16 * IEEE 3e-308, 0.135 50000 4.6e-16 9.8e-17 * * * ERROR MESSAGES: * * message condition value returned * ndtri domain x <= 0 -MAXNUM * ndtri domain x >= 1 MAXNUM * */ /* Cephes Math Library Release 2.1: January, 1989 Copyright 1984, 1987, 1989 by Stephen L. Moshier Direct inquiries to 30 Frost Street, Cambridge, MA 02140 */ #include "mconf.h" extern double MAXNUM; /* sqrt(2pi) */ static double s2pi = 2.50662827463100050242E0; /* approximation for 0 <= |y - 0.5| <= 3/8 */ static double P0[5] = { -5.99633501014107895267E1, 9.80010754185999661536E1, -5.66762857469070293439E1, 1.39312609387279679503E1, -1.23916583867381258016E0, }; static double Q0[8] = { /* 1.00000000000000000000E0,*/ 1.95448858338141759834E0, 4.67627912898881538453E0, 8.63602421390890590575E1, -2.25462687854119370527E2, 2.00260212380060660359E2, -8.20372256168333339912E1, 1.59056225126211695515E1, -1.18331621121330003142E0, }; /* Approximation for interval z = sqrt(-2 log y ) between 2 and 8 * i.e., y between exp(-2) = .135 and exp(-32) = 1.27e-14. */ static double P1[9] = { 4.05544892305962419923E0, 3.15251094599893866154E1, 5.71628192246421288162E1, 4.40805073893200834700E1, 1.46849561928858024014E1, 2.18663306850790267539E0, -1.40256079171354495875E-1, -3.50424626827848203418E-2, -8.57456785154685413611E-4, }; static double Q1[8] = { /* 1.00000000000000000000E0,*/ 1.57799883256466749731E1, 4.53907635128879210584E1, 4.13172038254672030440E1, 1.50425385692907503408E1, 2.50464946208309415979E0, -1.42182922854787788574E-1, -3.80806407691578277194E-2, -9.33259480895457427372E-4, }; /* Approximation for interval z = sqrt(-2 log y ) between 8 and 64 * i.e., y between exp(-32) = 1.27e-14 and exp(-2048) = 3.67e-890. */ static double P2[9] = { 3.23774891776946035970E0, 6.91522889068984211695E0, 3.93881025292474443415E0, 1.33303460815807542389E0, 2.01485389549179081538E-1, 1.23716634817820021358E-2, 3.01581553508235416007E-4, 2.65806974686737550832E-6, 6.23974539184983293730E-9, }; static double Q2[8] = { /* 1.00000000000000000000E0,*/ 6.02427039364742014255E0, 3.67983563856160859403E0, 1.37702099489081330271E0, 2.16236993594496635890E-1, 1.34204006088543189037E-2, 3.28014464682127739104E-4, 2.89247864745380683936E-6, 6.79019408009981274425E-9, }; #ifndef ANSIPROT double polevl(), p1evl(), log(), sqrt(); #endif double ndtri(y0) double y0; { double x, y, z, y2, x0, x1; int code; if( y0 <= 0.0 ) { mtherr( "ndtri", DOMAIN ); return( -MAXNUM ); } if( y0 >= 1.0 ) { mtherr( "ndtri", DOMAIN ); return( MAXNUM ); } code = 1; y = y0; if( y > (1.0 - 0.13533528323661269189) ) /* 0.135... = exp(-2) */ { y = 1.0 - y; code = 0; } if( y > 0.13533528323661269189 ) { y = y - 0.5; y2 = y * y; x = y + y * (y2 * polevl( y2, P0, 4)/p1evl( y2, Q0, 8 )); x = x * s2pi; return(x); } x = sqrt( -2.0 * log(y) ); x0 = x - log(x)/x; z = 1.0/x; if( x < 8.0 ) /* y > exp(-32) = 1.2664165549e-14 */ x1 = z * polevl( z, P1, 8 )/p1evl( z, Q1, 8 ); else x1 = z * polevl( z, P2, 8 )/p1evl( z, Q2, 8 ); x = x0 - x1; if( code != 0 ) x = -x; return( x ); } PDL-2.074/Basic/Math/NOTES0000644000175000017500000000247613265417442014641 0ustar osboxesosboxesNotes ----- Fixed to -DUNK (for reasons given below), but tried to get as much information on system specifics as possible from header files (may need to reconfigure mconf.h on systems other than Linux/Sun/Dec). Altered handling of nan and infinity to try to provide a consistent interface through function calls (system dependencies go in Makefile.PL, mconf.h: infinity.c and quiet_nan.c may need more obscure fallback ways of generating Inf and NaN for clever-clever compilers). More work will now be necessary to include extra cephes routines, but should be easier to configure what's there for new OSs. RJRW 29/10/98 - added linalg.shar TJL 5/1/98 Cephes lib config ----------------- I leave the default as -DUNK (mconf.h). This is OK as all it means is that the important constants are in floating point format rather than binary hex. The only advantage of the latter is that it is exact, however we prefer portability to exactly the same numbers at the epsilon level. (After all PDL also uses system routines). We can ignore the comments about BIGENDIAN - it is not used in any of the .c files we have taken from cephes, **AT LEAST SO FAR**. The PP code includes protos.h whether or not the system routines are used. Since the prototypes for system and cephes versions should be the same this is not a big deal. KGB 28/11/97 PDL-2.074/Basic/Math/mtherr.c0000644000175000017500000000447714173310620015463 0ustar osboxesosboxes/* mtherr.c * * Library common error handling routine * * * * SYNOPSIS: * * char *fctnam; * int code; * int mtherr(); * * mtherr( fctnam, code ); * * * * DESCRIPTION: * * This routine may be called to report one of the following * error conditions (in the include file mconf.h). * * Mnemonic Value Significance * * DOMAIN 1 argument domain error * SING 2 function singularity * OVERFLOW 3 overflow range error * UNDERFLOW 4 underflow range error * TLOSS 5 total loss of precision * PLOSS 6 partial loss of precision * EDOM 33 Unix domain error code * ERANGE 34 Unix range error code * * The default version of the file prints the function name, * passed to it by the pointer fctnam, followed by the * error condition. The display is directed to the standard * output device. The routine then returns to the calling * program. Users may wish to modify the program to abort by * calling exit() under severe error conditions such as domain * errors. * * Since all error conditions pass control to this function, * the display may be easily changed, eliminated, or directed * to an error logging device. * * SEE ALSO: * * mconf.h * */ /* Cephes Math Library Release 2.0: April, 1987 Copyright 1984, 1987 by Stephen L. Moshier Direct inquiries to 30 Frost Street, Cambridge, MA 02140 */ #include #include "mconf.h" int merror = 0; /* Notice: the order of appearance of the following * messages is bound to the error codes defined * in mconf.h. */ static char *ermsg[7] = { "unknown", /* error code 0 */ "domain", /* error code 1 */ "singularity", /* et seq. */ "overflow", "underflow", "total loss of precision", "partial loss of precision" }; int mtherr( name, code ) char *name; int code; { /* Display string passed by calling program, * which is supposed to be the name of the * function in which the error occurred: */ printf( "\n%s ", name ); /* Set global error message word */ merror = code; /* Display error message defined * by the code argument. */ if( (code <= 0) || (code >= 7) ) code = 0; printf( "%s error\n", ermsg[code] ); /* Return to calling * program */ return( 0 ); } PDL-2.074/Basic/Math/jn.c0000644000175000017500000000356214173310620014563 0ustar osboxesosboxes/* jn.c * * Bessel function of integer order * * * * SYNOPSIS: * * int n; * double x, y, jn(); * * y = jn( n, x ); * * * * DESCRIPTION: * * Returns Bessel function of order n, where n is a * (possibly negative) integer. * * The ratio of jn(x) to j0(x) is computed by backward * recurrence. First the ratio jn/jn-1 is found by a * continued fraction expansion. Then the recurrence * relating successive orders is applied until j0 or j1 is * reached. * * If n = 0 or 1 the routine for j0 or j1 is called * directly. * * * * ACCURACY: * * Absolute error: * arithmetic range # trials peak rms * DEC 0, 30 5500 6.9e-17 9.3e-18 * IEEE 0, 30 5000 4.4e-16 7.9e-17 * * * Not suitable for large n or x. Use jv() instead. * */ /* jn.c Cephes Math Library Release 2.0: April, 1987 Copyright 1984, 1987 by Stephen L. Moshier Direct inquiries to 30 Frost Street, Cambridge, MA 02140 */ #include "mconf.h" extern double MACHEP; double jn( n, x ) int n; double x; { double pkm2, pkm1, pk, xk, r, ans; int k, sign; double fabs(), j0(), j1(); if( n < 0 ) { n = -n; if( (n & 1) == 0 ) /* -1**n */ sign = 1; else sign = -1; } else sign = 1; if( n == 0 ) return( sign * j0(x) ); if( n == 1 ) return( sign * j1(x) ); if( n == 2 ) return( sign * (2.0 * j1(x) / x - j0(x)) ); if( x < MACHEP ) return( 0.0 ); /* continued fraction */ #ifdef DEC k = 56; #else k = 53; #endif pk = 2 * (n + k); ans = pk; xk = x * x; do { pk -= 2.0; ans = pk - (xk/ans); } while( --k > 0 ); ans = x/ans; /* backward recurrence */ pk = 1.0; pkm1 = 1.0/ans; k = n-1; r = 2 * k; do { pkm2 = (pkm1 * r - pk * x) / x; pk = pkm1; pkm1 = pkm2; r -= 2.0; } while( --k > 0 ); if( fabs(pk) > fabs(pkm1) ) ans = j1(x)/pk; else ans = j0(x)/pkm1; return( sign * ans ); } PDL-2.074/Basic/Math/j0.c0000644000175000017500000001274714173310620014472 0ustar osboxesosboxes/* j0.c * * Bessel function of order zero * * * * SYNOPSIS: * * double x, y, j0(); * * y = j0( x ); * * * * DESCRIPTION: * * Returns Bessel function of order zero of the argument. * * The domain is divided into the intervals [0, 5] and * (5, infinity). In the first interval the following rational * approximation is used: * * * 2 2 * (w - r ) (w - r ) P (w) / Q (w) * 1 2 3 8 * * 2 * where w = x and the two r's are zeros of the function. * * In the second interval, the Hankel asymptotic expansion * is employed with two rational functions of degree 6/6 * and 7/7. * * * * ACCURACY: * * Absolute error: * arithmetic domain # trials peak rms * DEC 0, 30 10000 4.4e-17 6.3e-18 * IEEE 0, 30 60000 4.2e-16 1.1e-16 * */ /* y0.c * * Bessel function of the second kind, order zero * * * * SYNOPSIS: * * double x, y, y0(); * * y = y0( x ); * * * * DESCRIPTION: * * Returns Bessel function of the second kind, of order * zero, of the argument. * * The domain is divided into the intervals [0, 5] and * (5, infinity). In the first interval a rational approximation * R(x) is employed to compute * y0(x) = R(x) + 2 * log(x) * j0(x) / PI. * Thus a call to j0() is required. * * In the second interval, the Hankel asymptotic expansion * is employed with two rational functions of degree 6/6 * and 7/7. * * * * ACCURACY: * * Absolute error, when y0(x) < 1; else relative error: * * arithmetic domain # trials peak rms * DEC 0, 30 9400 7.0e-17 7.9e-18 * IEEE 0, 30 30000 1.3e-15 1.6e-16 * */ /* Cephes Math Library Release 2.1: January, 1989 Copyright 1984, 1987, 1989 by Stephen L. Moshier Direct inquiries to 30 Frost Street, Cambridge, MA 02140 */ /* Note: all coefficients satisfy the relative error criterion * except YP, YQ which are designed for absolute error. */ #include "mconf.h" static double PP[7] = { 7.96936729297347051624E-4, 8.28352392107440799803E-2, 1.23953371646414299388E0, 5.44725003058768775090E0, 8.74716500199817011941E0, 5.30324038235394892183E0, 9.99999999999999997821E-1, }; static double PQ[7] = { 9.24408810558863637013E-4, 8.56288474354474431428E-2, 1.25352743901058953537E0, 5.47097740330417105182E0, 8.76190883237069594232E0, 5.30605288235394617618E0, 1.00000000000000000218E0, }; static double QP[8] = { -1.13663838898469149931E-2, -1.28252718670509318512E0, -1.95539544257735972385E1, -9.32060152123768231369E1, -1.77681167980488050595E2, -1.47077505154951170175E2, -5.14105326766599330220E1, -6.05014350600728481186E0, }; static double QQ[7] = { /* 1.00000000000000000000E0,*/ 6.43178256118178023184E1, 8.56430025976980587198E2, 3.88240183605401609683E3, 7.24046774195652478189E3, 5.93072701187316984827E3, 2.06209331660327847417E3, 2.42005740240291393179E2, }; static double YP[8] = { 1.55924367855235737965E4, -1.46639295903971606143E7, 5.43526477051876500413E9, -9.82136065717911466409E11, 8.75906394395366999549E13, -3.46628303384729719441E15, 4.42733268572569800351E16, -1.84950800436986690637E16, }; static double YQ[7] = { /* 1.00000000000000000000E0,*/ 1.04128353664259848412E3, 6.26107330137134956842E5, 2.68919633393814121987E8, 8.64002487103935000337E10, 2.02979612750105546709E13, 3.17157752842975028269E15, 2.50596256172653059228E17, }; /* 5.783185962946784521175995758455807035071 */ static double DR1 = 5.78318596294678452118E0; /* 30.47126234366208639907816317502275584842 */ static double DR2 = 3.04712623436620863991E1; static double RP[4] = { -4.79443220978201773821E9, 1.95617491946556577543E12, -2.49248344360967716204E14, 9.70862251047306323952E15, }; static double RQ[8] = { /* 1.00000000000000000000E0,*/ 4.99563147152651017219E2, 1.73785401676374683123E5, 4.84409658339962045305E7, 1.11855537045356834862E10, 2.11277520115489217587E12, 3.10518229857422583814E14, 3.18121955943204943306E16, 1.71086294081043136091E18, }; double j0(x) double x; { double polevl(), p1evl(); double w, z, p, q, xn; double sin(), cos(), sqrt(); extern double PIO4, SQ2OPI; if( x < 0 ) x = -x; if( x <= 5.0 ) { z = x * x; if( x < 1.0e-5 ) return( 1.0 - z/4.0 ); p = (z - DR1) * (z - DR2); p = p * polevl( z, RP, 3)/p1evl( z, RQ, 8 ); return( p ); } w = 5.0/x; q = 25.0/(x*x); p = polevl( q, PP, 6)/polevl( q, PQ, 6 ); q = polevl( q, QP, 7)/p1evl( q, QQ, 7 ); xn = x - PIO4; p = p * cos(xn) - w * q * sin(xn); return( p * SQ2OPI / sqrt(x) ); } /* y0() 2 */ /* Bessel function of second kind, order zero */ /* Rational approximation coefficients YP[], YQ[] are used here. * The function computed is y0(x) - 2 * log(x) * j0(x) / PI, * whose value at x = 0 is 2 * ( log(0.5) + EUL ) / PI * = 0.073804295108687225. */ /* #define PIO4 .78539816339744830962 #define SQ2OPI .79788456080286535588 */ extern double MAXNUM; double y0(x) double x; { double polevl(), p1evl(); double w, z, p, q, xn; double j0(), log(), sin(), cos(), sqrt(); extern double TWOOPI, SQ2OPI, PIO4; if( x <= 5.0 ) { if( x <= 0.0 ) { mtherr( "y0", DOMAIN ); return( -MAXNUM ); } z = x * x; w = polevl( z, YP, 7) / p1evl( z, YQ, 7 ); w += TWOOPI * log(x) * j0(x); return( w ); } w = 5.0/x; z = 25.0 / (x * x); p = polevl( z, PP, 6)/polevl( z, PQ, 6 ); q = polevl( z, QP, 7)/p1evl( z, QQ, 7 ); xn = x - PIO4; p = p * sin(xn) + w * q * cos(xn); return( p * SQ2OPI / sqrt(x) ); } PDL-2.074/Basic/Math/j1.c0000644000175000017500000001133614173310620014464 0ustar osboxesosboxes/* j1.c * * Bessel function of order one * * * * SYNOPSIS: * * double x, y, j1(); * * y = j1( x ); * * * * DESCRIPTION: * * Returns Bessel function of order one of the argument. * * The domain is divided into the intervals [0, 8] and * (8, infinity). In the first interval a 24 term Chebyshev * expansion is used. In the second, the asymptotic * trigonometric representation is employed using two * rational functions of degree 5/5. * * * * ACCURACY: * * Absolute error: * arithmetic domain # trials peak rms * DEC 0, 30 10000 4.0e-17 1.1e-17 * IEEE 0, 30 30000 2.6e-16 1.1e-16 * * */ /* y1.c * * Bessel function of second kind of order one * * * * SYNOPSIS: * * double x, y, y1(); * * y = y1( x ); * * * * DESCRIPTION: * * Returns Bessel function of the second kind of order one * of the argument. * * The domain is divided into the intervals [0, 8] and * (8, infinity). In the first interval a 25 term Chebyshev * expansion is used, and a call to j1() is required. * In the second, the asymptotic trigonometric representation * is employed using two rational functions of degree 5/5. * * * * ACCURACY: * * Absolute error: * arithmetic domain # trials peak rms * DEC 0, 30 10000 8.6e-17 1.3e-17 * IEEE 0, 30 30000 1.0e-15 1.3e-16 * * (error criterion relative when |y1| > 1). * */ /* Cephes Math Library Release 2.1: January, 1989 Copyright 1984, 1987, 1989 by Stephen L. Moshier Direct inquiries to 30 Frost Street, Cambridge, MA 02140 */ /* #define PIO4 .78539816339744830962 #define THPIO4 2.35619449019234492885 #define SQ2OPI .79788456080286535588 */ #include "mconf.h" static double RP[4] = { -8.99971225705559398224E8, 4.52228297998194034323E11, -7.27494245221818276015E13, 3.68295732863852883286E15, }; static double RQ[8] = { /* 1.00000000000000000000E0,*/ 6.20836478118054335476E2, 2.56987256757748830383E5, 8.35146791431949253037E7, 2.21511595479792499675E10, 4.74914122079991414898E12, 7.84369607876235854894E14, 8.95222336184627338078E16, 5.32278620332680085395E18, }; static double PP[7] = { 7.62125616208173112003E-4, 7.31397056940917570436E-2, 1.12719608129684925192E0, 5.11207951146807644818E0, 8.42404590141772420927E0, 5.21451598682361504063E0, 1.00000000000000000254E0, }; static double PQ[7] = { 5.71323128072548699714E-4, 6.88455908754495404082E-2, 1.10514232634061696926E0, 5.07386386128601488557E0, 8.39985554327604159757E0, 5.20982848682361821619E0, 9.99999999999999997461E-1, }; static double QP[8] = { 5.10862594750176621635E-2, 4.98213872951233449420E0, 7.58238284132545283818E1, 3.66779609360150777800E2, 7.10856304998926107277E2, 5.97489612400613639965E2, 2.11688757100572135698E2, 2.52070205858023719784E1, }; static double QQ[7] = { /* 1.00000000000000000000E0,*/ 7.42373277035675149943E1, 1.05644886038262816351E3, 4.98641058337653607651E3, 9.56231892404756170795E3, 7.99704160447350683650E3, 2.82619278517639096600E3, 3.36093607810698293419E2, }; static double YP[6] = { 1.26320474790178026440E9, -6.47355876379160291031E11, 1.14509511541823727583E14, -8.12770255501325109621E15, 2.02439475713594898196E17, -7.78877196265950026825E17, }; static double YQ[8] = { /* 1.00000000000000000000E0,*/ 5.94301592346128195359E2, 2.35564092943068577943E5, 7.34811944459721705660E7, 1.87601316108706159478E10, 3.88231277496238566008E12, 6.20557727146953693363E14, 6.87141087355300489866E16, 3.97270608116560655612E18, }; static double Z1 = 1.46819706421238932572E1; static double Z2 = 4.92184563216946036703E1; double j1(x) double x; { extern double THPIO4, SQ2OPI; double polevl(), p1evl(); double w, z, p, q, xn; double sin(), cos(), sqrt(); w = x; if( x < 0 ) w = -x; if( w <= 5.0 ) { z = x * x; w = polevl( z, RP, 3 ) / p1evl( z, RQ, 8 ); w = w * x * (z - Z1) * (z - Z2); return( w ); } w = 5.0/x; z = w * w; p = polevl( z, PP, 6)/polevl( z, PQ, 6 ); q = polevl( z, QP, 7)/p1evl( z, QQ, 7 ); xn = x - THPIO4; p = p * cos(xn) - w * q * sin(xn); return( p * SQ2OPI / sqrt(x) ); } extern double MAXNUM; double y1(x) double x; { extern double TWOOPI, THPIO4, SQ2OPI; double polevl(), p1evl(); double w, z, p, q, xn; double j1(), log(), sin(), cos(), sqrt(); if( x <= 5.0 ) { if( x <= 0.0 ) { mtherr( "y1", DOMAIN ); return( -MAXNUM ); } z = x * x; w = x * (polevl( z, YP, 5 ) / p1evl( z, YQ, 8 )); w += TWOOPI * ( j1(x) * log(x) - 1.0/x ); return( w ); } w = 5.0/x; z = w * w; p = polevl( z, PP, 6)/polevl( z, PQ, 6 ); q = polevl( z, QP, 7)/p1evl( z, QQ, 7 ); xn = x - THPIO4; p = p * sin(xn) + w * q * cos(xn); return( p * SQ2OPI / sqrt(x) ); } PDL-2.074/Basic/Math/ndtr.c0000644000175000017500000000546014173310620015122 0ustar osboxesosboxes/* ndtr.c * * Normal distribution function * * * * SYNOPSIS: * * double x, y, ndtr(); * * y = ndtr( x ); * * * * DESCRIPTION: * * Returns the area under the Gaussian probability density * function, integrated from minus infinity to x: * * x * - * 1 | | 2 * ndtr(x) = --------- | exp( - t /2 ) dt * sqrt(2pi) | | * - * -inf. * * = ( 1 + erf(z) ) / 2 * = erfc(z) / 2 * * where z = x/sqrt(2). Computation is via the functions * erf and erfc. * * * ACCURACY: * * Relative error: * arithmetic domain # trials peak rms * DEC -13,0 8000 2.1e-15 4.8e-16 * IEEE -13,0 30000 3.4e-14 6.7e-15 * * * ERROR MESSAGES: * * message condition value returned * erfc underflow x > 37.519379347 0.0 * */ /* Cephes Math Library Release 2.2: June, 1992 Copyright 1984, 1987, 1988, 1992 by Stephen L. Moshier Direct inquiries to 30 Frost Street, Cambridge, MA 02140 */ #include "mconf.h" extern double SQRTH; extern double MAXLOG; static double P[] = { 2.46196981473530512524E-10, 5.64189564831068821977E-1, 7.46321056442269912687E0, 4.86371970985681366614E1, 1.96520832956077098242E2, 5.26445194995477358631E2, 9.34528527171957607540E2, 1.02755188689515710272E3, 5.57535335369399327526E2 }; static double Q[] = { /* 1.00000000000000000000E0,*/ 1.32281951154744992508E1, 8.67072140885989742329E1, 3.54937778887819891062E2, 9.75708501743205489753E2, 1.82390916687909736289E3, 2.24633760818710981792E3, 1.65666309194161350182E3, 5.57535340817727675546E2 }; static double R[] = { 5.64189583547755073984E-1, 1.27536670759978104416E0, 5.01905042251180477414E0, 6.16021097993053585195E0, 7.40974269950448939160E0, 2.97886665372100240670E0 }; static double S[] = { /* 1.00000000000000000000E0,*/ 2.26052863220117276590E0, 9.39603524938001434673E0, 1.20489539808096656605E1, 1.70814450747565897222E1, 9.60896809063285878198E0, 3.36907645100081516050E0 }; static double T[] = { 9.60497373987051638749E0, 9.00260197203842689217E1, 2.23200534594684319226E3, 7.00332514112805075473E3, 5.55923013010394962768E4 }; static double U[] = { /* 1.00000000000000000000E0,*/ 3.35617141647503099647E1, 5.21357949780152679795E2, 4.59432382970980127987E3, 2.26290000613890934246E4, 4.92673942608635921086E4 }; #define UTHRESH 37.519379347 #ifndef ANSIPROT double polevl(), p1evl(), exp(), log(), fabs(); #endif double ndtr(a) double a; { double x, y, z; x = a * SQRTH; z = fabs(x); if( z < SQRTH ) y = 0.5 + 0.5 * erf(x); else { y = 0.5 * erfc(z); if( x > 0 ) y = 1.0 - y; } return(y); } PDL-2.074/Basic/Math/cpoly.h0000644000175000017500000000043614160714722015313 0ustar osboxesosboxes#ifdef DEBUGMAIN void prtc(int n, double p[], double q[]); void prtz(int n,double zr[], double zi[]); #endif int cpoly(double opr[], double opi[], int degree, double zeror[], double zeroi[]); #if !defined(FALSE) #define FALSE (0) #endif #if !defined(TRUE) #define TRUE (1) #endif PDL-2.074/Basic/Math/infinity.c0000644000175000017500000000024414173310620015777 0ustar osboxesosboxes#include "mconf.h" double infinity(void) { #ifdef DBL_INFINITY return DBL_INFINITY; #else double a=0; return 1./a; /* Expect divide by zero error */ #endif } PDL-2.074/Basic/Math/yn.c0000644000175000017500000000336014173310620014576 0ustar osboxesosboxes/* yn.c * * Bessel function of second kind of integer order * * * * SYNOPSIS: * * double x, y, yn(); * int n; * * y = yn( n, x ); * * * * DESCRIPTION: * * Returns Bessel function of order n, where n is a * (possibly negative) integer. * * The function is evaluated by forward recurrence on * n, starting with values computed by the routines * y0() and y1(). * * If n = 0 or 1 the routine for y0 or y1 is called * directly. * * * * ACCURACY: * * * Absolute error, except relative * when y > 1: * arithmetic domain # trials peak rms * DEC 0, 30 2200 2.9e-16 5.3e-17 * IEEE 0, 30 30000 3.4e-15 4.3e-16 * * * ERROR MESSAGES: * * message condition value returned * yn singularity x = 0 MAXNUM * yn overflow MAXNUM * * Spot checked against tables for x, n between 0 and 100. * */ /* Cephes Math Library Release 2.1: December, 1988 Copyright 1984, 1987 by Stephen L. Moshier Direct inquiries to 30 Frost Street, Cambridge, MA 02140 */ #include "mconf.h" extern double MAXNUM, MAXLOG; double yn( n, x ) int n; double x; { double an, anm1, anm2, r; double y0(), y1(), log(); int k, sign; if( n < 0 ) { n = -n; if( (n & 1) == 0 ) /* -1**n */ sign = 1; else sign = -1; } else sign = 1; if( n == 0 ) return( sign * y0(x) ); if( n == 1 ) return( sign * y1(x) ); /* test for overflow */ if( x <= 0.0 ) { mtherr( "yn", SING ); return( -MAXNUM ); } /* forward recurrence on n */ anm2 = y0(x); anm1 = y1(x); k = 1; r = 2 * k; do { an = r * anm1 / x - anm2; anm2 = anm1; anm1 = an; r += 2.0; ++k; } while( k < n ); return( sign * an ); } PDL-2.074/Basic/Math/Makefile.PL0000644000175000017500000000653214160015533015763 0ustar osboxesosboxesuse strict; use warnings; use ExtUtils::MakeMaker; use File::Basename; use Config; use File::Spec; sub cdir { return File::Spec->catdir(@_)} sub is_sys_func { my ( $code, $libs, $dir ) = @_; trylink( '', qq{#include "$dir/mconf.h"}, $code, $libs ); } # Files for each routine (.c assumed) my %source = qw( j0 j0 j1 j1 jn jn y0 j0 y1 j1 yn yn erfi ndtri ndtri ndtri rint rint nan quiet_nan infinity infinity polyroots cpoly ); my @keys = sort keys %source; my %included = (); # test for library features my (@sfuncs) = qw(nan infinity); my (@ufuncs2) = qw(acosh asinh atanh erf erfc rint); my (@besufuncs) = qw(j0 j1 y0 y1); my (@besbifuncs) = qw(jn yn); my ($libs) = $^O =~ /MSWin/ ? '' : $^O =~ /cygwin/ ? getcyglib('m') : '-lm'; if ($^O eq 'solaris' or $^O eq 'sunos') { # try to guess where sunmath is my @d = split /:+/, $ENV{LD_LIBRARY_PATH}; my $ok = 0; for my $d (@d) { if (-e "$d/libsunmath.so" or -e "$d/libsunmath.a" ) { $libs = "-lsunmath $libs"; $ok = 1; last; } } if (!$ok) { print "libsunmath not found in LD_LIBRARY_PATH: looking elsewhere\n"; # get root directory of compiler; may be off of there my @dirs = (); foreach my $p ( split(':', $ENV{'PATH'} ) ) { next unless -e "$p/$Config{cc}"; push @dirs, dirname($p) . '/lib'; last; } push @dirs, '/opt/SUNWspro/lib'; # default location if all else fails for my $d ( @dirs ) { if (-e "$d/libsunmath.so") { $libs = "-R$d -L$d -lsunmath $libs"; $ok = 1; last; } if (-e "$d/libsunmath.a") { $libs = "-L$d -lsunmath $libs"; $ok = 1; last; } } } if (!$ok) { print "Couldn't find sunmath library in standard places\n"; print "If you can find libsunmath.a or libsunmath.so\n"; print "please let us know at pdl-devel\@lists.sourceforge.net\n"; } } # Test for absence of unary functions use Cwd; my $mmdir = my $mdir = cdir 'Basic','Math'; $mmdir =~ s/\\/\\\\/g; my $dir = File::Spec->canonpath(cwd); $dir = cdir $dir, $mdir unless $dir =~ /$mmdir$/; foreach (@sfuncs) { $source{$_} = 'system' if is_sys_func( "$_();", $libs, $dir ); } foreach (@ufuncs2) { $source{$_} = 'system' if is_sys_func( "$_(1.);", $libs, $dir ); } # Test for absence of besfuncs foreach (@besufuncs) { if ( is_sys_func( "$_(1.);", $libs, $dir ) ) { $source{$_} = 'system'; next if $_ ne 'y0'; } } foreach (@besbifuncs) { next if ! exists $source{$_}; # May have been deleted in buggy case $source{$_} = 'system' if is_sys_func( "$_(1,1.);", $libs, $dir ); } my @pack = (["math.pd", qw(Math PDL::Math)]); my %hash = pdlpp_stdargs_int(@pack); my %seen = (); # Build object file list foreach my $func (@keys) { my $file = $source{$func}; next if $file eq 'system'; die "File for function $func not found\n" if $file eq ''; $hash{OBJECT} .= " $file\$(OBJ_EXT)" unless $seen{$file}++; $hash{DEFINE} .= ' -DMY_'.uc($func); } # Add support routines $hash{OBJECT} .= " const\$(OBJ_EXT) mtherr\$(OBJ_EXT) polevl\$(OBJ_EXT)"; $hash{LIBS}->[0] .= " $libs"; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.074/Basic/Math/rint.c0000644000175000017500000000263414173310620015127 0ustar osboxesosboxes/* * Round to neareast integer * * SYNOPSIS: * * double rint(double x); * * DESCRIPTION: * * Returns the integer (represented as a double precision number) * nearest to x. For half-integers, this implements "banker's * rounding", or round-half-to-even, in which half integers are * rounded to the nearest even integer. For other floating-point * numbers, returns floor(x + 0.5); * * Copyright (c) 1998, Raphael Manfredi * (c) 2010, Derek Lamb Note that other functions in PDL::Math use code from the Cephes math library. If this new Banker's rounding code causes some problems, it is possible to rename the round.c provided therein and use it here. 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. */ #include "mconf.h" double rint(x) double x; { //could do recursion but this is probably more memory efficient. int i = x; //just get the integer part if (x<0 && (i==x+0.5)){//if it is a neg half integer return i-(i&1); //subtract one if it is odd } else if (x>0 && (i==x-0.5)){//if it is a pos half integer return i+(i&1); //add one if it is odd } else return floor(x+0.5); } PDL-2.074/Basic/Pod/0000755000175000017500000000000014200406301013624 5ustar osboxesosboxesPDL-2.074/Basic/Pod/Graphics.pod0000644000175000017500000001075114164776572016131 0ustar osboxesosboxespackage PDL::Graphics; =head1 NAME PDL::Graphics - Introduction to the PDL::Graphics modules =head1 DESCRIPTION PDL has full-featured plotting abilities. Unlike MATLAB, PDL relies more on third-party libraries for its plotting features: Prima, Gnuplot, OpenGL, PLplot and PGplot. PDL has several plotting modules that you can choose from, each of them with their particular strength and weaknesses. In this page, you will find a short review of each of the main PDL::Graphics::* modules. =head1 GRAPHIC MODULES REVIEWS =head2 The newest generation of PDL::Graphics modules =head3 L Best for: backend-independent output: you get the same plots, whichever of the graphical module you manage to install. A unified backend-independent plotting interface for PDL. It implements all the functionality used in the L examples, and it will probably be the easiest L module for you to install, as it relies on any of the other ones. Because it is backend-independent, the plot you get will always be what you asked for, regardless of which plotting engine you have installed on your system. Only a small subset of PDL's complete graphics functionality is supported -- each individual plotting module has unique advantages and functionality that are beyond what L can do. =head3 L Best for: publication-quality 2D and 3D plots Gnuplot is widely used and produces publication-quality plots. It is also interactive: you can pan, scale, and rotate both 2-D and 3-D plots. And its API is powerful, simple and intuitive. A L

and C because the user may have sent ndarrays with extra threading dimensions. Of course, the temporary ndarray C (note the [t] flag) should not be given any thread dimensions anyway. You can also use C to set the dimension of a ndarray flagged with [o]. In this case you set the dimensions for the named dimension in the signature using $SIZE() as in the preceding example. However, because the ndarray is flagged with [o] instead of [t], threading dimensions will be added if required just as if the size of the dimension were computed from the signature according to the usual rules. Here is an example from PDL::Math pp_def("polyroots", Pars => 'cr(n); ci(n); [o]rr(m); [o]ri(m);', RedoDimsCode => 'PDL_Indx sn = $PDL(cr)->dims[0]; $SIZE(m) = sn-1;', The input ndarrays are the real and imaginary parts of complex coefficients of a polynomial. The output ndarrays are real and imaginary parts of the roots. There are C roots to an Cth order polynomial and such a polynomial has C coefficients (the zero-th through the Cth). In this example, threading will work correctly. That is, the first dimension of the output ndarray with have its dimension adjusted, but other threading dimensions will be assigned just as if there were no C. =head3 RedoDims passed directly A C value as above gets processed, including expanding macros, and adding type-generic loops. For very specific purposes, you may not want this processing done to your dimension-updating code, probably in "slice"-like functions. Then, instead of passing a C value, you can pass a C value (which the C would otherwise get processed into). Because you will probably want to access the ndarrays, the following macros are provided. They are named assuming you will have the first parameter as C and the second as C, which is the case if you passed a true C value, which you will basically always want to do for this scenario. =over =item $CHILD_PTR() =item $PARENT_PTR() These expand to a C pointer, e.g. to pass to a PDL API function. =item $CHILD() =item $PARENT() These expand to a lookup into C struct, e.g. C<$CHILD(ndims)> looks up the C value for the child parameter. =back =head3 RedoDims generated from EquivPDimExpr and EquivDimCheck Another way to generate the C code is to supply a C and maybe a C: pp_def( 'xchg', OtherPars => 'PDL_Indx n1; PDL_Indx n2;', TwoWay => 1, P2Child => 1, AffinePriv => 1, EquivDimCheck => ' if ($COMP(n1) <0) $COMP(n1) += $PARENT(threadids[0]); if ($COMP(n2) <0) $COMP(n2) += $PARENT(threadids[0]); if (PDLMIN($COMP(n1),$COMP(n2)) <0 || PDLMAX($COMP(n1),$COMP(n2)) >= $PARENT(threadids[0])) $CROAK("One of dims %d, %d out of range: should be 0<=dim<%d", $COMP(n1),$COMP(n2),$PARENT(threadids[0]));', EquivPDimExpr => ' (($CDIM == $COMP(n1)) ? $COMP(n2) : ($CDIM == $COMP(n2)) ? $COMP(n1) : $CDIM) ', ); C is evaluated within a loop, and the value of the relevant dimension is available using the macro C<$CDIM> as shown above. =head2 Typemap handling in the OtherPars section The C section discussed above is very often absolutely crucial when you interface external libraries with PDL. However in many cases the external libraries either use derived types or pointers of various types. The standard way to handle this in Perl is to use a F file. This is discussed in some detail in L in the standard Perl documentation. In PP the functionality is very similar, so you can create a F file in the directory where your PP file resides and when it is built it is automatically read in to figure out the appropriate translation between the C type and Perl's built-in type. For instance the C function has the following C declaration: int gsl_spline_init(gsl_spline * spline, const double xa[], const double ya[], size_t size); Clearly the C and C arrays are candidates for being passed in as ndarrays and the C argument is just the length of these ndarrays so that can be handled by the C<$SIZE()> macro in PP. Write an C declaration of the form OtherPars => 'gsl_spline *spl' and write a short F file which handles this type: TYPEMAP gsl_spline * T_PTR and use it in the code: pp_def('init_meat', Pars => 'double x(n); double y(n);', OtherPars => 'gsl_spline *spl', Code =>'gsl_spline_init,($COMP(spl),$P(x),$P(y),$SIZE(n)));' ); where I have removed a macro wrapper call, but that would obscure the discussion. =head2 Other useful PP keys in data operation definitions You have already heard about the C key. Currently, there are not many other keys for a data operation that will be useful in normal (whatever that is) PP programming. In fact, it would be interesting to hear about a case where you think you need more than what is provided at the moment. Please speak up on one of the PDL mailing lists. Most other keys recognised by C are only really useful for what we call I (see also above). One thing that is strongly being planned is variable number of arguments, which will be a little tricky. An incomplete list of the available keys: =head3 Inplace Setting this key marks the routine as working inplace - ie the input and output ndarrays are the same. An example is C<$x-Einplace-Esqrt()> (or C). =over 4 =item Inplace => 1 Use when the routine is a unary function, such as C. =item Inplace => ['a'] If there are more than one input ndarrays, specify the name of the one that can be changed inplace using an array reference. =item Inplace => ['a','b'] If there are more than one output ndarray, specify the name of the input ndarray and output ndarray in a 2-element array reference. This probably isn't needed, but left in for completeness. =back If bad values are being used, care must be taken to ensure the propagation of the badflag when inplace is being used; consider this excerpt from F: pp_def('replacebad',HandleBad => 1, Pars => 'a(); [o]b();', OtherPars => 'double newval', Inplace => 1, CopyBadStatusCode => '/* propagate badflag if inplace AND it has changed */ if ( a == b && $ISPDLSTATEBAD(a) ) PDL->propagate_badflag( b, 0 ); /* always make sure the output is "good" */ $SETPDLSTATEGOOD(b); ', ... Since this routine removes all bad values, the output ndarray had its bad flag cleared. If run inplace (so C), then we have to tell all the children of C that the bad flag has been cleared (to save time we make sure that we call C<< PDL->propagate_badflag >> only if the input ndarray had its bad flag set). NOTE: one idea is that the documentation for the routine could be automatically flagged to indicate that it can be executed inplace, ie something similar to how C sets C if it's not supplied (it's not an ideal solution). =head3 FTypes # in slices.pd FTypes => {CHILD => '$COMP(totype)'}, The value is a hash-ref mapping parameter-names to an expression giving an override of the type for that parameter. The example above shows the type being overridden to the C "totype". =head3 OtherParsDefaults OtherPars => 'int a; int b', OtherParsDefaults => { b => 0 }, Allows specifying default values for C. It is an error to specify a default for one that is before another that does not have a default. =head2 Other PDL::PP functions to support concise package definition So far, we have described the C and C functions. PDL::PP exports a few other functions to aid you in writing concise PDL extension package definitions. =head3 pp_addhdr Often when you interface library functions as in the above example you have to include additional C include files. Since the XS file is generated by PP we need some means to make PP insert the appropriate include directives in the right place into the generated XS file. To this end there is the C function. This is also the function to use when you want to define some C functions for internal use by some of the XS functions (which are mostly functions defined by C). By including these functions here you make sure that PDL::PP inserts your code before the point where the actual XS module section begins and will therefore be left untouched by xsubpp (cf. I and I man pages). A typical call would be pp_addhdr(' #include /* we need defs of XXXX */ #include "libprotos.h" /* prototypes of library functions */ #include "mylocaldecs.h" /* Local decs */ static void do_the real_work(PDL_Byte * in, PDL_Byte * out, int n) { /* do some calculations with the data */ } '); This ensures that all the constants and prototypes you need will be properly included and that you can use the internal functions defined here in the Cs, e.g.: pp_def('barfoo', Pars => ' a(n); [o] b(n)', GenericTypes => ['B'], Code => ' PDL_Indx ns = $SIZE(n); do_the_real_work($P(a),$P(b),ns); ', ); =head3 pp_addpm In many cases the actual PP code (meaning the arguments to C calls) is only part of the package you are currently implementing. Often there is additional Perl code and XS code you would normally have written into the pm and XS files which are now automatically generated by PP. So how to get this stuff into those dynamically generated files? Fortunately, there are a couple of functions, generally called C that assist you in doing this. Let's assume you have additional Perl code that should go into the generated B-file. This is easily achieved with the C command: pp_addpm(<<'EOD'); =head1 NAME PDL::Lib::Mylib -- a PDL interface to the Mylib library =head1 DESCRIPTION This package implements an interface to the Mylib package with full threading and indexing support (see L). =cut use PGPLOT; =head2 use_myfunc this function applies the myfunc operation to all the elements of the input pdl regardless of dimensions and returns the sum of the result =cut sub use_myfunc { my $pdl = shift; myfunc($pdl->clump(-1),($res=null)); return $res->sum; } EOD =head3 pp_add_exported You have probably got the idea. In some cases you also want to export your additional functions. To avoid getting into trouble with PP which also messes around with the C<@EXPORT> array you just tell PP to add your functions to the list of exported functions: pp_add_exported('use_myfunc gethynx'); =head3 pp_add_isa The C command works like the the C function. The arguments to C are added the @ISA list, e.g. pp_add_isa(' Some::Other::Class '); =head3 pp_bless If your pp_def routines are to be used as object methods use C to specify the package (i.e. class) to which your Ied methods will be added. For example, C. The default is C if this is omitted. =head3 pp_addxs Sometimes you want to add extra XS code of your own (that is generally not involved with any threading/indexing issues but supplies some other functionality you want to access from the Perl side) to the generated XS file, for example pp_addxs('',' # Determine endianness of machine int isbigendian() CODE: unsigned short i; PDL_Byte *b; i = 42; b = (PDL_Byte*) (void*) &i; if (*b == 42) RETVAL = 0; else if (*(b+1) == 42) RETVAL = 1; else croak("Impossible - machine is neither big nor little endian!!\n"); OUTPUT: RETVAL '); Especially C and C should be used with care. PP uses PDL::Exporter, hence letting PP export your function means that they get added to the standard list of function exported by default (the list defined by the export tag ``:Func''). If you use C you shouldn't try to do anything that involves threading or indexing directly. PP is much better at generating the appropriate code from your definitions. =head3 pp_add_boot Finally, you may want to add some code to the BOOT section of the XS file (if you don't know what that is check I). This is easily done with the C command: pp_add_boot(<descrip = descrip; GlobalStruc->maxfiles = 200; EOB =head3 pp_export_nothing By default, PP.pm puts all subs defined using the pp_def function into the output .pm file's EXPORT list. This can create problems if you are creating a subclassed object where you don't want any methods exported. (i.e. the methods will only be called using the $object->method syntax). For these cases you can call pp_export_nothing() to clear out the export list. Example (At the end of the .pd file): pp_export_nothing(); pp_done(); =head3 pp_core_importList By default, PP.pm puts the 'use Core;' line into the output .pm file. This imports Core's exported names into the current namespace, which can create problems if you are over-riding one of Core's methods in the current file. You end up getting messages like "Warning: sub sumover redefined in file subclass.pm" when running the program. For these cases the pp_core_importList can be used to change what is imported from Core.pm. For example: pp_core_importList('()') This would result in use Core(); being generated in the output .pm file. This would result in no names being imported from Core.pm. Similarly, calling pp_core_importList(' qw/ barf /') would result in use Core qw/ barf/; being generated in the output .pm file. This would result in just 'barf' being imported from Core.pm. =head3 pp_setversion Simultaneously set the F<.pm> and F<.xs> files' versions, thus avoiding unnecessary version-skew between the two. To use this, simply do this in your .pd file, probably near the top: our $VERSION = '0.0.3'; pp_setversion($VERSION); # Then, in your Makefile.PL: my @package = qw(FFTW3.pd FFTW3 PDL::FFTW3); my %descriptor = pdlpp_stdargs(\@package); $descriptor{VERSION_FROM} = 'FFTW3.pd'; # EUMM can parse the format above However, don't use this if you use L. See that module's documentation for details. =head3 pp_deprecate_module If a particular module is deemed obsolete, this function can be used to mark it as deprecated. This has the effect of emitting a warning when a user tries to C the module. The generated POD for this module also carries a deprecation notice. The replacement module can be passed as an argument like this: pp_deprecate_module( infavor => "PDL::NewNonDeprecatedModule" ); Note that function affects I the runtime warning and the POD. =head1 MAKING YOUR PP FUNCTION PRIVATE Let's say that you have a function in your module called PDL::foo that uses the PP function C to do the heavy lifting. But you don't want to advertise that C exists. To do this, you must move your PP function to the top of your module file, then call pp_export_nothing() to clear the C list. To ensure that no documentation (even the default PP docs) is generated, set Doc => undef and to prevent the function from being added to the symbol table, set PMFunc => '' in your pp_def declaration (see Image2D.pd for an example). This will effectively make your PP function "private." However, it is I accessible via PDL::bar_pp due to Perl's module design. But making it private will cause the user to go very far out of his or her way to use it, so he or she shoulders the consequences! =head1 SLICE OPERATION The slice operations require a much more intimate knowledge of PDL internals than the data operations. Furthermore, the complexity of the issues involved is considerably higher than that in the average data operation. Nevertheless, functions generated using the slice operations are at the heart of the index manipulation and dataflow capabilities of PDL. You can get started by reading the section on L. Also, there are a lot of dirty issues with virtual ndarrays and vaffines which we shall entirely skip here. =head2 Slices and bad values Slice operations need to be able to handle bad values. The easiest thing to do is look at F to see how this works. Along with C, there are also the C and C keys for C. However, any C should I need changing, since any changes are absorbed into the definition of the C<$EQUIVCPOFFS()> macro (i.e. it is handled automatically by PDL::PP). =head1 Handling of C and C in PP Code For printing warning messages or aborting/dieing, you can call C or C from PP code. However, you should be aware that these calls have been redefined using C preprocessor macros to C<< PDL->barf >> and C<< PDL->warn >>. These redefinitions are in place to keep you from inadvertently calling perl's C or C directly, which can cause segfaults during pthreading (i.e. processor multi-threading). PDL's own versions of C and C will queue-up warning or barf messages until after pthreading is completed, and then call the perl versions of these routines. See L for more information on pthreading. B As of 2.064, it is B that you do not call C at all in PP code, but instead use C<$CROAK()>. This will return a C which will transparently be used to throw the correct exception in Perl code, but can be handled suitably by non-Perl callers. =head1 MAKEFILES FOR PP FILES If you are going to generate a package from your PP file (typical file extensions are C<.pd> or C<.pp> for the files containing PP code) it is easiest and safest to leave generation of the appropriate commands to the Makefile. In the following we will outline the typical format of a Perl Makefile to automatically build and install your package from a description in a PP file. Most of the rules to build the xs, pm and other required files from the PP file are already predefined in the PDL::Core::Dev package. We just have to tell MakeMaker to use it. In most cases you can define your Makefile like use PDL::Core::Dev; # Pick up development utilities use ExtUtils::MakeMaker; $package = ["mylib.pd",Mylib,PDL::Lib::Mylib,'',1]; %hash = pdlpp_stdargs($package); $hash{OBJECT} .= ' additional_Ccode$(OBJ_EXT) '; WriteMakefile(%hash); sub MY::postamble { pdlpp_postamble($package); } # additional_Ccode.c #include "pdl.h" void ppcp(PDL_Byte *dst, PDL_Byte *src, int len) { int i; for (i=0;i is: first: PP source file name, then the prefix for the produced files, the whole package name, the package to add XS functions to (empty string to use the same as the PP functions), and a boolean to dictate whether to have PDL generate a separate C file for each PP function (for faster compilation). The last feature is opt-in as you have to avoid duplicate symbols when linking the library (so separate out C functions into their own file). You can modify the hash in whatever way you like but it would be reasonable to stay within some limits so that your package will continue to work with later versions of PDL. To make life even easier PDL::Core::Dev defines the function C that returns a hash with default values that can be passed (either directly or after appropriate modification) to a call to WriteMakefile. Currently, C returns a hash where the keys are filled in as follows: ( 'NAME' => $mod, VERSION_FROM => $src, 'TYPEMAPS' => [&PDL_TYPEMAP()], 'OBJECT' => "$pref\$(OBJ_EXT)", PM => {"$pref.pm" => "\$(INST_LIBDIR)/$pref.pm"}, MAN3PODS => {"$pref.pm" => "\$(INST_MAN3DIR)/$mod.\$(MAN3EXT)"}, 'INC' => &PDL_INCLUDE(), 'LIBS' => [''], 'clean' => {'FILES' => "$pref.xs $pref.pm $pref\$(OBJ_EXT)"}, ) Here, C<$src> is the name of the source file with PP code, C<$pref> the prefix for the generated .pm and .xs files and C<$mod> the name of the extension module to generate. If your C provides a version, PP will use that to set the C. If you need to influence the value of that variable so that L etc don't reject the loaded dynamic library, you can use this workaround in a C (the C is because the C happens at runtime, and your code appears after that call, but with a C it will take place beforehand): our $VERSION; BEGIN { $VERSION = '2.019106' }; our $XS_VERSION; BEGIN { $XS_VERSION = $VERSION }; =head1 INTERNALS The internals of the current version consist of a large table which gives the rules according to which things are translated and the subs which implement these rules. Later on, it would be good to make the table modifiable by the user so that different things may be tried. [Meta comment: here will hopefully be more in the future; currently, your best bet will be to read the source code :-( or ask on the list (try the latter first) ] =head1 C PREPROCESSOR MACROS As well as the above-mentioned C and C, there are also C, C, and C: $b() = PDL_IF_GENTYPE_INTEGER(0,NAN); =head1 Appendix A: Some keys recognised by PDL::PP Unless otherwise specified, the arguments are strings. =head3 Pars define the signature of your function =head3 OtherPars arguments which are not pdls. Default: nothing. This is a semi-colon separated list of arguments, e.g., C<< OtherPars=>'int k; double value; PerlIO *fp' >>. See C<$COMP(x)> and also the same entry in L. =head3 Code the actual code that implements the functionality; several PP macros and PP functions are recognised in the string value =head3 HandleBad If set to 1, the routine is assumed to support bad values and the code in the BadCode key is used if bad values are present; it also sets things up so that the C<$ISBAD()> etc macros can be used. If set to 0, cause the routine to print a warning if any of the input ndarrays have their bad flag set. =head3 BadCode Give the code to be used if bad values may be present in the input ndarrays. Only used if C<< HandleBad => 1 >>. If C is true and C is not supplied, the C section will be reused, on the assumption it will use C<#ifdef PDL_BAD_CODE> to handle bad values. As of 2.073, you can also use C. =head3 GenericTypes An array reference. The array may contain any subset of the one-character strings given below, which specify which types your operation will accept. The meaning of each type is: B - signed byte (i.e. signed char) S - signed short (two-byte integer) U - unsigned short L - signed long (four-byte integer, int on 32 bit systems) N - signed integer for indexing ndarray elements (platform & Perl-dependent size) Q - signed long long (eight byte integer) F - float D - double G - complex float C - complex double This is very useful (and important!) when interfacing an external library. Default: [qw/B S U L N Q F D/] =head3 Inplace Mark a function as being able to work inplace. Inplace => 1 if Pars => 'a(); [o]b();' Inplace => ['a'] if Pars => 'a(); b(); [o]c();' Inplace => ['a','c'] if Pars => 'a(); b(); [o]c(); [o]d();' If bad values are being used, care must be taken to ensure the propagation of the badflag when inplace is being used; for instance see the code for C in F. =head3 Doc Used to specify a documentation string in Pod format. See PDL::Doc for information on PDL documentation conventions. Note: in the special case where the PP 'Doc' string is one line this is implicitly used for the quick reference AND the documentation! If the Doc field is omitted PP will generate default documentation (after all it knows about the Signature). If you really want the function NOT to be documented in any way at this point (e.g. for an internal routine, or because you are doing it elsewhere in the code) explicitly specify Cundef>. =head3 BadDoc Contains the text returned by the C command (in C) or the C<-b> switch to the C shell script. In many cases, you will not need to specify this, since the information can be automatically created by PDL::PP. However, as befits computer-generated text, it's rather stilted; it may be much better to do it yourself! =head3 NoPthread Optional flag to indicate the PDL function should B use processor threads (i.e. pthreads or POSIX threads) to split up work across multiple CPU cores. This option is typically set to 1 if the underlying PDL function is not threadsafe. If this option isn't present, then the function is assumed to be threadsafe. This option only applies if PDL has been compiled with POSIX threads enabled. =head3 PMCode pp_def('funcname', Pars => 'a(); [o] b();', PMCode => 'sub PDL::funcname { return PDL::_funcname_int(@_) if @_ == 2; # output arg "b" supplied PDL::_funcname_int(@_, my $out = PDL->null); $out; }', # ... ); PDL functions allow C<[o]> ndarray arguments into which you want the output saved. This is handy because you can allocate an output ndarray once and reuse it many times; the alternative would be for PDL to create a new ndarray each time, which may waste compute cycles or, more likely, RAM. PDL functions check the number of arguments they are given, and call C if given the wrong number. By default (with no C supplied), any output arguments may be omitted, and PDL::PP provides code that can handle this by creating C objects, passing them to your code, then returning them on the stack. If you I supply C, the rest of PDL::PP assumes it will be a string that defines a Perl function with the function's name in the C package (C by default). As the example implies, the PP-generated function name will change from C<< >>, to C<< __int >>. As also shown above, you will need to supply all ndarrays in the exact order specified in the signature: output ndarrays are not optional, and the PP-generated function will not return anything. =head3 PMFunc When pp_def generates functions, it typically defines them in the PDL package. Then, in the .pm file that it generates for your module, it typically adds a line that essentially copies that function into your current package's symbol table with code that looks like this: *func_name = \&PDL::func_name; It's a little bit smarter than that (it knows when to wrap that sort of thing in a BEGIN block, for example, and if you specified something different for pp_bless), but that's the gist of it. If you don't care to import the function into your current package's symbol table, you can specify PMFunc => '', PMFunc has no other side-effects, so you could use it to insert arbitrary Perl code into your module if you like. However, you should use pp_addpm if you want to add Perl code to your module. =head3 ReadDataFuncName Allows overriding the default function-name, for reading data transformed by this operation. Mainly used internally to set it to C, in which case a default affine-orientated function will be called instead. =head3 WriteBackDataFuncName As above, but for writing transformed data from a child of this transformation back to the parent when C is supplied. =head3 AffinePriv Flag to indicate this is an affine transformation whose C (contents of the C) contains data that will need allocating and freeing. =head3 GlobalNew If supplied, will prevent generation of an XS function, and assigns the generated C "run" function into the named slot in the C struct. This is not used as of 2.058, and instead the relevant C functions are in F. =head3 P2Child Forces C to be C and C, the function's C to be all of them, no C or C, and turns on C (so do not supply any of those args). Intended for affine transformations with dataflow. =head3 DefaultFlow If true, sets in the C (see L) the C such that the trans will start with dataflow both forwards and backwards. =head3 HaveThreading Default true. If so, generate code implementing threading (see L). =head3 CallCopy For parameters that get created, normally the C<< PDL->initialize >> will be used (or on a subclass). If this is true (which is the default for simple functions i.e. 2-arg with 0-dim signatures), instead the first argument's C method will be used. =head3 TwoWay If true, sets in the C (see L) the C such as to inform the trans's error checks connected to dataflow. =head3 Identity If true, sets C C C C C such that the function is a dataflowing identity transformation. =head3 BackCode For dataflowing functions, this value (which gets parsed) overrides the operation of that from children ndarrays to parents. =head3 BadBackCode Same but taking account of bad values. =head3 EquivCPOffsCode If supplied, allows concise control of copying to Child from Parent the data considered Equivalent at each given Offset (hence the name); the C and C will be generated from this. Example: pp_def( '_clump_int', OtherPars => 'int n', P2Child => 1, RedoDims => # omitted EquivCPOffsCode => ' PDL_Indx i; for(i=0; i<$PDL(CHILD)->nvals; i++) $EQUIVCPOFFS(i,i); ', ); =head1 Appendix B: PP macros and functions =head2 Macros =head3 $I() access a pdl (by its name) that was specified in the signature =head3 $COMP(x) access a value in the private data structure of this transformation (mainly used to use an argument that is specified in the C section) =head3 $SIZE(n) replaced at runtime by the actual size of a I dimension (as specified in the I) =head3 $GENERIC() replaced by the C type that is equal to the runtime type of the operation =head3 $P(a) a pointer to the data of the PDL named C in the signature. Useful for interfacing to C functions =head3 $PP(a) a physical pointer access to pdl C; mainly for internal use =head3 $TXYZ(AlternativeX,AlternativeY,AlternativeZ) expansion alternatives according to runtime type of operation, where XXX is some string that is matched by C. =head3 $PDL(a) return a pointer to the pdl data structure (pdl *) of ndarray C =head3 $ISBAD(a()) returns true if the value stored in C equals the bad value for this ndarray. Requires C being set to 1. =head3 $ISGOOD(a()) returns true if the value stored in C does not equal the bad value for this ndarray. Requires C being set to 1. =head3 $SETBAD(a()) Sets C to equal the bad value for this ndarray. Requires C being set to 1. =head3 $PRIV() To access fields in the C, eg C<$PRIV(offs)>. =head3 $CROAK() Returns a C with the supplied (var-args) message, adding the function name at the start, which will cause a C within the Perl code. This is (as of 2.064) a change in PDL functions' API, so that callers can handle exceptions in their preferred way, which may not use Perl at all. =head3 $EQUIVCPOFFS() Copy from the C parameter at the first given offset, to the C parameter at the second given offset. =head3 $EQUIVCPTRUNC() Similar, but if the expression given as the third parameter is false, instead set the C's value to 0. =head3 $DOCOMPALLOC() Allocates memory for any C arrays, after their size has been determined, e.g. here after C<$COMP(whichdims_count)> has been set: Comp => 'PDL_Indx whichdims[$COMP(whichdims_count)]', =head3 $DOPRIVALLOC() As above, except the key is C; because it is "Priv", this is only for entries in the C itself, and almost certainly only for operations where C is true. =head3 $SETNDIMS() For affine transformations (specifically, ones which set P2Child to true), set the child's C to the given value and allocate a suitably-sized array of dimension values. =head3 $SETDIMS() Similarly for affine transformations, after the above and then the actual dimension sizes are set, use this to resize the child ndarray to the right size. =head3 $SETDELTATHREADIDS() Similarly again, this sets the child's C to the same as the parent's, allocates space for the C, then sets the child's ones to the same as the parent's plus the given value. To get a flavour of what C are for, in the normal way of things the first (0th) one in the parent is the highest dimension-number in it. See L for more. =head2 functions =head3 C loop over named dimensions; limits are generated automatically by PP =head3 C enclose following code in a thread loop =head3 C execute following code if type of operation is any of C =head1 Appendix C: Functions imported by PDL::PP A number of functions are imported when you C. These include functions that control the generated C or XS code, functions that control the generated Perl code, and functions that manipulate the packages and symbol tables into which the code is created. =head2 Generating C and XS Code PDL::PP's main purpose is to make it easy for you to wrap the threading engine around your own C code, but you can do some other things, too. =head3 pp_def Used to wrap the threading engine around your C code. Virtually all of this document discusses the use of pp_def. =head3 pp_done Indicates you are done with PDL::PP and that it should generate its .xs and .pm files based upon the other pp_* functions that you have called. This function takes no arguments. =head3 pp_addxs This lets you add XS code to your .xs file. This is useful if you want to create Perl-accessible functions that invoke C code but cannot or should not invoke the threading engine. XS is the standard means by which you wrap Perl-accessible C code. You can learn more at L. =head3 pp_add_boot This function adds whatever string you pass to the XS BOOT section. The BOOT section is C code that gets called by Perl when your module is loaded and is useful for automatic initialization. You can learn more about XS and the BOOT section at L. =head3 pp_addhdr Adds pure-C code to your XS file. XS files are structured such that pure C code must come before XS specifications. This allows you to specify such C code. =head3 pp_boundscheck PDL normally checks the bounds of your accesses before making them. You can turn that on or off at runtime by setting MyPackage::set_boundscheck. This function allows you to remove that runtime flexibility and B do bounds checking. It also returns the current boundschecking status if called without any argumens. NOTE: I have not found anything about bounds checking in other documentation. That needs to be addressed. =head2 Generating Perl Code Many functions imported when you use PDL::PP allow you to modify the contents of the generated .pm file. In addition to pp_def and pp_done, the role of these functions is primarily to add code to various parts of your generated .pm file. =head3 pp_addpm Adds Perl code to the generated .pm file. PDL::PP actually keeps track of three different sections of generated code: the Top, the Middle, and the Bottom. You can add Perl code to the Middle section using the one-argument form, where the argument is the Perl code you want to supply. In the two-argument form, the first argument is an anonymous hash with only one key that specifies where to put the second argument, which is the string that you want to add to the .pm file. The hash is one of these three: {At => 'Top'} {At => 'Middle'} {At => 'Bot'} For example: pp_addpm({At => 'Bot'}, < 'Top'}, ...) >>. Unlike pp_addpm, calling this overwrites whatever was there before. Generally, you probably shouldn't use it. =head2 Tracking Line Numbers When you get compile errors, either from your C-like code or your Perl code, it can help to make those errors back to the line numbers in the source file at which the error occurred. =head3 pp_line_numbers Takes a line number and a (usually long) string of code. The line number should indicate the line at which the quote begins. This is usually Perl's C<__LINE__> literal, unless you are using heredocs, in which case it is C<__LINE__ + 1>. The returned string has #line directives interspersed to help the compiler report errors on the proper line. =head2 Modifying the Symbol Table and Export Behavior PDL::PP usually exports all functions generated using pp_def, and usually installs them into the PDL symbol table. However, you can modify this behavior with these functions. =head3 pp_bless Sets the package (symbol table) to which the XS code is added. The default is PDL, which is generally what you want. If you use the default blessing and you create a function myfunc, then you can do the following: $ndarray->myfunc(); PDL::myfunc($ndarray, ); On the other hand, if you bless your functions into another package, you cannot invoke them as PDL methods, and must invoke them as: MyPackage::myfunc($ndarray, ); Of course, you could always use the PMFunc key to add your function to the PDL symbol table, but why do that? =head3 pp_add_isa Adds to the list of modules from which your B inherits. The default list is qw(PDL::Exporter DynaLoader) =head3 pp_core_importlist At the top of your generated .pm file is a line that looks like this: use PDL::Core; You can modify that by specifying a string to pp_core_importlist. For example, pp_core_importlist('::Blarg'); will result in use PDL::Core::Blarg; You can use this, for example, to add a list of symbols to import from PDL::Core. For example: pp_core_importlist(" ':Internal'"); will lead to the following use statement: use PDL::Core ':Internal'; =head3 pp_setversion Sets your module's version. The version must be consistent between the .xs and the .pm file, and is used to ensure that your Perl's libraries do not suffer from version skew. =head3 pp_add_exported Adds to the export list whatever names you give it. Functions created using pp_def are automatically added to the list. This function is useful if you define any Perl functions using pp_addpm or pp_addxs that you want exported as well. =head3 pp_export_nothing This resets the list of exported symbols to nothing. This is probably better called C, since you can add exported symbols after calling C. When called just before calling pp_done, this ensures that your module does not export anything, for example, if you only want programmers to use your functions as methods. =head1 SEE ALSO For the concepts of threading and slicing check L. L L for information on bad values L, L L =head1 BUGS Although PDL::PP is quite flexible and thoroughly used, there are surely bugs. First amongst them: this documentation needs a thorough revision. =head1 AUTHOR Copyright(C) 1997 Tuomas J. Lukka (lukka@fas.harvard.edu), Karl Glaazebrook (kgb@aaocbn1.aao.GOV.AU) and Christian Soeller (c.soeller@auckland.ac.nz). All rights reserved. Documentation updates Copyright(C) 2011 David Mertens (dcmertens.perl@gmail.com). This documentation is licensed under the same terms as Perl itself. PDL-2.074/Basic/Pod/QuickStart.pod0000644000175000017500000004761614146003631016450 0ustar osboxesosboxes =head1 NAME PDL::QuickStart - Quick introduction to PDL features. =head1 SYNOPSIS A brief summary of the main PDL features and how to use them. =head1 DESCRIPTION =head2 Introduction Perl is an extremely good and versatile scripting language, well suited to beginners and allows rapid prototyping. However until recently it did not support data structures which allowed it to do fast number crunching. However with the development of Perl v5, Perl acquired 'Objects'. To put it simply users can define their own special data types, and write custom routines to manipulate them either in low level languages (C and Fortran) or in Perl itself. This has been fully exploited by the PerlDL developers. The 'PDL' module is a complete Object-Oriented extension to Perl (although you don't have to know what an object is to use it) which allows large N-dimensional data sets, such as large images, spectra, time series, etc to be stored B and manipulated B. For example with the PDL module we can write the Perl code C<$x = $y + $z>, where C<$y> and C<$z> are large datasets (e.g. 2048x2048 images), and get the result in only a fraction of a second. PDL variables (or 'ndarrays' as they have come to be known) support a wide range of fundamental data types - arrays can be bytes, short integers (signed or unsigned), long integers, floats or double precision floats. And because of the Object-Oriented nature of PDL new customised datatypes can be derived from them. As well as the PDL modules, that can be used by normal Perl programs, PerlDL comes with a command line Perl shell, called 'perldl', which supports command line editing. In combination with the various PDL graphics modules this allows data to be easily played with and visualised. =head2 Help PDL contains extensive documentation, available both within the I or I shells and from the command line, using the C program. For further information try either of: pdl> help help $ pdldoc HTML copies of the documentation should also be available. To find their location, try the following: pdl> foreach ( map{"$_/PDL/HtmlDocs"}@INC ) { p "$_\n" if -d $_ } =head2 Perl Datatypes and how PDL extends them The fundamental Perl data structures are scalar variables, e.g. C<$x>, which can hold numbers or strings, lists or arrays of scalars, e.g. C<@x>, and associative arrays/hashes of scalars, e.g. C<%x>. Perl v5 introduces to Perl data structures and objects. A simple scalar variable C<$x> now be a user-defined data type or full blown object (it actually holds a reference (a smart "pointer") to this but that is not relevant for ordinary use of perlDL) The fundamental idea behind perlDL is to allow C<$x> to hold a whole 1D spectrum, or a 2D image, a 3D data cube, and so on up to large N-dimensional data sets. These can be manipulated all at once, e.g. C<$x = $y + 2> does a vector operation on each value in the spectrum/image/etc. You may well ask: "Why not just store a spectrum as a simple Perl C<@x> style list with each pixel being a list item?" The two key answers to this are I and I. Because we know our spectrum consists of pure numbers we can compactly store them in a single block of memory corresponding to a C style numeric array. This takes up a LOT less memory than the equivalent Perl list. It is then easy to pass this block of memory to a fast addition routine, or to any other C function which deals with arrays. As a result perlDL is very fast --- for example one can multiply a 2048*2048 image in exactly the same time as it would take in C or FORTRAN (0.1 sec on my SPARC). A further advantage of this is that for simple operations (e.g. C<$x += 2>) one can manipulate the whole array without caring about its dimensionality. I find when using perlDL it is most useful to think of standard Perl C<@x> variables as "lists" of generic "things" and PDL variables like C<$x> as "arrays" which can be contained in lists or hashes. Quite often in my perlDL scripts I have C<@x> contain a list of spectra, or a list of images (or even a mix!). Or perhaps one could have a hash (e.g. C<%x>) of images... the only limit is memory! perlDL variables support a range of data types - arrays can be bytes, short integers (signed or unsigned), long integers, floats or double precision floats. =head2 Usage PerlDL is loaded into your Perl script using this command: use PDL; # in Perl scripts: use the standard perlDL modules There are also a lot of extension modules, e.g. L. Most of these (but not all as sometimes it is not appropriate) follow a standard convention. If you say: use PDL::Graphics::TriD; You import everything in a standard list from the module. Sometimes you might want to import nothing (e.g. if you want to use OO syntax all the time and save the import tax). For these you say: use PDL::Graphics::TriD qw(); And the empty C quotes are recognised as meaning 'nothing'. You can also specify a list of functions to import in the normal Perl way. There is also an interactive shell, C or C, see I or L for details. =head2 To create a new PDL variable Here are some ways of creating a PDL variable: $x = pdl [1..10]; # 1D array $x = pdl (1,2,3,4); # Ditto $x = pdl '[1 2 3 4]'; # Ditto $y = pdl [[1,2,3],[4,5,6]]; # 2D 3x2 array $y = pdl '[1 2 3; 4 5 6]'; # Ditto $y = pdl q[1,2,3; 4,5,6]; # Ditto $y = pdl < function is used to initialise a PDL variable from a scalar, list, list reference, another PDL variable, or a properly formatted string. In addition all PDL functions automatically convert normal Perl scalars to PDL variables on-the-fly. (also see "Type Conversion" and "Input/Output" sections below) =head2 Arithmetic (and boolean expressions) $x = $y + 2; $x++; $x = $y / $c; # Etc. $c=sqrt($x); $d = log10($y+100); # Etc $e = $x>42; # Vector conditional $e = 42*($x>42) + $x*($x<=42); # Cap top $y = $x->log10 unless any ($x <= 0); # avoid floating point error $x = $x / ( max($x) - min($x) ); $f = where($x, $x > 10); # where returns an ndarray of elements for # which the condition is true print $x; # $x in string context prints it in a N-dimensional format (and other Perl operators/functions) When using ndarrays in conditional expressions (i.e. C, C and C constructs) only ndarrays with exactly one element are allowed, e.g. $x = pdl (1,0,0,1); print "is set" if $x->index(2); Note that the boolean operators return in general multi-element ndarrays. Therefore, the following will raise an error print "is ok" if $x > 3; since C<$x E 3> is an ndarray with 4 elements. Rather use L or L to test if all or any of the elements fulfill the condition: print "some are > 3" if any $x>3; print "can't take logarithm" unless all $x>0; There are also many predefined functions, which are described on other man pages. Check L. =head2 Matrix functions C<'x'> is hijacked as the matrix multiplication operator. e.g. C<$c = $x x $y>; perlDL is row-major not column major so this is actually C - but when matrices are printed the results will look right. Just remember the indices are reversed. e.g.: $x = [ $y = [ [ 1 2 3 0] [1 1] [ 1 -1 2 7] [0 2] [ 1 0 0 1] [0 2] ] [1 1] ] gives $c = [ [ 1 11] [ 8 10] [ 2 2] ] Note: L does what it says and is a convenient way to turn row vectors into column vectors. =head2 How to write a simple function sub dotproduct { my ($x,$y) = @_; return sum($x*$y) ; } 1; If put in file dotproduct.pdl would be autoloaded if you are using L (see below). Of course, this function is already available as the L function, see L. =head2 Type Conversion Default for pdl() is double. Conversions are: $x = float($y); $c = long($d); # "long" is generally a 4 byte int $d = byte($x); Also double(), short(), ushort(), indx(). NOTE: The indx() routine is a special integer type that is the correct size for a PDL index value (dimension size, index, or offest) which can be either a 32bit (long) or 64bit (longlong) quantity depending on whether the perl is built with 32bit or 64bit support. These routines also automatically convert Perl lists to allow the convenient shorthand: $x = byte [[1..10],[1..10]]; # Create 2D byte array $x = float [1..1000]; # Create 1D float array etc. =head2 Printing Automatically expands array in N-dimensional format: print $x; $y = "Answer is = $x "; =head2 Sections PDL has very powerful multidimensional slicing and sectioning operators; see L for details; we'll describe the most important one here. PDL shows its Perl/C heritage in that arrays are zero-offset. Thus a 100x100 image has indices C<0..99,0..99>. (The convention is that the I

of pixel (0,0) is at coordinate (0.0,0.0). All PDL graphics functions conform to this definition and hide away the unit offsets of, for example, the PGPLOT FORTRAN library. Following the usual convention coordinate (0,0) is displayed at the bottom left when displaying an image. It appears at the top left when using "C" etc. Simple sectioning uses a syntax extension to Perl, L, that allows you to specify subranges via a null-method modifier to a PDL: $g = $f->($x1:$x2,$y1:$y2,($z1)); # Take subsection Here, C<$f> is a 3-dimensional variable, and C<$g> gets a planar cutout that is defined by the limits $x1, $x2, $y1, $y2, at the location $z1. The parenthesis around C<$z1> cause the trivial index to be omitted -- otherwise C<$g> would be three-dimensional with a third dimension of order 1. You can put PDL slices on either side of the element-wise assignment operator C<.=>, like so: # Set part of $bigimage to values from $smallimage $bigimage->($xa:$xb,$ya:$yb) .= $smallimage; Some other miscellany: $c = nelem($x); # Number of pixels $val = at($object, $x,$y,$z...) # Pixel value at position, as a Perl scalar $val = $object->at($x,$y,$z...) # equivalent (method syntax OK) $y = xvals($x); # Fill array with X-coord values (also yvals(), zvals(), # axisvals($x,$axis) and rvals() for radial distance # from centre). =head2 Input/Output The C modules implement several useful IO format functions. It would be too much to give examples of each, but you can find a nice overview at L. Here is a sample of some of the supported IO formats in PDL. =over 8 =item PDL::IO::Misc Ascii, FITS and FIGARO/NDF IO routines. =item PDL::IO::FastRaw Using the raw data types of your machine, an unportable but blindingly fast IO format. Also supports memory mapping to conserve memory as well as get more speed. =item PDL::IO::FlexRaw General raw data formats. Like FastRaw, only better. =item PDL::IO::Browser A Curses browser for arrays. =item PDL::IO::Pnm Portaple bitmap and pixmap support. =item PDL::IO::Pic Using the previous module and netpbm, makes it possible to easily write GIF, jpeg and whatever with simple commands. =back =head2 Graphics The philosophy behind perlDL is to make it work with a variety of existing graphics libraries since no single package will satisfy all needs and all people and this allows one to work with packages one already knows and likes. Obviously there will be some overlaps in functionality and some lack of consistency and uniformity. However this allows PDL to keep up with a rapidly developing field - the latest PDL modules provide interfaces to OpenGL and VRML graphics! =over 4 =item PDL::Graphics::PGPLOT PGPLOT provides a simple library for line graphics and image display. There is an easy interface to this in the internal module L, which calls routines in the separately available PGPLOT top-level module. =item PDL::Graphics::PLplot PLplot provides a simple library for creating graphics with multiple output drivers, including a direct-to-ndarray driver. This module provides both high-level and low-level functionality built on PLplot. The low-level commands are pretty much direct bindings to PLplot's C interface. Read more at L. =item PDL::Graphics::IIS Many astronomers like to use SAOimage and Ximtool (or there derivations/clones). These are useful free widgets for inspection and visualisation of images. (They are not provided with perlDL but can easily be obtained from their official sites off the Net.) The L package provides allows one to display images in these ("IIS" is the name of an ancient item of image display hardware whose protocols these tools conform to.) =item PDL::Graphics::TriD See L, this is a collection of 3D routines for OpenGL and (soon) VRML and other 3D formats which allow 3D point, line, and surface plots from PDL. =back =head2 Autoloading See L. This allows one to autoload functions on demand, in a way perhaps familiar to users of MatLab. One can also write PDL extensions as normal Perl modules. =head2 PDL shells The Perl script C (or C) provides a simple command line interface to PDL. If the latest Readlines/ReadKey modules have been installed C detects this and enables command line recall and editing. See the man page for details. e.g.: % perldl perlDL shell v1.354 PDL comes with ABSOLUTELY NO WARRANTY. For details, see the file 'COPYING' in the PDL distribution. This is free software and you are welcome to redistribute it under certain conditions, see the same file for details. ReadLines, NiceSlice, MultiLines enabled Reading PDL/default.perldlrc... Found docs database /home/pdl/dev/lib/perl5/site_perl/PDL/pdldoc.db Type 'help' for online help Type 'demo' for online demos Loaded PDL v2.4.9_003 (supports bad values) pdl> $x = rfits 'm51.fits' Reading IMAGE data... BITPIX = 32 size = 147456 pixels Reading 589824 bytes BSCALE = && BZERO = pdl> use PDL::Graphics::PGPLOT; pdl> imag $x Displaying 384 x 384 image from 40 to 761, using 84 colors (16-99)... You can also run it from the Perl debugger (C) if you want. Miscellaneous shell features: =over 4 =item p The shell aliases C

to be a convenient short form of C, e.g. pdl> p ones 5,3 [ [1 1 1 1 1] [1 1 1 1 1] [1 1 1 1 1] ] =item Initialization The files C<~/.perldlrc> and C (in the current directory) are sourced if found. This allows the user to have global and local PDL code for startup. =item Help Type 'help'! One can search the PDL documentation, and look up documentation on any function. =item Escape Any line starting with the C<#> character is treated as a shell escape. This character is configurable by setting the Perl variable C<$PERLDL_ESCAPE>. This could, for example, be set in C<~/.perldlrc>. =back =head2 Overload operators The following builtin Perl operators and functions have been overloaded to work on PDL variables: + - * / > < >= <= << >> & | ^ == != <=> ** % ! ~ sin log abs atan2 sqrt cos exp [All the unary functions (sin etc.) may be used with inplace() - see "Memory" below.] =head2 Object-Orientation and perlDL PDL operations are available as functions and methods. Thus one can derive new types of object, to represent custom data classes. By using overloading one can make mathematical operators do whatever you please, and PDL has some built-in tricks which allow existing PDL functions to work unchanged, even if the underlying data representation is vastly changed! See L =head2 Memory usage and references Messing around with really huge data arrays may require some care. perlDL provides many facilities to let you perform operations on big arrays without generating extra copies though this does require a bit more thought and care from the programmer. NOTE: On some most systems it is better to configure Perl (during the build options) to use the system C function rather than Perl's built-in one. This is because Perl's one is optimised for speed rather than consumption of virtual memory - this can result in a factor of two improvement in the amount of memory storage you can use. The Perl malloc in 5.004 and later does have a number of compile-time options you can use to tune the behaviour. =over =item Simple arithmetic If $x is a big image (e.g. occupying 10MB) then the command $x = $x + 1; eats up another 10MB of memory. This is because the expression C<$x+1> creates a temporary copy of C<$x> to hold the result, then C<$x> is assigned a reference to that. After this, the original C<$x> is destroyed so there is no I memory waste. But on a small machine, the growth in the memory footprint can be considerable. It is obviously done this way so C<$c=$x+1> works as expected. Also if one says: $y = $x; # $y and $x now point to same data $x = $x + 1; Then C<$y> and C<$x> end up being different, as one naively expects, because a new reference is created and C<$x> is assigned to it. However if C<$x> was a huge memory hog (e.g. a 3D volume) creating a copy of it may not be a good thing. One can avoid this memory overhead in the above example by saying: $x++; The operations C<++,+=,--,-=>, etc. all call a special "in-place" version of the arithmetic subroutine. This means no more memory is needed - the downside of this is that if C<$y=$x> then C<$y> is also incremented. To force a copy explicitly: $y = pdl $x; # Real copy or, alternatively, perhaps better style: $y = $x->copy; =item Functions Most functions, e.g. C, return a result which is a transformation of their argument. This makes for good programming practice. However many operations can be done "in-place" and this may be required when large arrays are in use and memory is at a premium. For these circumstances the operator L is provided which prevents the extra copy and allows the argument to be modified. e.g.: $x = log($array); # $array unaffected log( inplace($bigarray) ); # $bigarray changed in situ WARNINGS: =over =item 1 The usual caveats about duplicate references apply. =item 2 Obviously when used with some functions which can not be applied in situ (e.g. C) unexpected effects may occur! We try to indicate C-safe functions in the documentation. =item 3 Type conversions, such asC, may cause hidden copying. =back =back =head2 Ensuring ndarrayness If you have written a simple function and you don't want it to blow up in your face if you pass it a simple number rather than a PDL variable. Simply call the function L first to make it safe. e.g.: sub myfiddle { my $pdl = topdl(shift); $pdl->fiddle_foo(...); ... } C does NOT perform a copy if a pdl variable is passed - it just falls through - which is obviously the desired behaviour. The routine is not of course necessary in normal user defined functions which do not care about internals. =head1 AUTHOR Copyright (C) Karl Glazebrook (kgb@aaoepp.aao.gov.au), Tuomas J. Lukka, (lukka@husc.harvard.edu) and Christian Soeller (c.soeller@auckland.ac.nz) 1997. Commercial reproduction of this documentation in a different format is forbidden. =cut PDL-2.074/Basic/Pod/Modules.pod0000644000175000017500000001460214146003631015753 0ustar osboxesosboxes=head1 NAME PDL::Modules - A guide to PDL's module reference. =head1 DESCRIPTION This page serves as a table of contents for PDL's module documentation. This page does not list every single PDL module. It only shows the ones intended for PDL users, while omitting those which are deemed "for internal use only". If you wish to see a comprehensive list of all documentation, please see the L page. =head1 LOOKING FOR A FUNCTION? If you want to search for a function name, you should use the PDL shell along with the "help" or "apropos" command (to do a fuzzy search). For example: pdl> apropos xval xlinvals X axis values between endpoints (see xvals). xlogvals X axis values logarithmicly spaced... xvals Fills an ndarray with X index values... yvals Fills an ndarray with Y index values. See the CAVEAT for xvals. zvals Fills an ndarray with Z index values. See the CAVEAT for xvals. To learn more about the PDL shell, see L or L. =head1 FOUNDATION =over 5 =item L or L Learn about the PDL shell. =back =head2 Functions =over 5 =item L Core module (e.g. creating ndarrays). =item L Simplified interface to the more general PDL::Primitive. =item L Basic operators (e.g. arithmetic, comparisons, etc.). =item L Functions that accumulate along a dimension (e.g. sum, max). =back =head2 Other Features =over 5 =item L MATLAB-style function autoloader. =item L Indexing and slices. How to access a subset of an ndarray. =item L Nicer syntax for slices. =back =head1 MISCELLANEOUS =over 5 =item L Fundamental operations on ndarrays. =item L Bad value support. =item L A 'reduce' function for PDL. =item L Minimum PDL module OO loader. =item L Minimum PDL module function loader. =item L Extended Mathematical Operators. =item L Interpolation-related functions. =back =head1 GRAPHICS =over 5 =item L PGPLOT library. =item L PLplot library. =back =head2 3D Graphics =over 5 =item L 3D graphics core module. =item L Helper routines for 3D graphics. =item L 3D surface contours. =back =head2 Helper Modules =over 5 =item L Look-up tables. =item L Display images on IIS devices. =item L Derive data limits for display purposes. =back =head1 IMAGE PROCESSING =over 5 =item L Compression utilities. =item L 2-dimmensional image processing. =item L N-dimmensional image processing. =item L RGB image data handling. =back =head1 NUMERICAL METHODS =over 5 =item L Fast Fourier Transform (native implementation). =item L PDL interface to the FFTW library. =item L Linear predictive filtering. =item L Linear filtering. =item L Simplex optimization routines. =item L PDL interface to the Minuit library. =item L PDL interface to the Slatec library. =back =head1 COORDINATE TRANSFORMATIONS =over 5 =item L Coordinate transforms, image warping, and N-D functions. =item L Cartographic projections. =item L PDL interface to the Proj4 projection library. =back =head1 IO FUNCTIONS =over 5 =item L Overview of IO functions. =item L Data dumper. =item L Fast storage format (outdated). =item L Flexible storage format. =item L Misc IO routines. =item L Support for Perl's 'Storable' module. =back =head2 Image Formats =over 5 =item L PDL support for FITS images. =item L PDL support for PNM images. =item L PDL interface to the GD image library. =item L PDL interface to the HDH4 image library. =item L PDL interface to the NetPBM image library. =item L PDL interface to the Starlink image library. Available as a separate CPAN download. =back =head1 2D MATRICES =over 5 =item L Convenience class for 2D matrix work. =item L Additional matrix operators. =back =head1 GNU SCIENTIFIC LIBRARY =over 5 =item L Numerical differentiation. =item L Numerical integration. =item L Interpolation. =item L Multidimensional root-finding. =item L RNG and randist. =back =head2 Special Functions =over 5 =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =item L =back =head1 FITTING FUNCTIONS =over 5 =item L Fit gaussian curves. =item L Fit polynomials. =item L Fit linear combinations of functions. =item L Fit functions using the Levenberg-Marquardt algorithm. =back =head1 ADVANCED =over 5 =item L PDL debugger. =item L Manage many ndarrays through a disk cache. =item L Call external functions. =item L If you want to sub-class from PDL (note: incomplete). =back =head1 COPYRIGHT Copyright 2010 Daniel Carrera (dcarrera@gmail.com). You can distribute and/or modify this document under the same terms as the current Perl license. See: http://dev.perl.org/licenses/ PDL-2.074/Basic/Pod/FAQ.pod0000644000175000017500000015274314160015533014763 0ustar osboxesosboxes =head1 NAME PDL::FAQ - Frequently asked questions about PDL =head1 VERSION Current FAQ version: 1.008 =head1 DESCRIPTION This is version 1.008 of the PDL FAQ, a collection of frequently asked questions about PDL - the Perl Data Language. =head1 ABOUT THIS DOCUMENT =head2 Q: 1.1 Where to find this document You can find the latest version of this document at L . =head2 Q: 1.2 How to contribute to this document This is a considerably reworked version of the PDL FAQ. As such many errors might have crept in and many updates might not have made it in. You are explicitly encouraged to let us know about questions which you think should be answered in this document but currently aren't. Similarly, if you think parts of this document are unclear, please tell the FAQ maintainer about it. Where a specific answer is taken in full from someones posting the authorship should be indicated, let the FAQ maintainer know if it isn't. For more general information explicit acknowledgment is not made in the text, but rather there is an incomplete list of contributors at the end of this document. Please contact the FAQ maintainer if you feel hard done by. Send your comments, additions, suggestions or corrections to the PDL mailing list at pdl-general@lists.sourceforge.net. See Q: 3.2 below for instructions on how to join the mailing lists. =head1 GENERAL QUESTIONS =head2 Q: 2.1 What is PDL ? PDL stands for I . To say it with the words of Karl Glazebrook, initiator of the PDL project: The PDL concept is to give standard perl5 the ability to COMPACTLY store and SPEEDILY manipulate the large N-dimensional data sets which are the bread and butter of scientific computing. e.g. $x=$y+$z can add two 2048x2048 images in only a fraction of a second. It provides tons of useful functionality for scientific and numeric analysis. For readers familiar with other scientific data evaluation packages it may be helpful to add that PDL is in many respects similar to IDL, MATLAB and similar packages. However, it tries to improve on a number of issues which were perceived (by the authors of PDL) as shortcomings of those existing packages. =head2 Q: 2.2 Who supports PDL? Who develops it? PDL is supported by its users. General informal support for PDL is provided through the PDL mailing list (pdl-general@lists.sourceforge.net , see below). As a Perl extension (see Q: 2.5 below) it is devoted to the idea of free and open development put forth by the Perl community. PDL was and is being actively developed by a loosely knit group of people around the world who coordinate their activities through the PDL development mailing list (pdl-devel@lists.sourceforge.net , see Q: 3.2 below). If you would like to join in the ongoing efforts to improve PDL please join this list. =head2 Q: 2.3 Why yet another Data Language ? There are actually several reasons and everyone should decide for himself which are the most important ones: =over 4 =item * PDL is "free software". The authors of PDL think that this concept has several advantages: everyone has access to the sources -> better debugging, easily adaptable to your own needs, extensible for your purposes, etc... In comparison with commercial packages such as MATLAB and IDL this is of considerable importance for workers who want to do some work at home and cannot afford the considerable cost to buy commercial packages for personal use. =item * PDL is based on a powerful and well designed scripting language: Perl. In contrast to other scientific/numeric data analysis languages it has been designed using the features of a proven language instead of having grown into existence from scratch. Defining the control structures while features were added during development leads to languages that often appear clumsy and badly planned for most existing packages with similar scope as PDL. =item * Using Perl as the basis a PDL programmer has all the powerful features of Perl at his hand, right from the start. This includes regular expressions, associative arrays (hashes), well designed interfaces to the operating system, network, etc. Experience has shown that even in mainly numerically oriented programming it is often extremely handy if you have easy access to powerful semi-numerical or completely non-numerical functionality as well. For example, you might want to offer the results of a complicated computation as a server process to other processes on the network, perhaps directly accepting input from other processes on the network. Using Perl and existing Perl extension packages things like this are no problem at all (and it all will fit into your "PDL script"). =item * Extremely easy extensibility and interoperability as PDL is a Perl extension; development support for Perl extensions is an integral part of Perl and there are already numerous extensions to standard Perl freely available on the network. =item * Integral language features of Perl (regular expressions, hashes, object modules) immensely facilitated development and implementation of key concepts of PDL. One of the most striking examples for this point is probably L (see Q: 6.16 below), a code generator/parser/pre-processor that generates PDL functions from concise descriptions. =item * None of the existing data languages follow the Perl language rules, which the authors firmly believe in: =over 4 =item * TIMTOWTDI: There is more than one way to do it. Minimalist languages are interesting for computer scientists, but for users, a little bit of redundancy makes things wildly easier to cope with and allows individual programming styles - just as people speak in different ways. For many people this will undoubtedly be a reason to avoid PDL ;) =item * Simple things are simple, complicated things possible: Things that are often done should be easy to do in the language, whereas seldom done things shouldn't be too cumbersome. =back All existing languages violate at least one of these rules. =item * As a project for the future PDL should be able to use super computer features, e.g. vector capabilities/parallel processing, GPGPU acceleration. This will probably be achieved by having L (see Q: 6.16 below) generate appropriate code on such architectures to exploit these features. =item * [ fill in your personal 111 favourite reasons here...] =back =head2 Q: 2.4 What is PDL good for ? Just in case you do not yet know what the main features of PDL are and what one could do with them, here is a (necessarily selective) list of key features: PDL is well suited for matrix computations, general handling of multidimensional data, image processing, general scientific computation, numerical applications. It supports I/O for many popular image and data formats, 1D (line plots), 2D (images) and 3D (volume visualization, surface plots via OpenGL - for instance implemented using Mesa or video card OpenGL drivers), graphics display capabilities and implements many numerical and semi-numerical algorithms. Through the powerful pre-processor it is also easy to interface Perl to your favorite C routines, more of that further below. =head2 Q: 2.5 What is the connection between PDL and Perl ? PDL is a Perl5 extension package. As such it needs an existing Perl5 installation (see below) to run. Furthermore, much of PDL is written in Perl (+ some core functionality that is written in C). PDL programs are (syntactically) just Perl scripts that happen to use some of the functionality implemented by the package "PDL". =head2 Q: 2.6 What do I need to run PDL on my machine ? Since PDL is just a Perl5 package you need first of all an installation of Perl5 on your machine. As of this writing PDL requires version 5.10.x of perl, or higher. More information on where and how to get a Perl installation can be found at the Perl home page L and at many CPAN sites (if you do not know what I is, check the answer to the next question). To build PDL you also need a working C compiler, support for Xsubs, and the package Extutils::MakeMaker. If you don't have a compiler there might be a binary distribution available, see "Binary distributions" below. If you can (or cannot) get PDL working on a new (previously unsupported) platform we would like to hear about it. Please, report your success/failure to the PDL mailing list at pdl-general@lists.sourceforge.net . We will do our best to assist you in porting PDL to a new system. =head2 Q: 2.7 Where do I get it? PDL is available as source distribution in the I (or CPAN) and from the GitHub project page at L. The CPAN archives contains not only the PDL distribution but also just about everything else that is Perl-related. CPAN is mirrored by dozens of sites all over the world. The main site is L, and local CPAN sites (mirrors) can be found there. PDL's homepage is at L and the latest version can also be downloaded from there. =head2 Q: 2.8 What do I have to pay to get PDL? We are delighted to be able to give you the nicest possible answer on a question like this: PDL is *free software* and all sources are publicly available. But still, there are some copyrights to comply with. So please, try to be as nice as we (the PDL authors) are and try to comply with them. Oh, before you think it is *completely* free: you have to invest some time to pull the distribution from the net, compile and install it and (maybe) read the manuals. =head1 GETTING HELP/MORE INFORMATION =head2 Q: 3.1 Where can I get information on PDL? The complete PDL documentation is available with the PDL distribution. Use the command C to start learning about PDL. The easiest way by far, however, to get familiar with PDL is to use the PDL on-line help facility from within the PDL shell, C Just type C at your system prompt. Once you are inside the C shell type C . Using the C and C commands inside the shell you should be able to find the way round the documentation. Even better, you can immediately try your newly acquired knowledge about PDL by issuing PDL/Perl commands directly at the command line. To illustrate this process, here is the record of a typical C session of a PDL beginner (lengthy output is only symbolically reproduced in braces ( <... ...> ) ): unix> pdl2 pdl> help < ... help output ... > pdl> help PDL::QuickStart < ... perldoc page ... > pdl> $x = pdl (1,5,7.3,1.0) pdl> $y = sequence float, 4, 4 pdl> help inner < ... help on the 'inner' function ... > pdl> $c = inner $x, $y pdl> p $c [22.6 79.8 137 194.2] For further sources of information that are accessible through the Internet see next question. =head2 Q: 3.2 Are there other PDL information sources on the Internet? First of all, for all purely Perl-related questions there are tons of sources on the net. Good points to start are L and L . The PDL home site can be accessed by pointing your web browser to L . It has tons of goodies for anyone interested in PDL: =over 4 =item * PDL distributions =item * On-line documentation =item * Pointers to an HTML archive of the PDL mailing lists =item * A list of platforms on which PDL has been successfully tested. =item * News about recently added features, ported libraries, etc. =item * Name of the current pumpkin holders for the different PDL modules (if you want to know what that means you better had a look at the web pages). =back If you are interested in PDL in general you can join the pdl-general mailing list. This is a forum to discuss programming issues in PDL, report bugs, seek assistance with PDL related problems, etc. If you are interested in all the technical details of the ongoing PDL development you can join the pdl-devel mailing list. Subscription and current archive links to both mailing lists can be found at L. Cross-posting between these lists should be avoided unless there is a I good reason for doing that. The PDL project, begun in the late 1990s, has undergone considerable evolution since that time, and the support for it has as well. Thus mailing-list archives are in several places. Originally pdl-general was called 'perldl', and pdl-devel was called 'pdl-porters'. |Time Period | URL | |------------|-------------------------------------------------------| |1996 - 2004 | http://www.xray.mpe.mpg.de/mailing-lists/perldl/ | |1997 - 2004 | http://www.xray.mpe.mpg.de/mailing-lists/pdl-porters/ | |2005 - 2015 | http://perldl.jach.hawaii.narkive.com/ | |2005 - 2015 | http://pdl-porters.jach.hawaii.narkive.com/ | |2015 - | https://sourceforge.net/p/pdl/mailman/pdl-general/ | |2015 - | https://sourceforge.net/p/pdl/mailman/pdl-devel/ | |--------------------------------------------------------------------| =head2 Q: 3.3 What is the current version of PDL ? As of this writing (FAQ version 1.008 of 21 May 2017) the latest stable version is 2.018. The latest stable version should always be available from a CPAN mirror site near you (see L for info on where to get PDL). The most current (possibly unstable) version of PDL can be obtained from the Git repository, see L and periodic CPAN developers releases of the Git code will be made for testing purposes and more general availability. =head2 Q: 3.4 How can PDL-2.2 be older than PDL-2.007? Over its development, PDL has used both a single floating point version number (from the versions 1.x through 2.005) at which point it switched to a dotted triple version for 2.1.1 onward---EXCEPT for version 2.2 which came out which should have been 2.2.0. To simplify and unify things, PDL has reverted to a single float version representation with PDL-2.006. This can cause dependency problems for modules that set a minimum PDL version of 2.2. The work around it, note that all extant PDL releases have version numbers greater than 2.2.1 so that using 0 as the minimum version will work. =head2 Q: 3.5 I want to contribute to the further development of PDL. How can I help? Two ways that you could help almost immediately are (1) participate in CPAN Testers for PDL and related modules, and (2) proofreading and clarifying the PDL documentation so that it is most useable for PDL users, especially new users. To participate in CPAN Testers and contribute test reports, the page L has instructions for starting for either C or C users. If you have a certain project in mind you should check if somebody else is already working on it or if you could benefit from existing modules. Do so by posting your planned project to the PDL developers mailing list at pdl-devel@lists.sourceforge.net . See the subscription instructions in L. We are always looking for people to write code and/or documentation ;). =head2 Q: 3.6 I think I have found a bug in the current version of PDL. What shall I do? First, make sure that the bug/problem you came across has not already been dealt with somewhere else in this FAQ. Secondly, you can check the searchable archive of the PDL mailing lists to find whether this bug has already been discussed. If you still haven't found any explanations you can post a bug report to pdl-general@lists.sourceforge.net , or through the Bugs link on L . See the F file in the PDL distribution for what information to include. If you are unsure, discussions via the perldl mailing list can be most helpful. =head1 INSTALLATION =head2 Q: 4.1 I have problems installing PDL. What shall I do? First make sure you have read the file F in the distribution. This contains a list of common problems which are unnecessary to repeat here. Next, check the file F to see if by editing the configuration options in that file you will be able to successfully build PDL. Some of the modules need additional software installed, please refer to the file F for further details. Make sure to edit the location of these packages in perldl.conf if you have them in non-standard locations. N.B. Unix shell specific: If you would like to save an edited perldl.conf for future builds just copy it as F<~/.perldl.conf> into your home directory where it will be picked up automatically during the PDL build process. Also, check for another, pre-existing version of PDL on the build system. Multiple PDL installs in the same PATH or @INC can cause puzzling test or build failures. If you still can't make it work properly please submit a bug report including detailed information on the problems you encountered to the perldl mailing list ( pdl-general@lists.sourceforge.net , see also above). Response is often rapid. =head2 Q: 4.2 Are there configuration files for PDL I have to edit? Most users should not have to edit any configuration files manually. However, in some cases you might have to supply some information about awkwardly placed include files/libraries or you might want to explicitly disable building some of the optional PDL modules. Check the files F and F for details. If you had to manually edit F and are happy with the results you can keep the file handy for future reference. Place it in F<~/.perldl.conf> where it will be picked up automatically or use C next time you build PDL. =head2 Q: 4.3 Do I need other software for successful operation? For the basic PDL functionality you don't need any additional software. However, some of the optional PDL modules included in the distribution (notably most graphics and some I/O modules) require certain other libraries/programs to be installed. Check the file F in the distribution for details and directions on how to get these. =head2 Q: 4.4 How can I install PDL in a non-standard location? To install PDL in a non-standard location, use the INSTALL_BASE option in the C configure step. For example, C will configure PDL to install into the tree rooted at C. For more details see L and subsequent sections. Another alternative is to use L to do the heavy lifting for the needed configuration. =head2 Q: 4.5 How can I force a completely clean installation? To guarantee a completely clean installation of PDL, you will need to first delete the current installation files and folders. These will be all directories named C in the Perl C<@INC> path, files named C<*Pdlpp*> in any C directories, and the programs C. Then just build and install as usual. This is much easier to keep track of if you always install C into a non-standard location. See Q: 4.4 above. =head1 BINARY DISTRIBUTIONS =head2 Q: 4.5 What binary distributions are available? Information about binary distributions of PDL can be found on L . At present there are binary distributions of PDL for Linux (RedHat and Debian), FreeBSD, Mac OS X and Windows, though they might not be the most recent version. If someone is interested in providing binary distributions for other architectures, that would be very welcome. Let us know on the pdl-devel@lists.sourceforge.net mailing list. Also check your Linux distribution's package manager as many now include PDL. PPMs for win32 versions (both 32bit and 64bit) are also available. =head2 Q: 4.6 Does PDL run on Linux? (And what about packages?) Yes, PDL does run on Linux and indeed much of the development has been done under Linux. On L you can find links to packages for some of the major distributions. Also check your distribution's package manager (yum, apt, urpmi, ...) as PDL is now found by many of these. =head2 Q: 4.7 Does PDL run under Windows? PDL builds fine on Win32 using MinGW or Microsoft compilers. See the F file in the PDL source distribution for details. Other compilers have not been tested--input is welcome. There is also a distribution of PDL through ActiveState's ppm, though it might not always be the latest version. PDL-2.018 builds out of the box on Strawberry Perl and ActiveState Perl and there are distributions of Strawberry Perl with bundled PDL (see L). =head1 CVS, GIT, AND ON-GOING DEVELOPMENT =head2 Q: 4.8 Can I get PDL via CVS? No. PDL development was conducted with a CVS repository from December 1999 to April 2009. In April 2009 the project switched to the Git version control system (see L). =head2 Q: 4.9 How do I get PDL via Git? Assume you have Git installed on your system and want to download the project source code into the directory C. To get read-only access to the repository, you type at the command line git clone git://github.com/PDLPorters/pdl If you wish to submit changes to PDL, you should "fork" the repository from L, then clone your fork in the normal fashion. To become an official PDL developer, you will need to be added to the GitHub "PDLPorters" organisation. For official PDL developers, to get read/write access to the repository type at the command line git clone git://github.com/PDLPorters/pdl They can still use their own fork; at least one active developer uses that model rather than branches on the main repository. =head2 Q: 4.10 I had a problem with the Git version, how do I check if someone has submitted a patch? The best way is to check L to see if somebody has submitted a pull request related to your problem. In addition, if you are not subscribing to the mailing list, check the archive of the C and C mailing lists. See L for details. =head2 Q: 4.11 I have gotten developer access to Git, how do I upload my changes? The first thing you should do is to read the Git documentation and learn the basics about Git. There are many sources available online. It is very important that you use Git "best practice", with branches, but fortunately this is very easy! Here are the basics. Make sure your copy is up to date with the main repo: git checkout master git pull --rebase # rebase in case you wrongly changed your own master Make a branch: git checkout -b mybranch-name Commit your changes locally: git add ... git commit or combine these two with: git commit -a Test the PDL before you push it to the main repository. If the code is broken for you, then it is most likely broken for others. Luckily, the rest of this process will test that automatically to help you catch such errors. Then update the shared repository with your changes: git push -u origin mybranch-name This will still leave your changes on a branch, but this is good. Now go to the GitHub page, L. It will ask you whether you want to make a "pull request" - you do. Follow the prompts. This will then initiate the automated "continuous integration" tests, on Linux and Windows, with various versions of Perl, with various compilers. You will also want to get at least one other developer to review your changes. Once this review process is successfully completed, you can merge your changes to the master branch! =head1 PDL JARGON =head2 Q: 5.1 What is threading (is PDL a newsreader) ? Unfortunately, in the context of PDL the term threading can have two different (but related) meanings: =over 4 =item * When mentioned in the F directions and possibly during the build process we have the usual computer science meaning of multi-threading in mind (useful mainly on multiprocessor machines or clusters) =item * PDL threading of operations on ndarrays (as mentioned in the indexing docs) is the iteration of a basic operation over appropriate sub-slices of ndarrays, e.g. the inner product C of a (3) pdl C<$x> and a (3,5,4) pdl C<$y> results in a (5,4) ndarray where each value is the result of an inner product of the (3) pdl with a (3) sub-slice of the (3,5,4) ndarray. For details check L =back PDL threading leads naturally to potentially parallel code which can make use of multi threading on multiprocessor machines/networks; there you have the connection between the two types of use of the term. =head2 Q: 5.2 What is an ndarray? Well, PDL scalar variables (which are instances of a particular class of Perl objects, i.e. blessed thingies (see C )) are in common PDL parlance often called I (for example, check the mailing list archives). Err, clear? If not, simply use the term I when you refer to a PDL variable (an instance of a PDL object as you might remember) regardless of what actual data the PDL variable contains. =head1 TECHNICAL QUESTIONS =head2 Q: 6.1 What is perldl? What is pdl2? Sometimes C (C) is used as a synonym for PDL. Strictly speaking, however, the name C (C) is reserved for the little shell that comes with the PDL distribution and is supposed to be used for the interactive prototyping of PDL scripts. For details check L or L. =head2 Q: 6.2 How do I get on-line help for PDL? Just type C (shortcut = "?") at the C shell prompt and proceed from there. Another useful command is the C (shortcut = "??") command. Also try the C command in the C or C shell if you are new to PDL. =head1 MANIPULATION OF NDARRAYS =head2 Q: 6.3 I want to access the third element of a pdl but $x[2] doesn't work ?! See answer to the next question why the normal Perl array syntax doesn't work for ndarrays. =head2 Q: 6.4 The docs say ndarrays are some kind of array. But why doesn't the Perl array syntax work with ndarrays then ? OK, you are right in a way. The docs say that ndarrays can be thought of arrays. More specifically, it says ( L ): I find when using the Perl Data Language it is most useful to think of standard Perl @x variables as "lists" of generic "things" and PDL variables like $x as "arrays" which can be contained in lists or hashes. So, while ndarrays can be thought of as some kind of multi-dimensional array they are B< not> arrays in the Perl sense. Rather, from the point of view of Perl they are some special class (which is currently implemented as an opaque pointer to some stuff in memory) and therefore need special functions (or 'methods' if you are using the OO version) to access individual elements or a range of elements. The functions/methods to check are C / C (see L ) or the powerful C function and friends (see L and L and especially L ). Finally, to confuse you completely, you can have Perl arrays of ndarrays, e.g. C<$spec[3]> can refer to a pdl representing ,e.g, a spectrum, where C<$spec[3]> is the fourth element of the Perl list (or array ;) C<@spec> . This may be confusing but is very useful ! =head2 Q: 6.5 How do I concatenate ndarrays? Most people will try to form new ndarrays from old ndarrays using some variation over the theme: C<$x = pdl([$y, 0, 2])>. This does work, but may not work in the way that a novice user would expect. (If C<$y> has N dimensions then C<$x> will have N+1 dimensions.) Other ways to concatenate ndarrays are to use the functions C, C, and C. Similarly you can split ndarrays using the command C. =head2 Q: 6.6 Sometimes I am getting these strange results when using inplace operations? This question is related to the C function. From the documentation (see L): Most functions, e.g. log(), return a result which is a transformation of their argument. This makes for good programming practice. However many operations can be done "in-place" and this may be required when large arrays are in use and memory is at a premium. For these circumstances the operator inplace() is provided which prevents the extra copy and allows the argument to be modified. e.g.: $x = log($array); # $array unaffected log( inplace($bigarray) ); # $bigarray changed in situ And also from the doc !!: Obviously when used with some functions which can not be applied in situ (e.g. convolve()) unexpected effects may occur! =for comment Check the list of PDL functions at the end of PDL.pod which points out C-safe functions. No longer in PDL.pod, need to fix!! =head2 Q: 6.7 What is this strange usage of the string concatenation operator C<.=> in PDL scripts? See next question on assignment in PDL. =head2 Q: 6.8 Why are there two different kinds of assignment in PDL ? This is caused by the fact that currently the assignment operator C<=> allows only restricted overloading. For some purposes of PDL it turned out to be necessary to have more control over the overloading of an assignment operator. Therefore, PDL peruses the operator C<.=> for certain types of assignments. =head2 Q: 6.9 How do I set a set of values in an ndarray? In Perl 5.6.7 and higher this assignment can be made using lvalue subroutines: pdl> $x = sequence(5); p $x [0 1 2 3 4] pdl> $x->slice('1:2') .= pdl([5,6]) pdl> p $x [0 5 6 3 4] see L for more info. PDL also supports a more matrix-like slice syntax via the L module: pdl> $x(1:2) .= pdl([5,6]) pdl> p $x [0 5 6 3 4] With versions of Perl prior to 5.6.7 B this has to be done using a temporary variable: pdl> $x = sequence(5); p $x [0 1 2 3 4] pdl> $tmp = $x->slice('1:2'); p $tmp; [1 2] pdl> $tmp .= pdl([5, 6]); # Note .= !! pdl> p $x [0 5 6 3 4] This can also be made into one expression, which is often seen in PDL code: pdl> ($tmp = $x->slice('1:2')) .= pdl([5,6]) pdl> p $x [0 5 6 3 4] =head2 Q: 6.10 Can I use an ndarray in a conditional expression? Yes you can, but not in the way you probably tried first. It is not possible to use an ndarray directly in a conditional expression since this is usually poorly defined. Instead PDL has two very useful functions: C and C . Use these to test if any or all elements in an ndarray fulfills some criterion: pdl> $x=pdl ( 1, -2, 3); pdl> print '$x has at least one element < 0' if (any $x < 0); $x has at least one element < 0 pdl> print '$x is not positive definite' unless (all $x > 0); $x is not positive definite =head2 Q: 6.11 Logical operators and ndarrays - '||' and '&&' don't work! It is a common problem that you try to make a mask array or something similar using a construct such as $mask = which($ndarray > 1 && $ndarray < 2); # incorrect This B< does not> work! What you are looking for is the B< bitwise> logical operators '|' and '&' which work on an element-by-element basis. So it is really very simple: Do not use logical operators on multi-element ndarrays since that really doesn't make sense, instead write the example as: $mask = which($ndarray > 1 & $ndarray < 2); which works correctly. =head1 ADVANCED TOPICS =head2 Q: 6.12 What is a null pdl ? =for comment Is Q: 6.12 up-to-date with null and empty pdls? C is a special token for 'empty ndarray'. A null pdl can be used to flag to a PDL function that it should create an appropriately sized and typed ndarray. I ndarrays can be used in places where a PDL function expects an I or I argument. I and I arguments are flagged in the I of a PDL function with the C<[o]> and C<[t]> qualifiers (see next question if you don't know what the I of a PDL function is). For example, you can invoke the C function as follows: sumover $x, $y=null; which is equivalent to $y = sumover $x; If this seems still a bit murky check L and L for details about calling conventions, the I and I (see also below). =head2 Q: 6.13 What is the signature of a PDL function ? The I of a function is an important concept in PDL. Many (but not all) PDL function have a I which specifies the arguments and their (minimal) dimensionality. As an example, look at the signature of the C function: 'a(n); [o] b;' this says that C takes two arguments, the first of which is (at least) one-dimensional while the second one is zero-dimensional and an I argument (flagged by the C<[o]> qualifier). If the function is called with ndarrays of higher dimension the function will be repeatedly called with slices of these ndarrays of appropriate dimension(this is called I in PDL). For details and further explanations consult L and L . =head2 Q: 6.14 How can I subclass (inherit from) ndarrays? The short answer is: read L (e.g. type C in the I or I shell). The longer answer (extracted from L ): Since a PDL object is an opaque reference to a C struct, it is not possible to extend the PDL class by e.g. extra data via sub-classing (as you could do with a hash based Perl object). To circumvent this problem PDL has built-in support to extend the PDL class via the I relation for blessed hashes. You can get the I to behave like I simply in that you assign the PDL object to the attribute named C and redefine the method initialize(). For example: package FOO; @FOO::ISA = qw(PDL); sub initialize { my $class = shift; my $self = { creation_time => time(), # necessary extension :-) PDL => PDL->null, # used to store PDL object }; bless $self, $class; } For another example check the script F in the PDL distribution. =head2 Q: 6.15 What on earth is this dataflow stuff ? Dataflow is an experimental project that you don't need to concern yourself with (it should not interfere with your usual programming). However, if you want to know, have a look at L . There are applications which will benefit from this feature (and it is already at work behind the scenes). =head2 Q: 6.16 What is PDL::PP? Simple answer: PDL::PP is both a glue between external libraries and PDL and a concise language for writing PDL functions. Slightly longer answer: PDL::PP is used to compile very concise definitions into XSUB routines implemented in C that can easily be called from PDL and which automatically support threading, dataflow and other things without you having to worry about it. For further details check L and the section below on L. =head2 Q: 6.17 What happens when I have several references to the same PDL object in different variables (cloning, etc?) ? ndarrays behave like Perl references in many respects. So when you say $x = pdl [0,1,2,3]; $y = $x; then both $y and $x point to the same object, e.g. then saying $y++; will *not* create a copy of the original ndarray but just increment in place, of which you can convince yourself by saying print $x; [1 2 3 4] This should not be mistaken for dataflow which connects several *different* objects so that data changes are propagated between the so linked ndarrays (though, under certain circumstances, dataflowed ndarrays can share physically the same data). It is important to keep the "reference nature" of ndarrays in mind when passing ndarrays into subroutines. If you modify the input ndarrays you modify the original argument, I a copy of it. This is different from some other array processing languages but makes for very efficient passing of ndarrays between subroutines. If you do not want to modify the original argument but rather a copy of it just create a copy explicitly (this example also demonstrates how to properly check for an I request to process inplace, assuming your routine can work inplace): sub myfunc { my $pdl = shift; if ($pdl->is_inplace) { $pdl->set_inplace(0) } else { # modify a copy by default $pdl = $pdl->copy } $pdl->set(0,0); return $pdl; } =head1 MISCELLANEOUS =head2 Q: 6.18 What I/O formats are supported by PDL ? The current versions of PDL already support quite a number of different I/O formats. However, it is not always obvious which module implements which formats. To help you find the right module for the format you require, here is a short list of the current list of I/O formats and a hint in which module to find the implementation: =over 4 =item * A home brew fast raw (binary) I/O format for PDL is implemented by the L module =item * The L module implements generic methods for the input and output of `raw' data arrays. In particular, it is designed to read output from FORTRAN 77 UNFORMATTED files and the low-level C C function, even if the files are compressed or gzipped. It is possible that the FastRaw functionality will be included in the FlexRaw module at some time in the future. =item * FITS I/O is implemented by the C/C functions in L . =item * ASCII file I/O in various formats can be achieved by using the C and C functions, also in L . =item * L implements an interface to the NetPBM/PBM+ filters to read/write several popular image formats; also supported is output of image sequences as MPEG movies, animated GIFs and a wide variety of other video formats. =item * On CPAN you can find the L module that works with PDL 2.007. =back For further details consult the more detailed list in the L documentation or the documentation for the individual modules. =head2 Q: 6.19 How can I stack a set of 2D arrays (images) into a 3D ndarray? Assuming all arrays are of the same size and in some format recognized by C (see L ) you could say: use PDL::IO::Pic; @names = qw/name1.tif .... nameN.tif/; # some file names $dummy = PDL->rpic($names[0]); $cube = PDL->zeroes($dummy->type,$dummy->dims,$#names+1); # make 3D ndarray for (0..$#names) { # this is the slice assignment ($tmp = $cube->slice(":,:,($_)")) .= PDL->rpic($names[$_]); } or $cube(:,:,($_)) .= PDL->rpic($names[$_]); for the slice assignment using the new L syntax and Lvalue assignments. The for loop reads the actual images into a temporary 2D ndarray whose values are then assigned (using the overloaded C<.=> operator) to the appropriate slices of the 3D ndarray C<$cube> . =head2 Q: 6.20 Where are test files for the graphics modules? This answer applies mainly to PDL::Graphics::TriD (PDL's device independent 3D graphics model) which is the trickiest one in this respect. You find some test scripts in Demos/TriD in the distribution. There are also F<3dtest.pl> and F in the PDL/Example/TriD directory. After you have built PDL you can do: perl -Mblib Example/TriD/3dtest.pl perl -Mblib Example/TriD/line3d.pl to try the two TriD test programs. They only exercise one TriD function each but their simplicity makes it easy to debug if needed with the Perl debugger, see L. The programs in the Demo directory can be run most easily from the C or C interactive shell: perl -Mblib perldl or perl -Mblib Perldl2/pdl2 followed by C or C at the prompt. C by itself will give you a list of the available PDL demos. You can run the test scripts in the Demos/TriD directory manually by changing to that directory and running perl -Mblib where C<< testfile >> ; should match the pattern C and watch the results. Some of the tests should bring up a window where you can control (twiddle) the 3D objects with the mouse. Try using mouse button 1 for turning the objects in 3D space, mouse button 3 to zoom in and out, and 'q' to advance to the next stage of the test. =head2 Q: 6.21 What is TriD or PDL::TriD or PDL::Graphics::TriD? Questions like this should be a thing of the past with the PDL on-line help system in place. Just try (after installation): un*x> pdl2 pdl> apropos trid Check the output for promising hits and then try to look up some of them, e.g. pdl> help PDL::Graphics::TriD Note that case matters with C but not with C . =head2 Q: 6.22 PGPLOT does not write out PNG files. There are a few sources of trouble with PGPLOT and PNG files. First, when compiling the pgplot libraries, make sure you uncomment the PNG entries in the F file. Then when running 'make' you probably got an error like C To fix this, find the line in the 'makefile' that starts with 'pndriv.o:' (it's near the bottom). Change, for example, ./png.h to /usr/include/png.h, if that is where your header files are (you do have the libpng and libz devel packages, don't you?). Do this for all four entries on that line, then go back and run C. Second, if you already have the PGPLOT Perl module and PDL installed, you probably tried to write out a PNG file and got fatal error message like: C This is because the PGPLOT Perl module does not automatically link against the png and z libraries. So when you are installing the PGPLOT Perl module (version 2.19) from CPAN, don't do C, but just do C. Then exit from CPAN and manually install PGPLOT, calling the makefile thusly: C assuming that there exist files such as /usr/lib/libpng.so.*, /usr/lib/libz.so.*. Then do the standard C sequence. Now you can write png files from PDL! =head1 EXTENSIONS OF PDL =head2 Q: 7.1 I am looking for a package to do XXX in PDL. Where shall I look for it? The first stop is again C or C and the on-line help or the PDL documentation. There is already a lot of functionality in PDL which you might not be aware of. The easiest way to look for functionality is to use the C command: pdl> apropos 'integral' ceil Round to integral values in floating-point format floor Round to integral values in floating-point format intover Project via integral to N-1 dimensions rint Round to integral values in floating-point format Since the apropos command is no sophisticated search engine make sure that you search on a couple of related topics and use short phrases. However there is a good chance that what you need is not part of the PDL distribution. You are then well advised to check out L where there is a list of packages using PDL. If that does not solve your problem, ask on the mailing-list, if nothing else you might get assistance which will let you interface your package with PDL yourself, see also the next question. =head2 Q: 7.2 Can I access my C/FORTRAN library routines in PDL? Yes, you can, in fact it is very simple for many simple applications. What you want is the PDL pre-processor PP (L ). This will allow you to make a simple interface to your C routine. The two functions you need to learn (at least first) are C which defines the calling interface to the function, specifying input and output parameters, and contains the code that links to the external library. The other command is C which finishes the PP definitions. For details see the L man-page, but we also have a worked example here. double eight_sum(int n) { int i; double sum, x; sum = 0.0; x=0.0; for (i=1; i<=n; i++) { x++; sum += x/((4.0*x*x-1.0)*(4.0*x*x-1.0)); } return 1.0/sum; } We will here show you an example of how you interface C code with PDL. This is the first example and will show you how to approximate the number 8... The C code is shown above and is a simple function returning a double, and expecting an integer - the number of terms in the sum - as input. This function could be defined in a library or, as we do here, as an inline function. We will postpone the writing of the Makefile till later. First we will construct the C<.pd> file. This is the file containing PDL::PP code. We call this C . # # pp_def defines a PDL function. # pp_addhdr ( ' double eight_sum(int n) { int i; double sum, x; sum = 0.0; x=0.0; for (i=1; i<=n; i++) { x++; sum += x/((4.0*x*x-1.0)*(4.0*x*x-1.0)); } return 1.0/sum; } '); pp_def ( 'eight', Pars => 'int a(); double [o]b();', Code => '$b()=eight_sum($a());' ); # Always make sure that you finish your PP declarations with # pp_done pp_done(); A peculiarity with our example is that we have included the entire code with C instead of linking it in. This is only for the purposes of example, in a typical application you will use C to include header files. Note that the argument to C is enclosed in quotes. What is most important in this example is however the C command. The first argument to this is the name of the new function I , then comes a hash which the real meat: =over 4 =item * This gives the input parameters (here C) and the output parameters (here C). The latter are indicated by the C<[o]> specifier. Both arguments can have a type specification as shown here. Many variations and further flexibility in the interface can be specified. See C for details. =item * This switch contains the code that should be executed. As you can see this is a rather peculiar mix of C and Perl, but essentially it is just as you would write it in C, but the variables that are passed from PDL are treated differently and have to be referred to with a preceding '$'. There are also simple macros to pass pointers to data and to obtain the values of other Perl quantities, see the manual page for further details. =back Finally note the call to C at the end of the file. This is necessary in all PP files. OK. So now we have a file with code that we dearly would like to use in Perl via PDL. To do this we need to compile the function, and to do that we need a Makefile. use PDL::Core::Dev; use ExtUtils::MakeMaker; PDL::Core::Dev->import(); $package = ["eight.pd",Eight,PDL::Eight,'',1]; %hash = pdlpp_stdargs($package); WriteMakefile( %hash ); sub MY::postamble {pdlpp_postamble($package)}; The code above should go in a file called Makefile.PL, which should subsequently be called in the standard Perl way: C . This should give you a Makefile and running C should compile the module for you and C will install it for you. The fifth element in the C<$package> array-ref is true. This tells PDL to generate one C file per PP function, which with the right C options can be compiled in parallel, for a useful speedup of development / installation. =head2 Q: 7.3 How can I interface package XXX in PDL? This question is closely related to the previous one, and as we said there, the L pre-processor is the standard way of interfacing external packages with PDL. The most usual way to use PDL::PP is to write a short interface routine, see the L perldoc page and the answer to the previous question for examples. However it is also possible to interface a package to PDL by re-writing your function in PDL::PP directly. This can be convenient in certain situations, in particular if you have a routine that expects a function as input and you would like to pass the function a Perl function for convenience. The L perldoc page is the main source of information for writing PDL::PP extensions, but it is very useful to look for files in the distribution of PDL as many of the core functions are written in PDL::PP. Look for files that end in C<.pd> which is the generally accepted suffix for PDL::PP files. But we also have a simple example here. The following example will show you how to write a simple function that automatically allows threading. To make this concise the example is of an almost trivial function, but the intention is to show the basics of writing a PDL::PP interface. We will write a simple function that calculates the minimum, maximum and average of an ndarray. On my machine the resulting function is 8 times faster than the built-in function C (of course the latter also calculates the median). Let's jump straight in. Here is the code (from a file called C ) # pp_def('quickstats', Pars => 'a(n); [o]avg(); [o]max(); [o]min()', Code => '$GENERIC(a) curmax, curmin; $GENERIC(a) tmp=0; loop(n) %{ tmp += $a(); if (!n || $a() > curmax) { curmax = $a();} if (!n || $a() < curmin) { curmin = $a();} %} $avg() = tmp/$SIZE(n); $max() = curmax; $min() = curmin; ' ); pp_done(); The above might look like a confusing mixture of C and Perl, but behind the peculiar syntax lies a very powerful language. Let us take it line by line. The first line declares that we are starting the definition of a PDL:PP function called C . The second line is very important as it specifies the input and output parameters of the function. C tells us that there is one input parameter that we will refer to as C which is expected to be a vector of length n (likewise matrices, both square and rectangular would be written as C and C respectively). To indicate that something is an output parameter we put C<[o]> in front of their names, so referring back to the code we see that avg, max and min are three output parameters, all of which are scalar (since they have no dimensional size indicated. The third line starts the code definition which is essentially pure C but with a couple of convenient functions. C<$GENERIC> is a function that returns the C type of its argument - here the input parameter a. Thus the first two lines of the code section are variable declarations. The C construct is a convenience function that loops over the dimension called n in the parameter section. Inside this loop we calculate the cumulative sum of the input vector and keep track of the maximum and minimum values. Finally we assign the resulting values to the output parameters. Finally we finish our function declaration with C . To compile our new function we need to create a Makefile, which we will just list since its creation is discussed in an earlier question. use PDL::Core::Dev; use ExtUtils::MakeMaker; PDL::Core::Dev->import(); $package = ["quickstats.pd",Quickstats,PDL::Quickstats,'',1]; %hash = pdlpp_stdargs($package); WriteMakefile( %hash ); sub MY::postamble {pdlpp_postamble($package)}; An example Makefile.PL Our new statistic function should now compile using the tried and tested Perl way: C . You should experiment with this function, changing the calculations and input and output parameters. In conjunction with the L perldoc page this should allow you to quickly write more advanced routines directly in PDL::PP. =head1 BUGS If you find any inaccuracies in this document (or dis-functional URLs) please report to the perldl mailing list pdl-general@lists.sourceforge.net. =head1 ACKNOWLEDGMENTS Achim Bohnet (ach@mpe.mpg.de ) for suggesting CoolHTML as a prettypodder (although we have switched to XML now) and various other improvements. Suggestions for some questions were taken from Perl FAQ and adapted for PDL. =head1 CONTRIBUTORS Many people have contributed or given feedback on the current version of the FAQ, here is an incomplete list of individuals whose contributions or posts to the mailing-list have improved this FAQ at some point in time alphabetically listed by first name: Christian Soeller, Chris Marshall, Doug Burke, Doug Hunt, Frank Schmauder, Jarle Brinchmann, John Cerney, Karl Glazebrook, Kurt Starsinic, Thomas Yengst, Tuomas J. Lukka. =head1 AUTHOR AND COPYRIGHT This document emerged from a joint effort of several PDL developers (Karl Glazebrook, Tuomas J. Lukka, Christian Soeller) to compile a list of the most frequently asked questions about PDL with answers. Permission is granted for verbatim copying (and formatting) of this material as part of PDL. Permission is explicitly not granted for distribution in book or any corresponding form. Ask on the PDL mailing list pdl-general@lists.sourceforge.net if some of the issues covered in here are unclear. PDL-2.074/Basic/Pod/Threading.pod0000644000175000017500000006223314160015533016253 0ustar osboxesosboxes=head1 NAME PDL::Threading - Tutorial for PDL's Threading feature =head1 INTRODUCTION One of the most powerful features of PDL is B, which can produce very compact and very fast PDL code by avoiding multiple nested for loops that C and BASIC users may be familiar with. The trouble is that it can take some getting used to, and new users may not appreciate the benefits of threading. Other vector based languages, such as MATLAB, use a subset of threading techniques, but PDL shines by completely generalizing them for all sorts of vector-based applications. =head1 TERMINOLOGY: NDARRAY MATLAB typically refers to vectors, matrices, and arrays. Perl already has arrays, and the terms "vector" and "matrix" typically refer to one- and two-dimensional collections of data. Having no good term to describe their object, PDL developers coined the term "I" to give a name to their data type. An I consists of a series of numbers organized as an N-dimensional data set. ndarrays provide efficient storage and fast computation of large N-dimensional matrices. They are highly optimized for numerical work. =head1 THINKING IN TERMS OF THREADING If you have used PDL for a little while already, you may have been using threading without realising it. Start the PDL shell (type C or C on a terminal). Most examples in this tutorial use the PDL shell. Make sure that L and L are enabled. For example: % pdl2 perlDL shell v1.352 ... ReadLines, NiceSlice, MultiLines enabled ... Note: AutoLoader not enabled ('use PDL::AutoLoader' recommended) pdl> In this example, NiceSlice was automatically enabled, but AutoLoader was not. To enable it, type C. Let's start with a two-dimensional I: pdl> $x = sequence(11,9) pdl> p $x [ [ 0 1 2 3 4 5 6 7 8 9 10] [11 12 13 14 15 16 17 18 19 20 21] [22 23 24 25 26 27 28 29 30 31 32] [33 34 35 36 37 38 39 40 41 42 43] [44 45 46 47 48 49 50 51 52 53 54] [55 56 57 58 59 60 61 62 63 64 65] [66 67 68 69 70 71 72 73 74 75 76] [77 78 79 80 81 82 83 84 85 86 87] [88 89 90 91 92 93 94 95 96 97 98] ] The C method gives you basic information about an I: pdl> p $x->info PDL: Double D [11,9] This tells us that C<$x> is an 11 x 9 I composed of double precision numbers. If we wanted to add 3 to all elements in an C ndarray, a traditional language would use two nested for-loops: # Pseudo-code. Traditional way to add 3 to an array. for (i=0; i < n; i++) { for (j=0; j < m; j++) { a(i,j) = a(i,j) + 3 } } B: Notice that indices start at 0, as in Perl, C and Java (and unlike MATLAB and IDL). But with PDL, we can just write: pdl> $y = $x + 3 pdl> p $y [ [ 3 4 5 6 7 8 9 10 11 12 13] [ 14 15 16 17 18 19 20 21 22 23 24] [ 25 26 27 28 29 30 31 32 33 34 35] [ 36 37 38 39 40 41 42 43 44 45 46] [ 47 48 49 50 51 52 53 54 55 56 57] [ 58 59 60 61 62 63 64 65 66 67 68] [ 69 70 71 72 73 74 75 76 77 78 79] [ 80 81 82 83 84 85 86 87 88 89 90] [ 91 92 93 94 95 96 97 98 99 100 101] ] This is the simplest example of threading, and it is something that all numerical software tools do. The C<+ 3> operation was automatically applied along two dimensions. Now suppose you want to to subtract a line from every row in C<$x>: pdl> $line = sequence(11) pdl> p $line [0 1 2 3 4 5 6 7 8 9 10] pdl> $c = $x - $line pdl> p $c [ [ 0 0 0 0 0 0 0 0 0 0 0] [11 11 11 11 11 11 11 11 11 11 11] [22 22 22 22 22 22 22 22 22 22 22] [33 33 33 33 33 33 33 33 33 33 33] [44 44 44 44 44 44 44 44 44 44 44] [55 55 55 55 55 55 55 55 55 55 55] [66 66 66 66 66 66 66 66 66 66 66] [77 77 77 77 77 77 77 77 77 77 77] [88 88 88 88 88 88 88 88 88 88 88] ] Two things to note here: First, the value of C<$x> is still the same. Try C

to check. Second, PDL automatically subtracted C<$line> from each row in C<$x>. Why did it do that? Let's look at the dimensions of C<$x>, C<$line> and C<$c>: pdl> p $line->info => PDL: Double D [11] pdl> p $x->info => PDL: Double D [11,9] pdl> p $c->info => PDL: Double D [11,9] So, both C<$x> and C<$line> have the same number of elements in the 0th dimension! What PDL then did was thread over the higher dimensions in C<$x> and repeated the same operation 9 times to all the rows on C<$x>. This is PDL threading in action. What if you want to subtract C<$line> from the first line in C<$x> only? You can do that by specifying the line explicitly: pdl> $x(:,0) -= $line pdl> p $x [ [ 0 0 0 0 0 0 0 0 0 0 0] [11 12 13 14 15 16 17 18 19 20 21] [22 23 24 25 26 27 28 29 30 31 32] [33 34 35 36 37 38 39 40 41 42 43] [44 45 46 47 48 49 50 51 52 53 54] [55 56 57 58 59 60 61 62 63 64 65] [66 67 68 69 70 71 72 73 74 75 76] [77 78 79 80 81 82 83 84 85 86 87] [88 89 90 91 92 93 94 95 96 97 98] ] See L and L to learn more about specifying subsets from ndarrays. The true power of threading comes when you realise that the ndarray can have any number of dimensions! Let's make a 4 dimensional ndarray: pdl> $ndarray_4D = sequence(11,3,7,2) pdl> $c = $ndarray_4D - $line Now C<$c> is an ndarray of the same dimension as C<$ndarray_4D>. pdl> p $ndarray_4D->info => PDL: Double D [11,3,7,2] pdl> p $c->info => PDL: Double D [11,3,7,2] This time PDL has threaded over three higher dimensions automatically, subtracting C<$line> all the way. But, maybe you don't want to subtract from the rows (dimension 0), but from the columns (dimension 1). How do I subtract a column of numbers from each column in C<$x>? pdl> $cols = sequence(9) pdl> p $x->info => PDL: Double D [11,9] pdl> p $cols->info => PDL: Double D [9] Naturally, we can't just type C<$x - $cols>. The dimensions don't match: pdl> p $x - $cols PDL: PDL::Ops::minus(a,b,c): Parameter 'b' PDL: Mismatched implicit thread dimension 0: should be 11, is 9 How do we tell PDL that we want to subtract from dimension 1 instead? =head1 MANIPULATING DIMENSIONS There are many PDL functions that let you rearrange the dimensions of PDL arrays. They are mostly covered in L. The three most common ones are: xchg mv reorder =head2 Method: C The C method "B" two dimensions in an ndarray: pdl> $x = sequence(6,7,8,9) pdl> $x_xchg = $x->xchg(0,3) pdl> p $x->info => PDL: Double D [6,7,8,9] pdl> p $x_xchg->info => PDL: Double D [9,7,8,6] | | V V (dim 0) (dim 3) Notice that dimensions 0 and 3 were exchanged without affecting the other dimensions. Notice also that C does not alter C<$x>. The original variable C<$x> remains untouched. =head2 Method: C The C method "B" one dimension, in an ndarray, shifting other dimensions as necessary. pdl> $x = sequence(6,7,8,9) (dim 0) pdl> $x_mv = $x->mv(0,3) | pdl> V _____ pdl> p $x->info => PDL: Double D [6,7,8,9] pdl> p $x_mv->info => PDL: Double D [7,8,9,6] ----- | V (dim 3) Notice that when dimension 0 was moved to position 3, all the other dimensions had to be shifted as well. Notice also that C does not alter C<$x>. The original variable C<$x> remains untouched. =head2 Method: C The C method is a generalization of the C and C methods. It "B" the dimensions in any way you specify: pdl> $x = sequence(6,7,8,9) pdl> $x_reorder = $x->reorder(3,0,2,1) pdl> pdl> p $x->info => PDL: Double D [6,7,8,9] pdl> p $x_reorder->info => PDL: Double D [9,6,8,7] | | | | V V v V dimensions: 0 1 2 3 Notice what happened. When we wrote C we instructed PDL to: * Put dimension 3 first. * Put dimension 0 next. * Put dimension 2 next. * Put dimension 1 next. When you use the C method, all the dimensions are shuffled. Notice that C does not alter C<$x>. The original variable C<$x> remains untouched. =head1 GOTCHA: LINKING VS ASSIGNMENT =head2 Linking By default, ndarrays are B so that changes on one will go back and affect the original B. pdl> $x = sequence(4,5) pdl> $x_xchg = $x->xchg(1,0) Here, C<$x_xchg> B. It is merely a different way of looking at C<$x>. Any change in C<$x_xchg> will appear in C<$x> as well. pdl> p $x [ [ 0 1 2 3] [ 4 5 6 7] [ 8 9 10 11] [12 13 14 15] [16 17 18 19] ] pdl> $x_xchg += 3 pdl> p $x [ [ 3 4 5 6] [ 7 8 9 10] [11 12 13 14] [15 16 17 18] [19 20 21 22] ] =head2 Assignment Some times, linking is not the behaviour you want. If you want to make the ndarrays independent, use the C method: pdl> $x = sequence(4,5) pdl> $x_xchg = $x->copy->xchg(1,0) Now C<$x> and C<$x_xchg> are completely separate objects: pdl> p $x [ [ 0 1 2 3] [ 4 5 6 7] [ 8 9 10 11] [12 13 14 15] [16 17 18 19] ] pdl> $x_xchg += 3 pdl> p $x [ [ 0 1 2 3] [ 4 5 6 7] [ 8 9 10 11] [12 13 14 15] [16 17 18 19] ] pdl> $x_xchg [ [ 3 7 11 15 19] [ 4 8 12 16 20] [ 5 9 13 17 21] [ 6 10 14 18 22] ] =head1 PUTTING IT ALL TOGETHER Now we are ready to solve the problem that motivated this whole discussion: pdl> $x = sequence(11,9) pdl> $cols = sequence(9) pdl> pdl> p $x->info => PDL: Double D [11,9] pdl> p $cols->info => PDL: Double D [9] How do we tell PDL to subtract C<$cols> along dimension 1 instead of dimension 0? The simplest way is to use the C method and rely on PDL linking: pdl> p $x [ [ 0 1 2 3 4 5 6 7 8 9 10] [11 12 13 14 15 16 17 18 19 20 21] [22 23 24 25 26 27 28 29 30 31 32] [33 34 35 36 37 38 39 40 41 42 43] [44 45 46 47 48 49 50 51 52 53 54] [55 56 57 58 59 60 61 62 63 64 65] [66 67 68 69 70 71 72 73 74 75 76] [77 78 79 80 81 82 83 84 85 86 87] [88 89 90 91 92 93 94 95 96 97 98] ] pdl> $x->xchg(1,0) -= $cols pdl> p $x [ [ 0 1 2 3 4 5 6 7 8 9 10] [10 11 12 13 14 15 16 17 18 19 20] [20 21 22 23 24 25 26 27 28 29 30] [30 31 32 33 34 35 36 37 38 39 40] [40 41 42 43 44 45 46 47 48 49 50] [50 51 52 53 54 55 56 57 58 59 60] [60 61 62 63 64 65 66 67 68 69 70] [70 71 72 73 74 75 76 77 78 79 80] [80 81 82 83 84 85 86 87 88 89 90] ] =over 5 =item General Strategy: Move the dimensions you want to operate on to the start of your ndarray's dimension list. Then let PDL thread over the higher dimensions. =back =head1 EXAMPLE: CONWAY'S GAME OF LIFE Okay, enough theory. Let's do something a bit more interesting: We'll write B in PDL and see how powerful PDL can be! The B is a simulation run on a big two dimensional grid. Each cell in the grid can either be alive or dead (represented by 1 or 0). The next generation of cells in the grid is calculated with simple rules according to the number of living cells in it's immediate neighbourhood: 1) If an empty cell has exactly three neighbours, a living cell is generated. 2) If a living cell has less than two neighbours, it dies of overfeeding. 3) If a living cell has 4 or more neighbours, it dies from starvation. Only the first generation of cells is determined by the programmer. After that, the simulation runs completely according to these rules. To calculate the next generation, you need to look at each cell in the 2D field (requiring two loops), calculate the number of live cells adjacent to this cell (requiring another two loops) and then fill the next generation grid. =head2 Classical implementation Here's a classic way of writing this program in Perl. We only use PDL for addressing individual cells. #!/usr/bin/perl -w use PDL; use PDL::NiceSlice; # Make a board for the game of life. my $nx = 20; my $ny = 20; # Current generation. my $a1 = zeroes($nx, $ny); # Next generation. my $n = zeroes($nx, $ny); # Put in a simple glider. $a1(1:3,1:3) .= pdl ( [1,1,1], [0,0,1], [0,1,0] ); for (my $i = 0; $i < 100; $i++) { $n = zeroes($nx, $ny); $new_a = $a1->copy; for ($x = 0; $x < $nx; $x++) { for ($y = 0; $y < $ny; $y++) { # For each cell, look at the surrounding neighbours. for ($dx = -1; $dx <= 1; $dx++) { for ($dy = -1; $dy <= 1; $dy++) { $px = $x + $dx; $py = $y + $dy; # Wrap around at the edges. if ($px < 0) {$px = $nx-1}; if ($py < 0) {$py = $ny-1}; if ($px >= $nx) {$px = 0}; if ($py >= $ny) {$py = 0}; $n($x,$y) .= $n($x,$y) + $a1($px,$py); } } # Do not count the central cell itself. $n($x,$y) -= $a1($x,$y); # Work out if cell lives or dies: # Dead cell lives if n = 3 # Live cell dies if n is not 2 or 3 if ($a1($x,$y) == 1) { if ($n($x,$y) < 2) {$new_a($x,$y) .= 0}; if ($n($x,$y) > 3) {$new_a($x,$y) .= 0}; } else { if ($n($x,$y) == 3) {$new_a($x,$y) .= 1} } } } print $a1; $a1 = $new_a; } If you run this, you will see a small glider crawl diagonally across the grid of zeroes. On my machine, it prints out a couple of generations per second. =head2 Threaded PDL implementation And here's the threaded version in PDL. Just four lines of PDL code, and one of those is printing out the latest generation! #!/usr/bin/perl -w use PDL; use PDL::NiceSlice; my $x = zeroes(20,20); # Put in a simple glider. $x(1:3,1:3) .= pdl ( [1,1,1], [0,0,1], [0,1,0] ); my $n; for (my $i = 0; $i < 100; $i++) { # Calculate the number of neighbours per cell. $n = $x->range(ndcoords($x)-1,3,"periodic")->reorder(2,3,0,1); $n = $n->sumover->sumover - $x; # Calculate the next generation. $x = ((($n == 2) + ($n == 3))* $x) + (($n==3) * !$x); print $x; } The threaded PDL version is much faster: Classical => 32.79 seconds. Threaded => 0.41 seconds. =head2 Explanation How does the threaded version work? There are many PDL functions designed to help you carry out PDL threading. In this example, the key functions are: =head3 Method: C At the simplest level, the C method is a different way to select a portion of an ndarray. Instead of using the C<$x(2,3)> notation, we use another ndarray. pdl> $x = sequence(6,7) pdl> p $x [ [ 0 1 2 3 4 5] [ 6 7 8 9 10 11] [12 13 14 15 16 17] [18 19 20 21 22 23] [24 25 26 27 28 29] [30 31 32 33 34 35] [36 37 38 39 40 41] ] pdl> p $x->range( pdl [1,2] ) 13 pdl> p $x(1,2) [ [13] ] At this point, the C method looks very similar to a regular PDL slice. But the C method is more general. For example, you can select several components at once: pdl> $index = pdl [ [1,2],[2,3],[3,4],[4,5] ] pdl> p $x->range( $index ) [13 20 27 34] Additionally, C takes a second parameter which determines the size of the chunk to return: pdl> $size = 3 pdl> p $x->range( pdl([1,2]) , $size ) [ [13 14 15] [19 20 21] [25 26 27] ] We can use this to select one or more 3x3 boxes. Finally, C can take a third parameter called the "boundary" condition. It tells PDL what to do if the size box you request goes beyond the edge of the ndarray. We won't go over all the options. We'll just say that the option C means that the ndarray "wraps around". For example: pdl> p $x [ [ 0 1 2 3 4 5] [ 6 7 8 9 10 11] [12 13 14 15 16 17] [18 19 20 21 22 23] [24 25 26 27 28 29] [30 31 32 33 34 35] [36 37 38 39 40 41] ] pdl> $size = 3 pdl> p $x->range( pdl([4,2]) , $size , "periodic" ) [ [16 17 12] [22 23 18] [28 29 24] ] pdl> p $x->range( pdl([5,2]) , $size , "periodic" ) [ [17 12 13] [23 18 19] [29 24 25] ] Notice how the box wraps around the boundary of the ndarray. =head3 Method: C The C method is a convenience method that returns an enumerated list of coordinates suitable for use with the C method. pdl> p $ndarray = sequence(3,3) [ [0 1 2] [3 4 5] [6 7 8] ] pdl> p ndcoords($ndarray) [ [ [0 0] [1 0] [2 0] ] [ [0 1] [1 1] [2 1] ] [ [0 2] [1 2] [2 2] ] ] This can be a little hard to read. Basically it's saying that the coordinates for every element in C<$ndarray> is given by: (0,0) (1,0) (2,0) (1,0) (1,1) (2,1) (2,0) (2,1) (2,2) =head3 Combining C and C What really matters is that C is designed to work together with C, with no C<$size> parameter, you get the same ndarray back. pdl> p $ndarray [ [0 1 2] [3 4 5] [6 7 8] ] pdl> p $ndarray->range( ndcoords($ndarray) ) [ [0 1 2] [3 4 5] [6 7 8] ] Why would this be useful? Because now we can ask for a series of "boxes" for the entire ndarray. For example, 2x2 boxes: pdl> p $ndarray->range( ndcoords($ndarray) , 2 , "periodic" ) The output of this function is difficult to read because the "boxes" along the last two dimension. We can make the result more readable by rearranging the dimensions: pdl> p $ndarray->range( ndcoords($ndarray) , 2 , "periodic" )->reorder(2,3,0,1) [ [ [ [0 1] [3 4] ] [ [1 2] [4 5] ] ... ] Here you can see more clearly that [0 1] [3 4] Is the 2x2 box starting with the (0,0) element of C<$ndarray>. We are not done yet. For the game of life, we want 3x3 boxes from C<$x>: pdl> p $x [ [ 0 1 2 3 4 5] [ 6 7 8 9 10 11] [12 13 14 15 16 17] [18 19 20 21 22 23] [24 25 26 27 28 29] [30 31 32 33 34 35] [36 37 38 39 40 41] ] pdl> p $x->range( ndcoords($x) , 3 , "periodic" )->reorder(2,3,0,1) [ [ [ [ 0 1 2] [ 6 7 8] [12 13 14] ] ... ] We can confirm that this is the 3x3 box starting with the (0,0) element of C<$x>. But there is one problem. We actually want the 3x3 box to be B on (0,0). That's not a problem. Just subtract 1 from all the coordinates in C. Remember that the "periodic" option takes care of making everything wrap around. pdl> p $x->range( ndcoords($x) - 1 , 3 , "periodic" )->reorder(2,3,0,1) [ [ [ [41 36 37] [ 5 0 1] [11 6 7] ] [ [36 37 38] [ 0 1 2] [ 6 7 8] ] ... Now we see a 3x3 box with the (0,0) element in the centre of the box. =head3 Method: C The C method adds along only the first dimension. If we apply it twice, we will be adding all the elements of each 3x3 box. pdl> $n = $x->range(ndcoords($x)-1,3,"periodic")->reorder(2,3,0,1) pdl> p $n [ [ [ [41 36 37] [ 5 0 1] [11 6 7] ] [ [36 37 38] [ 0 1 2] [ 6 7 8] ] ... pdl> p $n->sumover->sumover [ [144 135 144 153 162 153] [ 72 63 72 81 90 81] [126 117 126 135 144 135] [180 171 180 189 198 189] [234 225 234 243 252 243] [288 279 288 297 306 297] [216 207 216 225 234 225] ] Use a calculator to confirm that 144 is the sum of all the elements in the first 3x3 box and 135 is the sum of all the elements in the second 3x3 box. =head3 Counting neighbours We are almost there! Adding up all the elements in a 3x3 box is not B what we want. We don't want to count the center box. Fortunately, this is an easy fix: pdl> p $n->sumover->sumover - $x [ [144 134 142 150 158 148] [ 66 56 64 72 80 70] [114 104 112 120 128 118] [162 152 160 168 176 166] [210 200 208 216 224 214] [258 248 256 264 272 262] [180 170 178 186 194 184] ] When applied to Conway's Game of Life, this will tell us how many living neighbours each cell has: pdl> $x = zeroes(10,10) pdl> $x(1:3,1:3) .= pdl ( [1,1,1], ..( > [0,0,1], ..( > [0,1,0] ) pdl> p $x [ [0 0 0 0 0 0 0 0 0 0] [0 1 1 1 0 0 0 0 0 0] [0 0 0 1 0 0 0 0 0 0] [0 0 1 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] ] pdl> $n = $x->range(ndcoords($x)-1,3,"periodic")->reorder(2,3,0,1) pdl> $n = $n->sumover->sumover - $x pdl> p $n [ [1 2 3 2 1 0 0 0 0 0] [1 1 3 2 2 0 0 0 0 0] [1 3 5 3 2 0 0 0 0 0] [0 1 1 2 1 0 0 0 0 0] [0 1 1 1 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] ] For example, this tells us that cell (0,0) has 1 living neighbour, while cell (2,2) has 5 living neighbours. =head3 Calculating the next generation At this point, the variable C<$n> has the number of living neighbours for every cell. Now we apply the rules of the game of life to calculate the next generation. =over 5 =item If an empty cell has exactly three neighbours, a living cell is generated. Get a list of cells that have exactly three neighbours: pdl> p ($n == 3) [ [0 0 1 0 0 0 0 0 0 0] [0 0 1 0 0 0 0 0 0 0] [0 1 0 1 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] ] Get a list of B cells that have exactly three neighbours: pdl> p ($n == 3) * !$x =item If a living cell has less than 2 or more than 3 neighbours, it dies. Get a list of cells that have exactly 2 or 3 neighbours: pdl> p (($n == 2) + ($n == 3)) [ [0 1 1 1 0 0 0 0 0 0] [0 0 1 1 1 0 0 0 0 0] [0 1 0 1 1 0 0 0 0 0] [0 0 0 1 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] ] Get a list of B cells that have exactly 2 or 3 neighbours: pdl> p (($n == 2) + ($n == 3)) * $x =back Putting it all together, the next generation is: pdl> $x = ((($n == 2) + ($n == 3)) * $x) + (($n == 3) * !$x) pdl> p $x [ [0 0 1 0 0 0 0 0 0 0] [0 0 1 1 0 0 0 0 0 0] [0 1 0 1 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] [0 0 0 0 0 0 0 0 0 0] ] =head2 Bonus feature: Graphics! If you have L installed, you can make a graphical version of the program by just changing three lines: #!/usr/bin/perl use PDL; use PDL::NiceSlice; use PDL::Graphics::TriD; my $x = zeroes(20,20); # Put in a simple glider. $x(1:3,1:3) .= pdl ( [1,1,1], [0,0,1], [0,1,0] ); my $n; for (my $i = 0; $i < 100; $i++) { # Calculate the number of neighbours per cell. $n = $x->range(ndcoords($x)-1,3,"periodic")->reorder(2,3,0,1); $n = $n->sumover->sumover - $x; # Calculate the next generation. $x = ((($n == 2) + ($n == 3))* $x) + (($n==3) * !$x); # Display. nokeeptwiddling3d(); imagrgb [$x]; } But if we really want to see something interesting, we should make a few more changes: 1) Start with a random collection of 1's and 0's. 2) Make the grid larger. 3) Add a small timeout so we can see the game evolve better. 4) Use a while loop so that the program can run as long as it needs to. #!/usr/bin/perl use PDL; use PDL::NiceSlice; use PDL::Graphics::TriD; use Time::HiRes qw(usleep); my $x = random(100,100); $x = ($x < 0.5); my $n; while (1) { # Calculate the number of neighbours per cell. $n = $x->range(ndcoords($x)-1,3,"periodic")->reorder(2,3,0,1); $n = $n->sumover->sumover - $x; # Calculate the next generation. $x = ((($n == 2) + ($n == 3))* $x) + (($n==3) * !$x); # Display. nokeeptwiddling3d(); imagrgb [$x]; # Sleep for 0.1 seconds. usleep(100000); } =head1 CONCLUSION: GENERAL STRATEGY The general strategy is: I Threading is a powerful tool that helps eliminate for-loops and can make your code more concise. Hopefully this tutorial has shown why it is worth getting to grips with threading in PDL. =head1 COPYRIGHT Copyright 2010 Matthew Kenworthy (kenworthy@strw.leidenuniv.nl) and Daniel Carrera (dcarrera@gmail.com). You can distribute and/or modify this document under the same terms as the current Perl license. See: http://dev.perl.org/licenses/ PDL-2.074/Basic/Pod/Tutorials.pod0000644000175000017500000000662314146003631016335 0ustar osboxesosboxes=head1 NAME PDL::Tutorials - A guide to PDL's tutorial documentation. =head1 MIGRATION These are our migration guides for users familiar with other types of numerical analysis software. =over 5 =item L Migration guide for MATLAB users. This page explains the key differences between MATLAB and PDL from the point of view of a MATLAB user. =item L Migration guide for Scilab users. This page explains the key differences between Scilab and PDL from the point of view of a Scilab user. =back =head1 FOUNDATION =over 5 =item L Why did we write PDL? This document explains some of the history and motivation behind the Perl Data Language. It is an attempt to answer the question "Why PDL?". =item L Quick introduction to PDL features. A hands-on guide suitable for complete beginners. This page assumes no previous knowledge of Perl or PDL. =item L After you have read the QuickStart guide, you should follow up with this document. This guide goes more deeply into the concepts of "indexing" and "slicing" and how they form the core of numerical analysis with PDL. =back =head1 INTERMEDIATE =over 5 =item L B is one of PDL's most powerful features. If you know MATLAB, you've heard of "vectorizing". Well, B is like "vectorizing on steroids". It lets you make very fast and compact code by avoiding nested loops. All vector-based languages do this, but PDL generalizes the technique to all sorts of applications. This tutorial introduces PDL's threading feature, and it shows an example implementing Conway's Game of Life in 10 lines and 80 times faster than a classical implementation. =item L Sometimes it is useful to specify that a certain value is "bad" or "missing". Scientific instruments some times include portions of invalid data. For example, a CCD camera might produce an image with over-exposed pixels. PDL's "bad values" feature gives you an easy way to deal with this sort of imperfect data. =item L Tips and suggestions for using PDL. This page is an assorted collection of programming tidbits that some PDL users have found useful. Some of these tips might be of help when you write your programs. =back =head1 ADVANCED =over 5 =item L PDL's Pre-Processor is one of PDL's most powerful features. You write a function definition in special markup and the preprocessor generates real C code which can be compiled. With PDL:PP you get the full speed of native C code without having to deal with the full complexity of the C language. =item L A simple cookbook explaining how to create ndarray manually, either from Perl or from C/XS code. This page covers the PDL core routines that comprise the PDL API. If you need to access ndarrays from C/XS, this is the document for you. =item L Description of the inner workings of the PDL module. Very few people need to see this. This page is mainly for PDL developers, or people interested in debugging PDL or changing the internals of PDL. If you can read this document and understand all of it, and you additionally understand L, you will be awarded the title of "PDL Guru". =back =head1 COPYRIGHT Copyright 2010 Daniel Carrera (dcarrera@gmail.com). You can distribute and/or modify this document under the same terms as the current Perl license. See: http://dev.perl.org/licenses/ PDL-2.074/Basic/Pod/Objects.pod0000644000175000017500000000733114146003631015735 0ustar osboxesosboxes=head1 NAME PDL::Objects -- Object-Orientation, what is it and how to exploit it =head1 DESCRIPTION This still needs to be written properly. [Also, is there a good reason we don't recommend storing extra object data in the header hash?] =head2 Inheritance There are basically two reasons for subclassing ndarrays. The first is simply that you want to be able to use your own routines like $ndarray->something() but don't want to mess up the PDL namespace (a worthy goal, indeed!). The other is that you wish to provide special handling of some functions or more information about the data the ndarray contains. In the first case, you can do with package BAR; @ISA=qw/PDL/; sub foo {my($this) = @_; fiddle;} package main; $x = PDL::pdl(BAR,5); $x->foo(); However, because a PDL object is an opaque reference to a C struct, it is not possible to extend the PDL class by e.g. extra data via subclassing. To circumvent this problem PerlDL has built-in support to extent the PDL class via the I relation for blessed hashes. You can get the I behave like I simply in that you assign the C object to the attribute named PDL and redefine the method initialize(). package FOO; @FOO::ISA = qw(PDL); sub initialize { my $class = shift; my $self = { creation_time => time(), # necessary extension :-) PDL => null, # used to store PDL object }; bless $self, $class; } All PDL constructors will call initialize() to make sure that your extensions are added by I PDL constructors automatically. The C attribute is used by perlDL to store the PDL object and all PDL methods use this attribute automatically if they are called with a blessed hash reference instead of a PDL object (a blessed scalar). Do remember that if you subclass a class that is subclassed from an ndarray, you need to call SUPER::initialize. NEED STUFF ABOUT CODE REFs!! =head2 Examples You can find some simple examples of PDL subclassing in the PDL distribution test-case files. Look in C, C, etc. =head2 Output Auto-Creation and Subclassed Objects For PDL Functions where the output is created and returned, PDL will either call the subclassed object's C or C method to create the output object. (See L for a discussion on Output Auto-Creation.) This behavior is summarized as follows: =over 1 =item * For I functions, defined as having a signature of func( a(), [o]b() ) PDL will call $a->copy to create the output object. In the spirit of the Perl philosophy of making I, This behavior enables PDL-subclassed objects to be written without having to overload the many simple PDL functions in this category. The file t/subclass4.t in the PDL Distribution tests for this behavior. See that file for an example. =item * For other functions, PDL will call $class->initialize to create the output object. Where $class is the class name of the first argument supplied to the function. For these more complex cases, it is difficult to second-guess the subclassed object's designer to know if a C or a C is appropriate. So for these cases, $class->initialize is called by default. If this is not appropriate for you, overload the function in your subclass and do whatever is appropriate is the overloaded function's code. =back =head1 AUTHOR Copyright (C) Karl Glazebrook (kgb@aaoepp.aao.gov.au), Tuomas J. Lukka, (lukka@husc.harvard.edu) and Christian Soeller (c.soeller@auckland.ac.nz) 2000. Commercial reproduction of this documentation in a different format is forbidden. =cut PDL-2.074/Basic/Pod/Index.pod0000644000175000017500000002452314146003631015415 0ustar osboxesosboxes =head1 NAME PDL::Index - an index of PDL documentation =head1 DESCRIPTION A meta document listing the documented PDL modules and the PDL manual documents =head1 PDL manuals =over 4 =item * L - making ndarrays from Perl and C/XS code =item * L - Discussion of bad value support in PDL =item * L - A journey through PDL's documentation, from beginner to advanced. =item * L - description of the dataflow philosophy =item * L - PDL changes between V1.0 and V2.0 =item * L - Frequently asked questions about PDL =item * L - An overview of the modules in the PDL::IO namespace. =item * L - Introduction to indexing and slicing ndarrays. =item * L - description of some aspects of the current internals =item * L - A guide for MATLAB users. =item * L - A guide to PDL's module reference. =item * L - Object-Orientation, what is it and how to exploit it =item * L - Generate PDL routines from concise descriptions =item * L - Parallel Processor MultiThreading Support in PDL (Experimental) =item * L - Why did we write PDL? =item * L - Quick introduction to PDL features. =item * L - A guide for Scilab users. =item * L - Tutorial for PDL's Threading feature =item * L - Small tidbits of useful arcana. Programming tidbits and such. =item * L - A guide to PDL's tutorial documentation. =back =head1 PDL scripts =over 4 =item * L - Simple shell (version 2) for PDL =item * L - shell interface to PDL documentation =item * L - Simple shell for PDL (see also L) =item * L - script to generate Makefile.PL and PP file skeleton =back =head1 PDL modules =over 4 =item * L - the Perl Data Language =item * L - MatLab style AutoLoader for PDL =item * L - PDL does process bad values =item * L - Basic utility functions for PDL =item * L - call functions in external shared libraries =item * L - PDL subclass which allows reading and writing of fixed-length character strings as byte PDLs =item * L - compression utilities =item * L - basic compile time constants for PDL =item * L - fundamental PDL functionality and vectorization/threading =item * L - PDL development module =item * L - functions to support debugging of PDL scripts =item * L - Non-memory-resident array object =item * L - support for PDL online documentation =item * L - commands for accessing PDL doc database from 'perldl' shell =item * L - PDL export control =item * L - FFTs for PDL =item * L - PDL interface to the Fastest Fourier Transform in the West v2.x =item * L - Linear predictive filtering =item * L - linear filtering for PDL =item * L - routines for fitting gaussians =item * L - Levenberg-Marquardt fitting routine for PDL =item * L - routines for fitting data with linear combinations of functions. =item * L - routines for fitting with polynomials =item * L - interpolation, integration, & gradient estimation (differentiation) of functions =item * L - PDL interface to the Proj4 projection library. =item * L - PDL interface to numerical differentiation routines in GSL =item * L - PDL interface to numerical integration routines in GSL =item * L - PDL interface to Interpolation routines in GSL =item * L - PDL interface to multidimensional root-finding routines in GSL =item * L - PDL interface to RNG and randist routines in GSL =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - PDL interface to GSL Special Functions =item * L - Gaussian distributions. =item * L - An object oriented interface to PDL graphics =item * L - Display PDL images on IIS devices (saoimage/ximtool) =item * L - provides access to a number of look-up tables =item * L - derive limits for display purposes =item * L - PDL TriD OpenGL interface using POGL =item * L - quick routines to plot lots of stuff from ndarrays. =item * L - PGPLOT enhanced interface for PDL =item * L - A OO interface to PGPLOT windows =item * L - Setting PGPLOT options =item * L - Object-oriented interface from perl/PDL to the PLPLOT plotting library =item * L - PDL 3D interface =item * L - default event handler subroutines =item * L - 3D Surface contours for TriD =item * L - Text tools =item * L - Mathematical Graph objects for PDL =item * L - Simple Graph Objects for TriD =item * L - Helper routines for Three-dimensional graphics =item * L - A Tk widget interface to the PDL::Graphics::TriD. =item * L - TriD VRML backend =item * L - a module for reading DICOM images. =item * L - data dumping for structs with PDLs =item * L - Simple FITS support for PDL =item * L - A simple, fast and convenient io format for PerlDL. =item * L - A flexible binary I/O format for PerlDL =item * L - Interface to the GD image library. =item * L - An interface library for HDF4 files. =item * L - PDL interface to the HDF4 SD library. =item * L - I/O of IDL Save Files =item * L - misc IO routines for PDL =item * L - image I/O for PDL =item * L - pnm format I/O for PDL =item * L - helper functions to make PDL usable with Storable =item * L - Miscellaneous 2D image processing functions =item * L - useful image processing in N dimensions =item * L - some utility functions for RGB image data handling =item * L - minimum PDL module OO loader =item * L - minimum PDL module function loader =item * L - declare PDL lvalue subs =item * L - extended mathematical operations and special functions =item * L - a convenience matrix class for column-major access =item * L - Some Useful Matrix Operations =item * L - a PDL interface to the Minuit library =item * L - toward a nicer slicing syntax for PDL =item * L - Fundamental mathematical operators =item * L - Simplex optimization routines =item * L - simplifies option passing by hash in PerlDL =item * L - filter out Moose cruft =item * L - enable PDL NiceSlice syntax =item * L - implement perldl aliases/escapes =item * L - disable default print output =item * L - profile for Perldl2 shell =item * L - primitive operations for pdl =item * L - a C function for PDL =item * L - PDL interface to the slatec numerical programming library =item * L - Indexing, slicing, and dicing =item * L - tests for some PP features =item * L - Coordinate transforms, image warping, and N-D functions =item * L - Useful cartographic projections =item * L - PDL::Transform interface to the Proj4 projection library =item * L - define fundamental PDL Datatypes =item * L - primitive ufunc operations for pdl =back =head1 HISTORY Automatically generated by scantree.pl for PDL version 2.004_995. PDL-2.074/Basic/Pod/MATLAB.pod0000644000175000017500000007027714160015533015315 0ustar osboxesosboxes=head1 NAME PDL::MATLAB - A guide for MATLAB users. =head1 INTRODUCTION If you are a MATLAB user, this page is for you. It explains the key differences between MATLAB and PDL to help you get going as quickly as possible. B. For that, go to L. This document B the Quick Start guide, as it highlights the key differences between MATLAB and PDL. =head1 Perl The key differences between MATLAB and PDL are threading, and B. Threading means you can get a reference to just a part of your data, and operate on it in a way that makes sense for your application. Those operations will be reflected in the original data. Perl is a general purpose programming language with thousands of modules freely available on the web. PDL is an extension of Perl. This gives PDL programs access to more features than most numerical tools can dream of. At the same time, most syntax differences between MATLAB and PDL are a result of its Perl foundation. B. But if you wish to learn Perl, there is excellent documentation available on-line (L) or through the command C. There is also a beginner's portal (L). Perl's module repository is called CPAN (L) and it has a vast array of modules. Run C for more information. =head1 TERMINOLOGY: NDARRAY MATLAB typically refers to vectors, matrices, and arrays. Perl already has arrays, and the terms "vector" and "matrix" typically refer to one- and two-dimensional collections of data. Having no good term to describe their object, PDL developers coined the term "I" to give a name to their data type. An I consists of a series of numbers organized as an N-dimensional data set. ndarrays provide efficient storage and fast computation of large N-dimensional matrices. They are highly optimized for numerical work. For more information, see "B" later in this document. =head1 COMMAND WINDOW AND IDE Unlike MATLAB, PDL does not come with a dedicated IDE. It does however come with an interactive shell and you can use a Perl IDE to develop PDL programs. =head2 PDL interactive shell To start the interactive shell, open a terminal and run C or C. As in MATLAB, the interactive shell is the best way to learn the language. To exit the shell, type C, just like MATLAB. =head2 Writing PDL programs One popular IDE for Perl is called Padre (L). It is cross platform and easy to use. Whenever you write a stand-alone PDL program (i.e. outside the C or C shell) you must start the program with C. This command imports the PDL module into Perl. Here is a sample PDL program: use PDL; # Import main PDL module. use PDL::NiceSlice; # Import additional PDL module. use PDL::AutoLoader; # Import additional PDL module. $y = pdl [2,3,4]; # Statements end in semicolon. $A = pdl [ [1,2,3],[4,5,6] ]; # 2-dimensional matrix. print $A x $y->transpose; Save this file as C and run it with: perl myprogram.pl =head2 New: Flexible syntax In current versions of PDL (version 2.4.7 or later) there is a flexible matrix syntax that can look extremely similar to MATLAB: 1) Use spaces to separate elements: $y = pdl q[ 2 3 4 ]; 2) Use a ';' to delimit rows: $A = pdl q[ 1,2,3 ; 4,5,6 ]; Basically, as long as you put a C in front of the opening bracket, PDL should "do what you mean". So you can write in a syntax that is more comfortable for you. =head1 MODULES FOR MATLAB USERS There are two modules that MATLAB users will want to use: =over 5 =item L Gives PDL a syntax for slices (sub-matrices) that is shorter and more familiar to MATLAB users. % MATLAB b(1:5) --> Selects the first 5 elements from b. # PDL without NiceSlice $y->slice("0:4") --> Selects the first 5 elements from $y. # PDL with NiceSlice $y(0:4) --> Selects the first 5 elements from $y. =item L Provides a MATLAB-style autoloader for PDL. If an unknown function C is called, PDL looks for a file called C. If it finds one, it reads it. =back =head1 BASIC FEATURES This section explains how PDL's syntax differs from MATLAB. Most MATLAB users will want to start here. =head2 General "gotchas" =over 5 =item Indices In PDL, indices start at '0' (like C and Java), not 1 (like MATLAB or FORTRAN). For example, if C<$y> is an array with 5 elements, the elements would be numbered from 0 to 4. This is different, but less difficult as soon as you need to do calculations based on offsets. =item Displaying an object MATLAB normally displays object contents automatically. In the PDL shells you display objects explicitly with the C command or the shortcut C

: MATLAB: >> a = 12 a = 12 >> b = 23; % Suppress output. >> PDL Shell (perldl or pdl2): pdl> $x = 12 # No output. pdl> print $x # Print object. 12 pdl> p $x # "p" is a shorthand for "print" in the shell. 12 pdl> In pdl2 there is the C command that will toggle the "quiet" mode, which defaults to on. In "print" mode, expressions you enter on the command line will have their values printed. =back =head2 Creating ndarrays =over 5 =item Variables in PDL Variables always start with the '$' sign. MATLAB: value = 42 PerlDL: $value = 42 =item Basic syntax Use the "pdl" constructor to create a new I. MATLAB: v = [1,2,3,4] PerlDL: $v = pdl [1,2,3,4] MATLAB: A = [ 1,2,3 ; 3,4,5 ] PerlDL: $A = pdl [ [1,2,3] , [3,4,5] ] =item Simple matrices MATLAB PDL ------ ------ Matrix of ones ones(5) ones 5,5 Matrix of zeros zeros(5) zeros 5,5 Random matrix rand(5) random 5,5 Linear vector 1:5 sequence 5 Notice that in PDL the parenthesis in a function call are often optional. It is important to keep an eye out for possible ambiguities. For example: pdl> p zeros 2, 2 + 2 Should this be interpreted as C or as C? Both are valid statements: pdl> p zeros(2,2) + 2 [ [2 2] [2 2] ] pdl> p zeros 2, (2+2) [ [0 0] [0 0] [0 0] [0 0] ] Rather than trying to memorize Perl's order of precedence, it is best to use parentheses to make your code unambiguous. Remember you may need to come back to your code, and parentheses make your own (as well as others') comprehension easier. =item Linearly spaced sequences MATLAB: >> linspace(2,10,5) ans = 2 4 6 8 10 PerlDL: pdl> p zeroes(5)->xlinvals(2,10) [2 4 6 8 10] B: Start with a 1-dimensional ndarray of 5 elements and give it equally spaced values from 2 to 10. MATLAB has a single function call for this. On the other hand, PDL's method is more flexible: pdl> p zeros(5,5)->xlinvals(2,10) [ [ 2 4 6 8 10] [ 2 4 6 8 10] [ 2 4 6 8 10] [ 2 4 6 8 10] [ 2 4 6 8 10] ] pdl> p zeros(5,5)->ylinvals(2,10) [ [ 2 2 2 2 2] [ 4 4 4 4 4] [ 6 6 6 6 6] [ 8 8 8 8 8] [10 10 10 10 10] ] pdl> p zeros(3,3,3)->zlinvals(2,6) [ [ [2 2 2] [2 2 2] [2 2 2] ] [ [4 4 4] [4 4 4] [4 4 4] ] [ [6 6 6] [6 6 6] [6 6 6] ] ] =item Slicing and indices Extracting a subset from a collection of data is known as I. PDL and MATLAB have a similar syntax for slicing, but there are two important differences: 1) PDL indices start at 0, as in C and Java. MATLAB starts indices at 1. 2) In MATLAB you think "rows and columns". In PDL, think "x and y". MATLAB PerlDL ------ ------ >> A pdl> p $A A = [ 1 2 3 [1 2 3] 4 5 6 [4 5 6] 7 8 9 [7 8 9] ] ------------------------------------------------------- (row = 2, col = 1) (x = 0, y = 1) >> A(2,1) pdl> p $A(0,1) ans = [ 4 [4] ] ------------------------------------------------------- (row = 2 to 3, col = 1 to 2) (x = 0 to 1, y = 1 to 2) >> A(2:3,1:2) pdl> p $A(0:1,1:2) ans = [ 4 5 [4 5] 7 8 [7 8] ] =over 5 =item B When you write a stand-alone PDL program, if you want the "nice slice" syntax, you have to include the L module. See the previous section "B" for more information. use PDL; # Import main PDL module. use PDL::NiceSlice; # Nice syntax for slicing. use PDL::AutoLoader; # MATLAB-like autoloader. $A = random 4,4; print $A(0,1); =back =back =head2 Matrix Operations =over 10 =item Matrix multiplication MATLAB: A * B PerlDL: $A x $B =item Element-wise multiplication MATLAB: A .* B PerlDL: $A * $B =item Transpose MATLAB: A' PerlDL: $A->transpose =back =head2 Functions that aggregate data Some functions (like C, C and C) aggregate data for an N-dimensional data set. This is a place where MATLAB and PDL take a different approach: =over 10 =item In MATLAB, these functions all work along one dimension. >> A = [ 1,5,4 ; 4,2,1 ] A = 1 5 4 4 2 1 >> max(A) ans = 4 5 4 >> max(A') ans = 5 4 If you want the maximum for the entire data set, you can use the special C notation which basically turns the entire data set into a single 1-dimensional vector. >> max(A(:)) ans = 5 >> A = ones(2,2,2,2) >> max(A(:)) ans = 1 =item PDL offers two functions for each feature. sum vs sumover avg vs average max vs maximum min vs minimum The B works over a dimension, while the B works over the entire ndarray. pdl> p $A = pdl [ [1,5,4] , [4,2,1] ] [ [1 5 4] [4 2 1] ] pdl> p $A->maximum [5 4] pdl> p $A->transpose->maximum [4 5 4] pdl> p $A->max 5 pdl> p ones(2,2,2)->max 1 pdl> p ones(2,2,2,2)->max 1 =back =over 5 =item B Notice that PDL aggregates horizontally while MATLAB aggregates vertically. In other words: MATLAB PerlDL max(A) == $A->transpose->maximum max(A') == $A->maximum B: In MATLAB you think "rows and columns". In PDL, think "x and y". =back =head2 Higher dimensional data sets A related issue is how MATLAB and PDL understand data sets of higher dimension. MATLAB was designed for 1D vectors and 2D matrices. Higher dimensional objects ("N-D arrays") were added on top. In contrast, PDL was designed for N-dimensional ndarrays from the start. This leads to a few surprises in MATLAB that don't occur in PDL: =over 5 =item MATLAB sees a vector as a 2D matrix. MATLAB PerlDL ------ ------ >> vector = [1,2,3,4]; pdl> $vector = pdl [1,2,3,4] >> size(vector) pdl> p $vector->dims ans = 1 4 4 MATLAB sees C<[1,2,3,4]> as a 2D matrix (1x4 matrix). PDL sees it as a 1D vector: A single dimension of size 4. =item But MATLAB ignores the last dimension of a 4x1x1 matrix. MATLAB PerlDL ------ ------ >> A = ones(4,1,1); pdl> $A = ones 4,1,1 >> size(A) pdl> p $A->dims ans = 4 1 4 1 1 =item And MATLAB treats a 4x1x1 matrix differently from a 1x1x4 matrix. MATLAB PerlDL ------ ------ >> A = ones(1,1,4); pdl> $A = ones 1,1,4 >> size(A) pdl> p $A->dims ans = 1 1 4 1 1 4 =item MATLAB has no direct syntax for N-D arrays. pdl> $A = pdl [ [[1,2,3],[4,5,6]], [[2,3,4],[5,6,7]] ] pdl> p $A->dims 3 2 2 =item Feature support. In MATLAB, several features such as sparse matrix support are not available for N-D arrays. In PDL, just about any feature supported by 1D and 2D ndarrays, is equally supported by N-dimensional ndarrays. There is usually no distinction. =back =head2 Loop Structures Perl has many loop structures, but we will only show the one that is most familiar to MATLAB users: MATLAB PerlDL ------ ------ for i = 1:10 for $i (1..10) { disp(i) print $i endfor } =over 5 =item B Never use for-loops for numerical work. Perl's for-loops are faster than MATLAB's, but they both pale against a "vectorized" operation. PDL has many tools that facilitate writing vectorized programs. These are beyond the scope of this guide. To learn more, see: L, L, and L. Likewise, never use C<1..10> for numerical work, even outside a for-loop. C<1..10> is a Perl array. Perl arrays are designed for flexibility, not speed. Use I instead. To learn more, see the next section. =back =head2 ndarrays vs Perl Arrays It is important to note the difference between an I and a Perl array. Perl has a general-purpose array object that can hold any type of element: @perl_array = 1..10; @perl_array = ( 12, "Hello" ); @perl_array = ( 1, 2, 3, \@another_perl_array, sequence(5) ); Perl arrays allow you to create powerful data structures (see B below), B. For that, use I: $pdl = pdl [ 1, 2, 3, 4 ]; $pdl = sequence 10_000_000; $pdl = ones 600, 600; For example: $points = pdl 1..10_000_000 # 4.7 seconds $points = sequence 10_000_000 # milliseconds B: You can use underscores in numbers (C<10_000_000> reads better than C<10000000>). =head2 Conditionals Perl has many conditionals, but we will only show the one that is most familiar to MATLAB users: MATLAB PerlDL ------ ------ if value > MAX if ($value > $MAX) { disp("Too large") print "Too large\n"; elseif value < MIN } elsif ($value < $MIN) { disp("Too small") print "Too small\n"; else } else { disp("Perfect!") print "Perfect!\n"; end } =over 5 =item B Here is a "gotcha": MATLAB: elseif PerlDL: elsif If your conditional gives a syntax error, check that you wrote your C's correctly. =back =head2 TIMTOWDI (There Is More Than One Way To Do It) One of the most interesting differences between PDL and other tools is the expressiveness of the Perl language. TIMTOWDI, or "There Is More Than One Way To Do It", is Perl's motto. Perl was written by a linguist, and one of its defining properties is that statements can be formulated in different ways to give the language a more natural feel. For example, you are unlikely to say to a friend: "While I am not finished, I will keep working." Human language is more flexible than that. Instead, you are more likely to say: "I will keep working until I am finished." Owing to its linguistic roots, Perl is the only programming language with this sort of flexibility. For example, Perl has traditional while-loops and if-statements: while ( ! finished() ) { keep_working(); } if ( ! wife_angry() ) { kiss_wife(); } But it also offers the alternative B and B statements: until ( finished() ) { keep_working(); } unless ( wife_angry() ) { kiss_wife(); } And Perl allows you to write loops and conditionals in "postfix" form: keep_working() until finished(); kiss_wife() unless wife_angry(); In this way, Perl often allows you to write more natural, easy to understand code than is possible in more restrictive programming languages. =head2 Functions PDL's syntax for declaring functions differs significantly from MATLAB's. MATLAB PerlDL ------ ------ function retval = foo(x,y) sub foo { retval = x.**2 + x.*y my ($x, $y) = @_; endfunction return $x**2 + $x*$y; } Don't be intimidated by all the new syntax. Here is a quick run through a function declaration in PDL: 1) "B" stands for "subroutine". 2) "B" declares variables to be local to the function. This helps you not accidentally use undeclared variables, which is enforced if you C. See L for more. 3) "B<@_>" is a special Perl array that holds all the function parameters. This might seem like a strange way to do functions, but it allows you to make functions that take a variable number of parameters. For example, the following function takes any number of parameters and adds them together: sub mysum { my ($i, $total) = (0, 0); for $i (@_) { $total += $i; } return $total; } In more recent versions of Perl, you can C for a different syntax for declaring function parameters. See L for more. 4) You can assign values to several variables at once using the syntax: ($x, $y, $z) = (1, 2, 3); So, in the previous examples: # This declares two local variables and initializes them to 0. my ($i, $total) = (0, 0); # This takes the first two elements of @_ and puts them in $x and $y. my ($x, $y) = @_; 5) The "B" statement gives the return value of the function, if any. =head1 ADDITIONAL FEATURES =head2 ASCII File IO To read data files containing whitespace separated columns of numbers (as would be read using the MATLAB I command) one uses the PDL I in L. For a general review of the IO functionality available in PDL, see the documentation for L, e.g., C in the I shell or C< pdldoc PDL::IO > from the shell command line. =head2 Data structures To create complex data structures, MATLAB uses "I" and "I". Perl's arrays and hashes offer similar functionality but are more powerful and flexible. This section is only a quick overview of what Perl has to offer. To learn more about this, please go to L or run the command C. =over 5 =item Arrays Perl arrays are similar to MATLAB's cell arrays, but more flexible. For example, in MATLAB, a cell array is still fundamentally a matrix. It is made of rows, and rows must have the same length. MATLAB ------ array = {1, 12, 'hello'; rand(3, 2), ones(3), 'junk'} => OK array = {1, 12, 'hello'; rand(3, 2), ones(3) } => ERROR A Perl array is a general purpose, sequential data structure. It can contain any data type. PerlDL ------ @array = ( [1, 12, 'hello'] , [ random(3,2), ones(3,3), 'junk' ] ) => OK @array = ( [1, 12, 'hello'] , [ random(3,2), ones(3,3) ] ) => OK @array = ( 5 , {'name' => 'Mike'} , [1, 12, 'hello'] ) => OK Notice that Perl array's start with the "@" prefix instead of the "$" used by ndarrays. I or run the command C.> =item Hashes Perl hashes are similar to MATLAB's structure arrays: MATLAB ------ >> drink = struct('type', 'coke', 'size', 'large', 'myarray', {1,2,3}) >> drink.type = 'sprite' >> drink.price = 12 % Add new field to structure array. PerlDL ------ pdl> %drink = ( type => 'coke' , size => 'large', myndarray => ones(3,3,3) ) pdl> $drink{type} = 'sprite' pdl> $drink{price} = 12 # Add new field to hash. Notice that Perl hashes start with the "%" prefix instead of the "@" for arrays and "$" used by ndarrays. I or run the command C.> =back =head2 Performance PDL has powerful performance features, some of which are not normally available in numerical computation tools. The following pages will guide you through these features: =over 5 =item L B: Beginner This beginner tutorial covers the standard "vectorization" feature that you already know from MATLAB. Use this page to learn how to avoid for-loops to make your program more efficient. =item L B: Intermediate PDL's "vectorization" feature goes beyond what most numerical software can do. In this tutorial you'll learn how to "thread" over higher dimensions, allowing you to vectorize your program further than is possible in MATLAB. =item Benchmarks B: Intermediate Perl comes with an easy to use benchmarks module to help you find how long it takes to execute different parts of your code. It is a great tool to help you focus your optimization efforts. You can read about it online (L) or through the command C. =item L B: Advanced PDL's Pre-Processor is one of PDL's most powerful features. You write a function definition in special markup and the pre-processor generates real C code which can be compiled. With PDL:PP you get the full speed of native C code without having to deal with the full complexity of the C language. =back =head2 Plotting PDL has full-featured plotting abilities. Unlike MATLAB, PDL relies more on third-party libraries (pgplot and PLplot) for its 2D plotting features. Its 3D plotting and graphics uses OpenGL for performance and portability. PDL has three main plotting modules: =over 5 =item L B: Plotting 2D functions and data sets. This is an interface to the venerable PGPLOT library. PGPLOT has been widely used in the academic and scientific communities for many years. In part because of its age, PGPLOT has some limitations compared to newer packages such as PLplot (e.g. no RGB graphics). But it has many features that still make it popular in the scientific community. =item L B: Plotting 2D functions as well as 2D and 3D data sets. This is an interface to the PLplot plotting library. PLplot is a modern, open source library for making scientific plots. It supports plots of both 2D and 3D data sets. PLplot is best supported for unix/linux/macosx platforms. It has an active developers community and support for win32 platforms is improving. =item L B: Plotting 3D functions. The native PDL 3D graphics library using OpenGL as a backend for 3D plots and data visualization. With OpenGL, it is easy to manipulate the resulting 3D objects with the mouse in real time. =back =head2 Writing GUIs Through Perl, PDL has access to all the major toolkits for creating a cross platform graphical user interface. One popular option is wxPerl (L). These are the Perl bindings for wxWidgets, a powerful GUI toolkit for writing cross-platform applications. wxWidgets is designed to make your application look and feel like a native application in every platform. For example, the Perl IDE B is written with wxPerl. =head2 Simulink Simulink is a graphical dynamical system modeler and simulator. It can be purchased separately as an add-on to MATLAB. PDL and Perl do not have a direct equivalent to MATLAB's Simulink. If this feature is important to you, then take a look at B: L Scilab is another numerical analysis software. Like PDL, it is free and open source. It doesn't have PDL's unique features, but it is very similar to MATLAB. Scilab comes with B (previously Scicos), a graphical system modeler and simulator similar to Simulink. =head1 COMPARISON: REPEATED COPY OF MATRIX In MATLAB, the C function works like so: > A = reshape(0:5, 3, 2)' # similar to PDL::sequence(3, 2) ans = 0 1 2 3 4 5 > repmat(A, 2, 3) # double rows, triple columns ans = 0 1 2 0 1 2 0 1 2 3 4 5 3 4 5 3 4 5 0 1 2 0 1 2 0 1 2 3 4 5 3 4 5 3 4 5 This works (at least in Octave) at least up to 3 dimensions. The PDL analog: sub repmat { my $f=shift; my @n=@_; #number of repetitions along dimension my $sl = join ',', map ":,*$_", @n; # insert right-size dummy after each real my $r = $f->slice($sl); #result $r = $r->clump($_, $_+1) for 0..$#n; $r; } > p $x = sequence(3,2) [ [0 1 2] [3 4 5] ] > p repmat($x, 3, 2) # triple columns, double rows [ [0 1 2 0 1 2 0 1 2] [3 4 5 3 4 5 3 4 5] [0 1 2 0 1 2 0 1 2] [3 4 5 3 4 5 3 4 5] ] =head1 COMPARISON: FLOYD-WARSHALL ALGORITHM In L, an apparently-simple but difficult problem is the "shortest path" problem, of finding the shortest path between any two nodes. A famous solution to this, albeit expensive (it is C where C is the number of vertices) is the Floyd-Warshall algorithm, which iterates through all the possible paths. Both the MATLAB solution and the PDL solution use vectorisation, so hopefully this is a useful comparison. The MATLAB version started with the code in L, but modified as that code produces an incorrect path matrix. Sample data (reflected on both the Wikipedia page, and the Rosetta Code website) for the weighted-edges matrix is, in PDL format: my $we = pdl q[ [Inf Inf -2 Inf] [ 4 Inf 3 Inf] [Inf Inf Inf 2] [Inf -1 Inf Inf] ]; and in MATLAB format: A = [0 Inf -2 Inf; 4 0 3 Inf; Inf Inf 0 2; Inf -1 Inf 0] =head2 PDL version To solve for only distances without capturing the shortest actual paths: $we .= $we->hclip($we->mslice('X', $_) + $we->mslice($_, 'X')) for 0..($we->dim(0)-1); This loops over each possible intermediate point (C in the other literature), setting it to C<$_> (a Perl idiom). It uses L for vectorised calculation of the distance between the intermediate point's predecessors and successors. Those are the two components of the addition expression, using "slices" alluded to above. The C<.=> is the PDL syntax for updating an ndarray. To capture the shortest-path "next vertex" matrix as well: use PDL::Lite; my $d = $we->copy->inplace; $d->diagonal(0, 1) .= 0; my $suc = $we->copy->inplace; my $adjacent_coords = PDL::whichND($we->isfinite); $suc->indexND($adjacent_coords) .= $adjacent_coords->slice(0)->flat; $suc->diagonal(0, 1) .= PDL::Basic::sequence($d->dim(0)); for (my $k = $d->dim(0)-1; $k >= 0; $k--) { my $d_copy = $d->copy; $d .= $d->hclip($d->mslice('X', $k) + $d->mslice($k, 'X')); my $coords = PDL::whichND($d < $d_copy); my $from_coords = $coords->copy->inplace; $from_coords->slice(0) .= $k; $suc->indexND($coords) .= $suc->indexND($from_coords); } The C and C expressions show how to update data via a query syntax. =head2 MATLAB version Path-lengths only: function D = FloydWarshall(D) for k = 1:length(D) D = min(D,D(:,k) + D(k,:)); end end The path vertices-capturing as well: function [D,P] = FloydWarshall(D) P = D; n = length(D); coords = find(isfinite(P)); P(coords) = floor((coords-1) / n)+1; % the col in 1-based for v = 1:n; P(v, v) = v; end for k = 1:n prevD = D; D = min(D,D(:,k) + D(k,:)); coords = find(D =head1 ACKNOWLEDGEMENTS I'd like to thank David Mertens, Chris Marshall and Sigrid Carrera for their immense help reviewing earlier drafts of this guide. Without their hours of work, this document would not be remotely as useful to MATLAB users as it is today. PDL-2.074/Basic/Pod/Tips.pod0000644000175000017500000000667014146003631015270 0ustar osboxesosboxes=head1 NAME PDL::Tips - Small tidbits of useful arcana. Programming tidbits and such. =head1 SYNOPSIS use PDL; # Whatever happens here. =head1 DESCRIPTION This page documents useful idioms, helpful hints and tips for using Perl Data Language v2.0. =head2 Help Use C within I or I or use the C program from the command line for access to the PerlDL documentation. HTML versions of the pages should also be present, in the F directory of the PDL distribution. To find this directory, try the following pdl> foreach ( map{"$_/PDL/HtmlDocs"}@INC ) { p "$_\n" if -d $_ } =head2 Indexing idioms The following code normalizes a bunch of vectors in $x. This works regardless of the dimensionality of $x. $x /= $x->sumover->dummy(0); =head2 What is actually happening? If you want to see what the code is actually doing, try the command PDL::Core::set_debugging(1); somewhere. This spews out a huge amount of debug info for PDL into STDOUT. Plans for the future include making it possible to redirect the output, and also making it possible to select messages with more precision. Many of the messages come from C and you can look at the source to see what is going on. If you have any extra time to work on these mechanisms, inform the pdl-porters mailing list. =head2 Memory savings If you are running recursively something that selects certain indices of a large ndarray, like while(1) { $inds = where($x>0); $x = $x->index($inds); $y = $y->index($inds); func($y,$x); } If you are not writing to $y, it saves a lot of memory to change this to $y = $y->index($inds)->sever; The new method C is a causes the write-back relation to be forgotten. It is like copy except it changes the original ndarray and returns it). Of course, the probably best way to do the above is $inds = xvals ($x->long); while(1) { $inds0 = where($x>0); $inds1 = $inds->index($inds)->sever; $x = $a0->index($inds1); $y = $y->index($inds1)->sever; func($y,$x); } which doesn't save all the temporary instances of $x in memory. See C in the Demos subdirectory of the PerlDL distribution for an example. =head2 PP speed If you really want to write speedy PP code, the first thing you need to do is to make sure that your C compiler is allowed to do the necessary optimizations. What this means is that you have to allow as many variables as possible to go into registers: loop(a) %{ $a() += $COMP(foo_member) * $b() %} expands to for(i=0; i<10000; i++) { a[i] += __privtrans->foo_member * b[i]; } is about the worst you can do, since your C compiler is not allowed to assume that C doesn't clobber C which completely inhibits vectorization. Instead, do float foo = $COMP(foo_member); loop(a) %{ $a() += foo * $b(); %} This is not a restriction caused by PP but by ANSI C semantics. Of course, we could copy the struct into local variables and back but that could cause very strange things sometimes. There are many other issues on organizing loops. We are currently planning to make PP able to do fixed-width things as well as physical ndarrays (where looping over the first dimensions would be cheaper as there are less distinct increments, which might make a difference on machines with a small number of registers). =head1 AUTHOR Copyright (C) Tuomas J. Lukka 1997. All rights reserved. Duplication in the same form and printing a copy for yourself allowed. PDL-2.074/Basic/Pod/Course.pod0000644000175000017500000003554314160015533015612 0ustar osboxesosboxes=head1 NAME PDL::Course - A journey through PDL's documentation, from beginner to advanced. =head1 AUTHOR, DATE This is written by David Mertens with edits by Daniel Carrera. =head1 Preface PDL's documentation is extensive. Some sections cover deep core magic while others cover more usual topics like IO and numerical computation. How are these related? Where should you begin? This document is an attempt to pull all the key PDL documentation together in a coherent study course, starting from the beginner level, up to the expert. I've broken down everything by level of expertise, and within expertise I've covered documentation, library, and workflow modules. The documentation modules are useful for what they tell you; the library modules are useful for the functions that they define for you; the workflow modules are useful for the way that they allow you to get your work done in new and different ways. =head1 Introductory If you are new to PDL, these documentation modules will get you started down the right path for using PDL. =head2 Documentation Modules that tell you how to start using PDL. Many of these are library modules technically, but they are included when you C, so I've included them for their documentation. After the first three, most of the docs listed below are rather dry. Perhaps they would be better summarized by tables or better synopses. You should at least scan through them to familiarize yourself with the basic capabilities of PDL. =over =item * L, L A couple of brief introductions to PDL. The second one is a bit more hands-on. If you are new to PDL, you should start with these. =item * L Covers basic ndarray-creation routines like C, C, and C to name a random few. Also covers C and C. =item * L Explains a large collection of built-in functions which, given an N-dimension ndarray, will create an ndarray with N-1 dimensions. =item * L PDL came of age right around the turn of the millennium and NiceSlice came on the scene slightly after that. Some of the docs still haven't caught up. NiceSlice is the 'modern' way to slice and dice your ndarrays. Read the Synopsis, then scroll down to The New Slicing Syntax. After you've read to the bottom, return to and read the stuff at the top. =item * L Defines a whole slew of useful built-in functions. These are the sorts of things that beginners are likely to write to the list and say, "How do I do xxx?" You would be well on your way to learning the ropes after you've gotten through this document. =item * Selections from L Like PDL::Primitive, defines a large set of useful functions. Unfortunately, some of the functions are quite esoteric, but are mixed in with the rest of the simple and easy ones. Skim the whole document, skipping over the complicated functions for now. I would point out in particular the function C. =back =head2 Workflow =over =item * The L or L Shell The Perldl Shell is a REPL (Read-Evaluate-Print-Loop, in other words, a prompt or shell) that allows you to work with PDL (or any Perl, for that matter) in 'real time', loading data from files, plotting, manipulating... Anything you can do in a script, you can do in the PDL Shell, with instant feedback! =back =head2 Libraries =over =item * L The main workhorse module. You'll include this in nearly every PDL program you write. =back =head1 Normal Usage The sorts of modules that you'll likely use on a normal basis in scripts or from within the perldl shell. Some of these modules you may never use, but you should still be aware that they exist, just in case you need their functionality. =head2 Documentation =over =item * L In addition to explaining the original slicing and dicing functions - for which you can usually use L - this also covers many dimension-handling functions such as C, C, and C. This also thoroughly documents the C function, which can be very powerful, and covers a number of internal functions, which can probably be skipped. =item * L This covers a lot of the deeper conceptual ground that you'll need to grasp to really use PDL to its full potential. It gets more complex as you go along, so don't be troubled if you find yourself loosing interest half way through. However, reading this document all the way through will bring you much closer to PDL enlightenment. =item * L PDL has quite a few IO modules, most of which are discussed in this summary module. =item * L A collection of some of Tuomas's ideas for making good use of PDL. =item * L Explains what bad values are and how and why they are implemented. =item * Selections from L Although writing PDL::PP code is considered an Advanced topic, and is covered in the next section, you should be aware that it is possible (and surprisingly simple) to write PDL-aware code. You needn't read the whole thing at this point, but to get some feel for how it works, you should read everything up through the first example. A copy of this documentation is contained in L. =item * L Explains how to subclass an ndarray object. =item * L This was discussed in the Preface. It is an automatically generated file that lists all of the PDL modules on your computer. There are many modules that may be on your machine but which are not documented here, such as bindings to the FFTW library, or GSL. Give it a read! =back =head2 Libraries =over =item * L PDL's own Fast Fourier Transform. If you have FFTW, then you should probably make use of it; this is PDL's internal implementation and should always be available. =item * GSL PDL does not have bindings for every sub-library in the GNU Scientific Library, but it has quite a few. If you have GSL installed on your machine then chances are decent that your PDL has the GSL bindings. For a full list of the GSL bindings, check L. =item * L A somewhat uniform interface to the different interpolation modules in PDL. =item * L Includes some basic bad-value functionality, including functions to query if an ndarray has bad values (C) and functions to set certain elements as bad (C and C). Among other places, bad values are used in L's xyplot to make a gap in a line plot. =item * L A cool module that allows you to tie a Perl array to a collection of files on your disk, which will be loaded into and out of memory as ndarrays. If you find yourself writing scripts to process many data files, especially if that data processing is not necessarily in sequential order, you should consider using PDL::DiskCache. =item * L A PDL subclass that allows you to store and manipulate collections of fixed-length character strings using PDL. =item * L A whole collection of methods for manipulating images whose image data are stored in an ndarray. These include methods for convolutions (smoothing), polygon fills, scaling, rotation, and warping, among others. =item * L Contains a few functions that are conceptually related to image processing, but which can be defined for higher-dimensional data. For examples this module defines high-dimensional convolution and interpolation, among others. =item * L Defines some useful functions for working with RBG image data. It's not very feature-full, but it may have something you need, and if not, you can always add more! =item * L Creates the transform class, which allows you to create various coordinate transforms. For example, if you data is a collection of Cartesian coordinates, you could create a transform object to convert them to Spherical-Polar coordinates (although many such standard coordinate transformations are predefined for you, in this case it's called C). =item * L This package states that it "implements the commonly used simplex optimization algorithm." I'm going to assume that if you need this algorithm then you already know what it is. =item * L A collection of fairly standard math functions, like the inverse trigonometric functions, hyperbolic functions and their inverses, and others. This module is included in the standard call to C, but not in the Lite versions. =item * L Provides a few functions that use the standard mathematical Matrix notation of row-column indexing rather than the PDL-standard column-row. It appears that this module has not been heavily tested with other modules, so although it should work with other modules, don't be surprised if something breaks when you use it (and feel free to offer any fixes that you may develop). =item * L Provides many standard matrix operations for ndarrays, such as computing eigenvalues, inverting square matrices, LU-decomposition, and solving a system of linear equations. Though it is not built on L, it should generally work with that module. Also, the methods provided by this module do not depend on external libraries such as Slatec or GSL. =item * L Implements an interface to all the functions that return ndarrays with one less dimension (for example, C), such that they can be called by supplying their name, as a string. =back =head2 Workflow =over =item * L Enables Matlab-style autoloading. When you call an unknown function, instead of complaining and croaking, PDL will go hunt around in the directories you specify in search of a like-named file. Particularly useful when used with the Perldl Shell. =item * L Declares the C function, which can be handy for debugging your PDL scripts and/or perldl shell commands. =item * L Suppose you define a powerful, versatile function. Chances are good that you'll accept the arguments in the form of a hash or hashref. Now you face the problem of processing that hashref. L assists you in writing code to process those options. (You'd think Perl would have tons of these sorts of modules lying around, but I couldn't find any.) Note this module does not depend on PDL for its usage or installation. =item * L Ever fired-up the perldl shell just to look up the help for a particular function? You can use C instead. This shell script extracts information from the help index without needing to start the perldl shell. =back =head1 Advanced Usage The sorts of modules and documentation that you'll use if you write modules that use PDL, or if you work on PDL maintenance. These modules can be difficult to use, but enable you to tackle some of your harder problems. =over =item * L, L Lite-weight replacements for C, from the standpoint of namespace pollution and load time. =item * L This was mentioned earlier. Before you begin reading about L (next), you should remind yourself about how to use this. L will help you experiment with L without having to go through the trouble of building a module and constructing makefiles (but see L for help on that). =item * L The PDL Pre-Processor, which vastly simplifies making you C or Fortran code play with Perl and ndarrays. Most of PDL's basic functionality is written using PDL::PP, so if you're thinking about how you might integrate some numerical library written in C, look no further. =item * L A script that automates the creation of modules that use L, which should make your life as a module author a bit simpler. =item * L Allows you to call functions using external shared libraries. This is an alternative to using L. The major difference between PDL::PP and PDL::CallExt is that the former will handle threading over implicit thread dimensions for you, whereas PDL::CallExt simply calls an external function. PDL::PP is generally the recommended way to interface your code with PDL, but it wouldn't be Perl if there wasn't another way to do it. =item * PDL::Config Defines the C<%PDL::Config> hash, which has lots of useful information pertinent to your PDL build. =item * L Explanation of the PDL documentation conventions, and an interface to the PDL Documentation parser. Following these guidelines when writing documentation for PDL functions will ensure that your wonderful documentation is accessible from the perldl shell and from calls to C. (Did you notice that C used your documentation? Time to reread L...) =item * L A simple replacement for the standard L module. The only major difference is that the default imported modules are those marked ':Func'. =item * L Defines some useful functions for getting an ndarray's type, as well as getting information about that type. =back =head1 Expert Usage =over =item * L Provides some decently useful functions that are pretty much only needed by the PDL Porters. =item * L Explains how to make an ndarray I, from Perl or your C source code, using the PDL API. =item * L Explains the nitty-gritty of the PDL data structures. After reading this (a few times :), you should be able to create an ndarray completely from scratch (i.e. without using the PDL API). Put a little differently, if you want to understand how PDL::PP works, you'll need to read this. =back =begin questionable =head1 Other Documents These documents are part of the PDL distribution but don't seem to fit anywhere above. =over =item * L Explains how things changed from PDL 1.x to PDL 2.x =item * L Supposed to be a uniform interface to plotting 2D graphics. =item * L Covers data flow, a cool feature to be sure, but from what I can tell it is not currently supported. =item * L PDL started before Perl 5.6, which introduce subs that could return lvalues. I'm pretty sure that this module has been rolled into the core and is no longer necessary. =item * L Defines a few PDL::PP tests. This code should be moved into the testing suite, but hasn't been... =item * L Defines the standard Perl-overloadable operators, like + and .=, for example. Since pretty much all of these operators and functions are discussed elsewhere, there's usually no need to read this documentation or use this module. =item * L An apparently broken module to help generate and work with Gaussian distributions. =back =end questionable =head1 COPYRIGHT Copyright 2010 David Mertens (dcmertens.perl@gmail.com). You can distribute and/or modify this document under the same terms as the current Perl license. See: http://dev.perl.org/licenses/ PDL-2.074/Basic/Pod/Dataflow.pod0000644000175000017500000001636114146003631016110 0ustar osboxesosboxes=head1 NAME PDL::Dataflow -- description of the dataflow philosophy =head1 SYNOPSIS pdl> $x = zeroes(10); pdl> $y = $x->slice("2:4:2"); pdl> $y ++; pdl> print $x; [0 0 1 0 1 0 0 0 0 0] =head1 WARNING Dataflow is very experimental. Many features of it are disabled for 2.0, particularly families for one-directional dataflow. If you wish to use one-directional dataflow for something, please contact the author first and we'll work out how to make it functional again. Two-directional dataflow (which implements ->slice() etc.) is fully functional, however. Just about any function which returns some subset of the values in some ndarray will make a binding so that $x = some ndarray $y = $x->slice("some parts"); $y->set(3,3,10); also changes the corresponding element in $x. $y has become effectively a window to some sub-elements of $x. You can also define your own routines that do different types of subsets. If you don't want $y to be a window to $x, you must do $y = $x->slice("some parts")->copy; The copying turns off all dataflow between the two ndarrays. The difficulties with one-directional dataflow are related to sequences like $y = $x + 1; $y ++; where there are several possible outcomes and the semantics get a little murky. =head1 DESCRIPTION Dataflow is new to PDL2.0. The basic philosophy behind dataflow is that > $x = pdl 2,3,4; > $y = $x * 2; > print $y [2 3 4] > $x->set(0,5); > print $y; [10 3 4] should work. It doesn't. It was considered that doing this might be too confusing for novices and occasional users of the language. Therefore, you need to explicitly turn on dataflow, so > $x = pdl 2,3,4; > $x->doflow(); > $y = $x * 2; ... produces the unexpected result. The rest of this documents explains various features and details of the dataflow implementation. =head1 Lazy evaluation When you calculate something like the above > $x = pdl 2,3,4; > $x->doflow(); > $y = $x * 2; nothing will have been calculated at this point. Even the memory for the contents of $y has not been allocated. Only the command > print $y will actually cause $y to be calculated. This is important to bear in mind when doing performance measurements and benchmarks as well as when tracking errors. There is an explanation for this behaviour: it may save cycles but more importantly, imagine the following: > $x = pdl 2,3,4; > $y = pdl 5,6,7; > $c = $x + $y; ... > $x->resize(4); > $y->resize(4); > print $c; Now, if $c were evaluated between the two resizes, an error condition of incompatible sizes would occur. What happens in the current version is that resizing $x raises a flag in $c: "PDL_PARENTDIMSCHANGED" and $y just raises the same flag again. When $c is next evaluated, the flags are checked and it is found that a recalculation is needed. Of course, lazy evaluation can sometimes make debugging more painful because errors may occur somewhere where you'd not expect them. A better stack trace for errors is in the works for PDL, probably so that you can toggle a switch $PDL::traceevals and get a good trace of where the error actually was. =head1 Families This is one of the more intricate concepts of one-directional dataflow. Consider the following code ($x and $y are pdls that have dataflow enabled): $w = $u + $v; $y = $w + 1; $x = $w->diagonal(); $x++; $z = $w + 1; What should $y and $z contain now? What about when $u is changed and a recalculation is triggered. In order to make dataflow work like you'd expect, a rather strange concept must be introduced: families. Let us make a diagram: u v \ / w /| / | y x This is what PDL actually has in memory after the first three lines. When $x is changed, we want $w to change but we don't want $y to change because it already is on the graph. It may not be clear now why you don't want it to change but if there were 40 lines of code between the 2nd and 4th lines, you would. So we need to make a copy of $w and $x: u v \ / w' . . . w /| |\ / | | \ y x' . . . x z Notice that we primed the original w and x, because they do not correspond to the objects in $w and $x any more. Also, notice the dotted lines between the two objects: when $u is changed and this diagram is re-evaluated, $w really does get the value of w' with the diagonal incremented. To generalize on the above, whenever an ndarray is mutated i.e. when its actual *value* is forcibly changed (not just the reference): $x = $x + 1 would produce a completely different result ($w and $x would not be bound any more whereas $x .= $x + 1 would yield the same as $x++), a "family" consisting of all other ndarrays joined to the mutated ndarray by a two-way transformation is created and all those are copied. All slices or transformations that simply select a subset of the original pdl are two-way. Matrix inverse should be. No arithmetic operators are. =head1 Sources What you were told in the previous section is not quite true: the behaviour described is not *always* what you want. Sometimes you would probably like to have a data "source": $x = pdl 2,3,4; $y = pdl 5,6,7; $c = $x + $y; line($c); Now, if you know that $x is going to change and that you want its children to change with it, you can declare it into a data source (XXX unimplemented in current version): $x->datasource(1); After this, $x++ or $x .= something will not create a new family but will alter $x and cut its relation with its previous parents. All its children will follow its current value. So if $c in the previous section had been declared as a source, $e and $f would remain equal. =head1 Binding A dataflow mechanism would not be very useful without the ability to bind events onto changed data. Therefore, we provide such a mechanism: > $x = pdl 2,3,4 > $y = $x + 1; > $c = $y * 2; > $c->bind( sub { print "A now: $x, C now: $c\n" } ) > PDL::dowhenidle(); A now: [2,3,4], C now: [6 8 10] > $x->set(0,1); > $x->set(1,1); > PDL::dowhenidle(); A now: [1,1,4], C now: [4 4 10] Notice how the callbacks only get called during PDL::dowhenidle. An easy way to interface this to Perl event loop mechanisms (such as Tk) is being planned. There are many kinds of uses for this feature: self-updating graphs, for instance. Blah blah blah XXX more explanation =head1 Limitations Dataflow as such is a fairly limited addition on top of Perl. To get a more refined addition, the internals of Perl need to be hacked a little. A true implementation would enable flow of everything, including =over 12 =item data =item data size =item datatype =item operations =back At the moment we only have the first two (hey, 50% in a couple of months is not bad ;) but even this is useful by itself. However, especially the last one is desirable since it would add the possibility of flowing closures from place to place and would make many things more flexible. To get the rest working, the internals of dataflow probably need to be changed to be a more general framework. Additionally, it would be nice to be able to flow data in time, lucid-like (so you could easily define all kinds of signal processing things). =head1 AUTHOR Copyright(C) 1997 Tuomas J. Lukka (lukka@fas.harvard.edu). Redistribution in the same form is allowed provided that the copyright notice stays intact but reprinting requires a permission from the author. PDL-2.074/Basic/Pod/Makefile.PL0000644000175000017500000000157314164221257015622 0ustar osboxesosboxesuse strict; use warnings; use ExtUtils::MakeMaker; my @pods = map { $_=~s/.pod//; $_ } grep { ! m/Index.pod/ } glob("*.pod"); # do we want to create PP-Inline? eval 'require Pod::Select'; if (!$@) { push @pods, 'PP-Inline' unless grep {/PP-Inline/} @pods; } my @man1 = map { $_.".pod", '$(INST_MAN1DIR)/PDL::' . $_ . '.$(MAN1EXT)' } @pods; my @pms = map { $_.".pod", '$(INST_LIBDIR)/' . $_ .".pod"} @pods; undef &MY::postamble; # suppress warning *MY::postamble = sub { my $text = ''; eval 'require Pod::Select'; if (!$@) { $text .= << "EOPS" ; PP-Inline.pod: ../Gen/Inline/Pdlpp.pm \t\$(PERLRUN) -MPod::Select -e "podselect('../Gen/Inline/Pdlpp.pm');" > PP-Inline.pod EOPS } $text; }; WriteMakefile( 'NAME' => 'PDL::pod', 'MAN1PODS' => { @man1 }, 'MAN3PODS' => { }, 'PM' => { @pms }, 'clean' => {FILES => "PP-Inline.pod"}, NO_MYMETA => 1, ); PDL-2.074/Basic/Pod/Delta.pod0000644000175000017500000000234014146003631015370 0ustar osboxesosboxes=head1 NAME PDL::Delta - PDL changes between V1.0 and V2.0 =head1 DESCRIPTION This file is an attempt to list the major user-visible changes between PDL versions 1.0 and 2.0. =head1 Core Changes =head2 ndarrays are not hashes any more: $x = zeroes 10,10; $$x{FOO} = "bar" doesn't work. They are currently scalar references (to opaque C structures in finer terms) because of speed as well as syntactic issues. If you want to have a hash, use $x->hdr() which returns a reference to an anonymous hash. Also, subclassing works if you store an ndarray in the hash member ``PDL''. There are also many core enhancements to support Dataflow and Slicing tricks, but these do not introduce any incompatibilities. =head2 Incompatible Changes vs 1.11 =over 4 =item rgrep Order of the arguments has changed. =item copy method No longer copies the header. This may not be a misfeature. =back =head1 Documentation Changes Many of the base and library pods were updated. =head1 SEE ALSO The F file for exhaustive details on what changed. The F file for how to build PDL. The F file for general stuff. =head1 HISTORY pdldelta was inspired by I man page in the Perl 5.004 distribution. PDL-2.074/Basic/Lvalue.pm0000644000175000017500000000414214165550222014705 0ustar osboxesosboxes=head1 NAME PDL::Lvalue - declare PDL lvalue subs =head1 DESCRIPTION Declares a subset of PDL functions so that they can be used as lvalue subs. In particular, this allows simpler constructs such as $x->slice(',(0)') .= 1; instead of the clumsy (my $tmp = $x->slice(',(0)')) .= 1; This will only work if your perl supports lvalue subroutines (i.e. versions >= v5.6.0). Note that lvalue subroutines are currently regarded experimental. =head1 SYNOPSIS use PDL::Lvalue; # automatically done with all PDL loaders =head1 FUNCTIONS =cut package PDL::Lvalue; use strict; use warnings; # list of functions that can be used as lvalue subs # extend as necessary my @funcs = qw/ clump diagonal dice dice_axis dummy flat index index2d indexND indexNDb mslice mv nslice_if_pdl polyfillv px range rangeb reorder reshape sever slice where whereND xchg /; my $prots = join "\n", map {"use attributes 'PDL', \\&PDL::$_, 'lvalue';"} @funcs; =head2 subs =for ref test if routine is a known PDL lvalue sub =for example print "slice is an lvalue sub" if PDL::Lvalue->subs('slice'); returns the list of PDL lvalue subs if no routine name is given, e.g. @lvfuncs = PDL::Lvalue->subs; It can be used in scalar context to find out if your PDL has lvalue subs: print 'has lvalue subs' if PDL::Lvalue->subs; =cut sub subs { my ($type,$func) = @_; if (defined $func) { $func =~ s/^.*:://; return ($^V and $^V >= 5.006007) && scalar grep {$_ eq $func} @funcs; } else { return ($^V and $^V >= 5.006007) ? @funcs : (); } } # print "defining lvalue subs:\n$prots\n"; eval << "EOV" if ($^V and $^V >= 5.006007); { package PDL; no warnings qw(misc); $prots } EOV =head1 AUTHOR Copyright (C) 2001 Christian Soeller (c.soeller@auckland.ac.nz). 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 1; PDL-2.074/Basic/Makefile.PL0000644000175000017500000000233614146003631015070 0ustar osboxesosboxesuse strict; use warnings; use ExtUtils::MakeMaker; my $defstartup = 'default.perldlrc'; if ($^O =~ /win32/i) { $defstartup = 'default.pdl'; system("copy default.perldlrc $defstartup"); } my @pm_names = qw ( PDL.pm Lite.pm LiteF.pm AutoLoader.pm Options.pm Matrix.pm Reduce.pm Lvalue.pm Constants.pm); my %pm = map { my $h = '$(INST_LIBDIR)/'; $h .= 'PDL/' if $_ !~ /PDL.pm$/; ( $_, $h . $_ ); } ( @pm_names, $defstartup ); my %man3pods = map { my $h = '$(INST_MAN3DIR)/'; $h .= 'PDL::' if $_ !~ /PDL.pm$/; ( $_, $h . substr($_,0,length($_)-3) . '.$(MAN3EXT)' ); } @pm_names; WriteMakefile( 'NAME' => 'PDL', 'VERSION_FROM' => 'PDL.pm', 'PM' => \%pm, 'MAN3PODS' => \%man3pods, 'DIR' => ['Pod','Gen','SourceFilter','Core','Bad','Ops','Ufunc', 'Primitive','Slices','Math','MatrixOps','Complex'], NO_MYMETA => 1, ); # modify clean method not to delete files named 'core' # (required for MacOSX, where "Core" and "core" are # indistinguishable) package MY; # so that "SUPER" works right sub clean { my $inherited = shift->SUPER::clean(@_); $inherited =~ s/\s+core\s/ /; # print STDERR "processed list :\n$inherited\n"; $inherited; } PDL-2.074/Basic/MatrixOps/0000755000175000017500000000000014200406301015030 5ustar osboxesosboxesPDL-2.074/Basic/MatrixOps/sslib.h0000644000175000017500000000167714160714722016346 0ustar osboxesosboxes/* * ssl.h - Small Scientific Library. * * (C) Copyright 2001 by NetGroup A/S. All rights reserved. * * $Log$ * Revision 1.1 2006/06/20 15:57:22 djburke * Hopefully a saner way to build Basic/MatrixOps * * Revision 1.1 2005/01/08 09:22:57 zowie * Added non-symmetric matrices to eigens; updated version to 2.4.2cvs. * * Revision 1.2 2001/07/11 08:06:01 kneth * Added SWAP macro * * Revision 1.1.1.1 2001/07/06 13:39:35 kneth * Initial import of code. * * */ #ifndef SSL_H_ #define SSL_H_ #ifndef PI # define PI 3.141592653589793238462643 #endif /***** A boolean type *****/ typedef enum {false=0, true=1} bool; /***** Pratical macros *****/ #define min(x, y) ((x)>(y))?(y):(x) #define max(x, y) ((x)>(y))?(x):(y) #define SWAP(x, y) { double tmp; tmp=x; x=y; y=tmp; } /***** General functions *****/ extern void SSLerror(char *); extern double Sqr(double); extern double Cube(double); #endif /* SSL_H_ */ PDL-2.074/Basic/MatrixOps/matrix.c0000644000175000017500000003155614160714722016530 0ustar osboxesosboxes/* * matrix.c - misc. routines for manipulating matrices and vectors. * * (C) Copyright 2001 by NetGroup A/S. All rights reserved. * * $Log$ * Revision 1.1 2006/06/20 15:57:22 djburke * Hopefully a saner way to build Basic/MatrixOps * * Revision 1.1 2005/01/08 09:22:57 zowie * Added non-symmetric matrices to eigens; updated version to 2.4.2cvs. * * Revision 1.1.1.1 2001/07/06 13:39:35 kneth * Initial import of code. * * * * The matrices and vectors are indexed in C-style, i.e. from 0 to * N-1. A matrix is assumed to be declared as double **, and it is * allocated by MatrixAlloc. * * * References: * [1] Numerical Recipes in C, 2nd edition, * W.H. Press, S.A. Teukolsky, W.T. Vitterling, and B.P. Flannery, * Cambridge University Press, 1992. * [2] Numerical Analysis, * D. Kincaid and W. Cheney, * Brooks/Cole Publishing Company, 1991. * [3] The C Programming Language, 2nd edition, * B.W. Kernighan and D.M. Ritchie, * Prentice Hall, 1988. * [4] Advanced Engineering Mathematics, 6th edition, * E. Kreyszig, * Wiley and Sons, 1988. * */ #include #include #include #ifndef TINY # define TINY 1.0e-18 #endif #include "sslib.h" #include "matrix.h" /* * MatrixAlloc allocates storage for a square matrix with dimension * n*n. An error message is printed, if it was impossible to allocate * the neccesary space, [3]. * */ double **MatrixAlloc(const int n) { double **matrix; int i; matrix=(double **)calloc(n, sizeof(double *)); if (matrix==NULL) SSLerror("No memory available in routine MatrixAlloc"); else for(i=0; i=k so ... */ not_finished=1; while (not_finished) { j++; temp=fabs(a[p[j]][k]/s[p[j]]); for(i=k; i=(fabs(a[p[i]][k])/s[p[i]])) not_finished=0; /* end loop */ } /* while */ i_swap=p[k]; p[k]=p[j]; p[j]=i_swap; temp=1.0/a[p[k]][k]; for(i=(k+1); i=0; i--) { /* back subst */ sum=b[p[i]]; for(j=(i+1); j=eps)); VectorFree(n, x_old); } /* GaussSeidel */ /* * Jacobi is an iterative equation solver, [2, pp. 185-189]. The algorithm * can be optimised a bit, which is done in this implementation. The method * is suitable for parallel computers. * * The arguments are the same as in GaussSeidel. * */ void Jacobi(const int n, double **a, double *b, double *x, double eps, int max_iter) { double d; /* temporary real */ int i, j, iter; /* counters */ double **a_new; /* a is altered */ double *b_new; /* b is altered */ double *u; /* new solution */ double norm; /* L1-norm */ a_new=MatrixAlloc(3); b_new=VectorAlloc(3); u=VectorAlloc(3); for(i=0; i=eps)); MatrixFree(3, a_new); VectorFree(3, b_new); VectorFree(3, u); } /* Jacobi */ /* * DotProd computes the dot product between two vectors. They are assumed to * be of the same dimension. * */ double DotProd(const int n, double *u, double *v) { int i; /* counter */ double sum=0.0; /* temporary real */ for(i=0; i */ for(i=0; i int simq( A, B, X, n, flag, IPS ) double A[], B[], X[]; int n, flag; int IPS[]; { int i, j, ij, ip, ipj, ipk, ipn; int idxpiv, iback; int k, kp, kp1, kpj, kpk, kpn; int nip, nkp, nm1; double em, q, rownrm, big, size, pivot, sum; double fabs(); if( flag < 0 ) goto solve; /* Initialize IPS and X */ ij=0; for( i=0; i big ) { big = size; idxpiv = i; } } if( big == 0.0 ) { puts( "SIMQ BIG=0" ); return(2); } if( idxpiv != k ) { j = IPS[k]; IPS[k] = IPS[idxpiv]; IPS[idxpiv] = j; } kp = IPS[k]; kpk = n*kp + k; pivot = A[kpk]; kp1 = k+1; for( i=kp1; i /* * SSLerror is an error handling routine. * */ void SSLerror(char *msg) { fprintf(stderr, "Fatal error in SSL.\n%s\n", msg); } /* SSLerror */ /* * Sqr and Cube is two simple power-raising routines. * */ double Sqr(double x) { return x*x; } /* Sqr */ double Cube(double x) { return x*x*x; } /* Cube */ PDL-2.074/Basic/MatrixOps/NOTES0000644000175000017500000000147713265417442015676 0ustar osboxesosboxes20-Jun-2006 Moved the "Small Science Libraty" code from ssl/ into this directory to avoid having to deal with OS/system-specific make files. Changed nan("") to atof("NaN") on Solaris machines (done in a quick way; should be handled in Basic/Core/ or top-level Makefile.PL). --Doug Burke 7-Jan-2004 Added a subset of the "Small Science Library" available from geisshirt.dk, to handle eigens work. The former 'eigens.c' is now relegated to 'eigens_sym'. 19-Nov-2002 This is intended to be a useful repository of self-contained linear algebra routines. Some of the stuff has been stolen from ../Math, which in turn used the Cephes maths library sources. Some of it was ported to PDL from the algorithms in _Numerical_Recipes_, but the original C code should probably be used if the copyrights allow it. --Craig DeForest PDL-2.074/Basic/MatrixOps/eigen.c0000644000175000017500000004552114160714722016310 0ustar osboxesosboxes/* * eigen.c - calculation of eigen values and vectors. * * (C) Copyright 2001 by NetGroup A/S. All rights reserved. * * $Log$ * Revision 1.1 2006/06/20 15:57:22 djburke * Hopefully a saner way to build Basic/MatrixOps * * Revision 1.1 2005/01/08 09:22:57 zowie * Added non-symmetric matrices to eigens; updated version to 2.4.2cvs. * * Revision 1.1.1.1 2001/07/06 13:39:35 kneth * Initial import of code. * * * Eigen is a library for computing eigenvalues and eigenvectors of general * matrices. There is only one routine exported, namely Eigen. * * The meaning of the arguments to Eigen is: * 1. The dimension of the general matrix (n). * 2. A general matrix (A). * 3. The maximal number of iterations. * 4. The precision. * 5. A vector with the eigenvalues. * 6. A matrix with the eigenvectors. * */ #include #include "matrix.h" #include #include void BlockCheck(double **A, int n, int i, int *block, double epsx) { /* block == 1 <=> TRUE, block == 0 <=> FALSE */ if (i==n) *block=0; else { if ((fabs(A[i-1][i]-A[i][i-1])>epsx) && (fabs(A[i-1][i-1]-A[i][i])<=epsx)) *block=1; else *block=0; } /* else */ } /* BlockCheck */ void PrintEigen(int n, double **A, double **B, double eps, FILE *outfile) { int i, j; int block; fprintf(outfile, "\nEigenvalues:\t\t\tRe\t\t\tIm\n"); i=1; do { BlockCheck(A, n, i, &block, eps); if (block==1) { fprintf(outfile, "\t\t\t\t%e\t\t%e\n", A[i-1][i-1], A[i-1][i]); fprintf(outfile, "\t\t\t\t%e\t\t%e\n", A[i][i], A[i][i-1]); i+=2; } else { fprintf(outfile, "\t\t\t\t%e\t\t%e\n", A[i-1][i-1], 0.0); i++; } /* if else */ } while (i!=(n+1)); fprintf(outfile, "\nEigenvectors:\t\t\tRe\t\t\tIm\n"); i=1; do { BlockCheck(A, n, i, &block, eps); if (block==1) { for(j=1; j<=n; j++) fprintf(outfile, "\t\t\t\t%e\t\t%e\n", B[j-1][i-1], B[j-1][i]); fprintf(outfile, "\n"); for(j=1; j<=n; j++) fprintf(outfile, "\t\t\t\t%e\t\t%e\n", B[j-1][i-1], -B[j-1][i]); fprintf(outfile, "\n"); i+=2; } else { for(j=1; j<=n; j++) fprintf(outfile, "\t\t\t\t%e\t\t%e\n", B[j-1][i-1], 0.0); fprintf(outfile, "\n"); i++; } /* if else */ } while (i!=(n+1)); } /* PrintEigen */ void NormalizingMatrix(int n, double **A, int fixedref, int *ref, double **V, double eps) { int j, col, block; complex double c1, c2, c3; double sqrnorm, norm, max; col=1; do { if (fixedref==0) { *ref=1; c1 = V[*ref-1][col-1] + I * V[*ref-1][col]; max=cabs(c1); for(j=2; j<=n; j++) { c2 = V[j-1][col-1] + I * V[j-1][col]; sqrnorm=cabs(c2); if (sqrnorm>max) { *ref=j; max=sqrnorm; } /* if */ } /* for j */ } /* if fixedref */ BlockCheck(A, n, col, &block, eps); if (block==1) { c1 = V[*ref-1][col-1] + I * V[*ref-1][col]; for(j=1; j<=n; j++) { c2 = V[j-1][col-1] + I * V[j-1][col]; c3 = c2 / c1; V[j-1][col-1]=creal(c3); V[j-1][col]=cimag(c3); } /* for j */ col+=2; } /* if */ else { norm=fabs(V[*ref-1][col-1]); if (norm!=0.0) for(j=1; j<=n; j++) V[j-1][col-1]/=norm; col++; } /* else */ } while (col<=n); } /* NormalizingMatrix */ void Permutation(int n, double **P, double **A, double **B, int colon, double eps) { int *nr; int block; double max, x; int im, j, ki, u, i, k, ii; double **AA; nr=IntVectorAlloc(n); AA=MatrixAlloc(n); MatrixCopy(n, AA, A); for(i=1; i<=n; i++) { nr[i-1]=i; for(k=1; k<=n; k++) P[i-1][k-1]=0.0; } /* for i */ i=ii=ki=1; while (i0.0) { A[i][i-1]=A[i-1][i]; A[i-1][i]=-A[i][i-1]; AA[i][i-1]=AA[i-1][i]; AA[i-1][i]=-AA[i][i-1]; for(j=1; j<=n; j++) B[j-1][i]=-B[j-1][i]; } else { A[i][i-1]=-A[i-1][i]; AA[i][i-1]=-AA[i-1][i]; } /* else */ j=i; for(k=ii; k<=(ii+1); k++) { x=AA[k-1][k-1]; AA[k-1][k-1]=A[j-1][j-1]; AA[j-1][j-1]=x; u=nr[k-1]; nr[k-1]=nr[j-1]; nr[j-1]=u; j++; } /* for k */ if (ii>1) { if (AA[ii-1][ii-1]>AA[0][0]) { j=ii; for(k=1; k<=2; k++) { x=AA[k-1][k-1]; AA[k-1][k-1]=A[j-1][j-1]; AA[j-1][j-1]=x; u=nr[k-1]; nr[k-1]=nr[j-1]; nr[j-1]=u; j++; } /* for k */ } /* if */ } /* if */ ki=i; i+=2; ii+=2; } /* if */ else i++; } /* while */ if (n>3) { do { im=ii; i=ii; max=AA[im-1][im-1]; do { i++; if (AA[i-1][i-1]>max) { im=i; max=AA[i-1][i-1]; } /* if */ } while (iii) { x=AA[ii-1][ii-1]; u=nr[ii-1]; AA[ii-1][ii-1]=max; nr[ii-1]=nr[im-1]; AA[im-1][im-1]=x; nr[im-1]=u; } /* if */ ii++; } while (ii=1; j--) { r=0.0; for(i=1; i<=(j-1); i++) r+=fabs(a[j-1][i-1]); for(i=(j+1); i<=k; i++) r+=fabs(a[j-1][i-1]); if (r==0.0) { d[k-1]=(double)j; if (j!=k) { for(i=1; i<=k; i++) { f=a[i-1][j-1]; a[i-1][j-1]=a[i-1][k-1]; a[i-1][k-1]=f; } for(i=l; i<=n; i++) { f=a[j-1][i-1]; a[j-1][i-1]=a[k-1][i-1]; a[k-1][i-1]=f; } } k--; goto L110; } /* if */ } /* for j */ L120: for(j=l; j<=k; j++) { c=0.0; for (i=l; i<=(j-1); i++) c+=fabs(a[i-1][j-1]); for(i=(j+1); i<=k; i++) c+=fabs(a[i-1][j-1]); if (c==0.0) { d[l-1]=(double)j; if (j!=l) { for(i=1; i<=k; i++) { f=a[i-1][j-1]; a[i-1][j-1]=a[i-1][l-1]; a[i-1][l-1]=f; } for(i=l; i<=n; i++) { f=a[j-1][i-1]; a[j-1][i-1]=a[l-1][i-1]; a[l-1][i-1]=f; } } l++; goto L120; } /* if */ } /* for j */ *low=l; *hi=k; for(i=l; i<=k; i++) d[i-1]=1.0; L130: noconv=0; for(i=l; i<=k; i++) { r=c=0.0; for(j=l; j<=(i-1); j++) { c+=fabs(a[j-1][i-1]); r+=fabs(a[i-1][j-1]); } /* for j */ for(j=(i+1); j<=k; j++) { c+=fabs(a[j-1][i-1]); r+=fabs(a[i-1][j-1]); } /* for j */ g=r/((double) b); f=1.0; s=c+r; L140: if (c=g) { f/=(double) b; c/=(double) b2; goto L150; } /* if */ if ((c+r)/f<(0.95*s)) { g=1.0/f; d[i-1]*=f; noconv=1; for(j=l; j<=n; j++) a[i-1][j-1]*=g; for(j=1; j<=k; j++) a[j-1][i-1]*=f; } /* if */ } /* for i */ if (noconv==1) goto L130; } /* Balance */ void BalBak(int n, int low, int hi, int m, double **z, double *d) { int i, j, k; double s; for(i=low; i<=hi; i++) { s=d[i-1]; for(j=1; j<=m; j++) z[i-1][j-1]*=s; } /* for i */ for(i=(low-1); i>=1; i--) { k=(int)floor(d[i-1]+0.5); if (k!=i) for(j=1; j<=m; j++) { s=z[i-1][j-1]; z[i-1][j-1]=z[k-1][j-1]; z[k-1][j-1]=s; } /* for j */ } /* for i */ for(i=(hi+1); i<=n; i++) { k=(int)floor(d[i-1]+0.5); if (k!=i) for(j=1; j<=m; j++) { s=z[i-1][j-1]; z[i-1][j-1]=z[k-1][j-1]; z[k-1][j-1]=s; } /* for j */ } /* for i */ } /* BalBak */ void Elmhes(int n, int k, int l, double **a, int *index) { int i, j, la, m; double x, y; la=l-1; for(m=(k+1); m<=la; m++) { i=m; x=0.0; for(j=m; j<=l; j++) if (fabs(a[j-1][m-2])>fabs(x)) { x=a[j-1][m-2]; i=j; } /* if */ index[m-1]=i; if (i!=m) { for(j=(m-1); j<=n; j++) { y=a[i-1][j-1]; a[i-1][j-1]=a[m-1][j-1]; a[m-1][j-1]=y; } /* for j */ for(j=1; j<=l; j++) { y=a[j-1][i-1]; a[j-1][i-1]=a[j-1][m-1]; a[j-1][m-1]=y; } /* for j */ } /* if */ if (x!=0.0) for(i=(m+1); i<=l; i++) { y=a[i-1][m-2]; if (y!=0.0) { a[i-1][m-2]=y/x; y/=x; for(j=m; j<=n; j++) a[i-1][j-1]-=y*a[m-1][j-1]; for(j=1; j<=l; j++) a[j-1][m-1]+=y*a[j-1][i-1]; } /* if */ } /* for i */ } /* for m */ } /* Elmhes */ void Elmtrans(int n, int low, int upp, double **h, int *index, double **v) { int i, j, k; for(i=1; i<=n; i++) { for(j=1; j<=n; j++) v[i-1][j-1]=0.0; v[i-1][i-1]=1.0; } /* for i */ for(i=(upp-1); i>=(low+1); i--) { j=index[i-1]; for(k=(i+1); k<=upp; k++) v[k-1][i-1]=h[k-1][i-2]; if (i!=j) { for(k=i; k<=upp; k++) { v[i-1][k-1]=v[j-1][k-1]; v[j-1][k-1]=0.0; } /* for k */ v[j-1][i-1]=1.0; } /* if */ } /* for i */ } /* Elmtrans */ void hqr2(int n, int low, int upp, int maxits, double macheps, double **h, double **vecs, double *wr, double *wi, int *cnt, int *fail) { int i, j, k, l, m, na, its, en, dummy; double p = 0, q = 0, r = 0, s = 0, t, w, x, y, z = 0, ra, sa, vr, vi, norm; int notlast; complex double c1, c2, c3; *fail=0; for(i=1; i<=(low-1); i++) { wr[i-1]=h[i-1][i-1]; wi[i-1]=0.0; cnt[i-1]=0; } /* for i */ for(i=(upp+1); i<=n; i++) { wr[i-1]=h[i-1][i-1]; wi[i-1]=0.0; cnt[i-1]=0; } /* for i */ en=upp; t=0.0; L210: if (en=(low+1); l--) if (fabs(h[l-1][l-2])<= macheps*(fabs(h[l-2][l-2])+fabs(h[l-1][l-1]))) goto L231; l=low; L231: x=h[en-1][en-1]; if (l==en) goto L240; y=h[na-1][na-1]; w=h[en-1][na-1]*h[na-1][en-1]; if (l==na) goto L250; if (its==maxits) { cnt[en-1]=maxits+1; *fail=1; goto L270; } /* if */ if ((its % 10)==0) { t+=x; for(i=low; i<=en; i++) h[i-1][i-1]-=x; s=fabs(h[en-1][na-1])+fabs(h[na-1][en-3]); y=0.75*s; x=y; w=-0.4375*s*s; } /* if */ its++; for(m=(en-2); m>=l; m--) { z=h[m-1][m-1]; r=x-z; s=y-z; p=(r*s-w)/h[m][m-1]+h[m-1][m]; q=h[m][m]-z-r-s; r=h[m+1][m]; s=fabs(p)+fabs(q)+fabs(r); p/=s; q/=s; r/=s; if (m==1) goto L232; if ((fabs(h[m-1][m-2])*(fabs(q)+fabs(r)))<= (macheps*fabs(p)*(fabs(h[m-2][m-2])+fabs(z)+fabs(h[m][m])))) goto L232; } /* for m */ L232: for(i=(m+2); i<=en; i++) h[i-1][i-3]=0.0; for(i=(m+3); i<=en; i++) h[i-1][i-4]=0.0; for(k=m; k<=na; k++) { if (k!=na) notlast=1; else notlast=0; if (k!=m) { p=h[k-1][k-2]; q=h[k][k-2]; if (notlast==1) r=h[k+1][k-2]; else r=0.0; x=fabs(p)+fabs(q)+fabs(r); if (x==0.0) goto L233; p/=x; q/=x; r/=x; } /* if */ s=sqrt(p*p+q*q+r*r); if (p<0) s=-s; if (k!=m) h[k-1][k-2]=-s*x; else if (l!=m) h[k-1][k-2]=-h[k-1][k-2]; p+=s; x=p/s; y=q/s; z=r/s; q/=p; r/=p; for(j=k; j<=n; j++) { p=h[k-1][j-1]+q*h[k][j-1]; if (notlast==1) { p+=r*h[k+1][j-1]; h[k][j-1]-=p*z; } /* if */ h[k][j-1]-=p*y; h[k-1][j-1]-=p*x; } /* for j */ if ((k+3)0.0) { if (p<0.0) z=p-z; else z+=p; wr[na-1]=x+z; s=x-w/z; wr[en-1]=s; wi[na-1]=0.0; wi[en-1]=0.0; x=h[en-1][na-1]; r=sqrt(x*x+z*z); p=x/r; q=z/r; for(j=na; j<=n; j++) { z=h[na-1][j-1]; h[na-1][j-1]=q*z+p*h[en-1][j-1]; /* h[en-1][j-1]=q*h[en-1][j-1]-p*z */ h[en-1][j-1]*=q; h[en-1][j-1]-=p*z; } /* for j */ for(i=1; i<=en; i++) { z=h[i-1][na-1]; h[i-1][na-1]=q*z+p*h[i-1][en-1]; /* h[i-1][en-1]=q*h[i-1][en-1]-p*z */ h[i-1][en-1]*=q; h[i-1][en-1]-=p*z; } /* for i */ for(i=low; i<=upp; i++) { z=vecs[i-1][na-1]; vecs[i-1][na-1]=q*z+p*vecs[i-1][en-1]; /* vecs[i-1][en-1]=q*vecs[i-1][en-1]-p*z */ vecs[i-1][en-1]*=q; vecs[i-1][en-1]-=p*z; } /* for i */ } /* if */ else { wr[na-1]=x+p; wr[en-1]=x+p; wi[na-1]=z; wi[en-1]=-z; } /* else */ en-=2; goto L210; L260: norm=0.0; k=1; for(i=1; i<=n; i++) { for(j=k; j<=n; j++) norm+=fabs(h[i-1][j-1]); k=i; } /* for i */ for(en=n; en>=1; en--) { p=wr[en-1]; q=wi[en-1]; na=en-1; if (q==0.0) { m=en; h[en-1][en-1]=1.0; for(i=na; i>=1; i--) { w=h[i-1][i-1]-p; r=h[i-1][en-1]; for(j=m; j<=na; j++) r+=h[i-1][j-1]*h[j-1][en-1]; if (wi[i-1]<0.0) { z=w; s=r; } /* if */ else { m=i; if (wi[i-1]==0.0) { if (w!=0.0) h[i-1][en-1]=-r/w; else h[i-1][en-1]=-r/macheps/norm; } else { x=h[i-1][i]; y=h[i][i-1]; q=pow(wr[i-1]-p, 2.0)+wi[i-1]*wi[i-1]; t=(x*s-z*r)/q; h[i-1][en-1]=t; if (fabs(x)>fabs(z)) h[i][en-1]=(-r-w*t)/x; else h[i][en-1]=(-s-y*t)/z; } /* else */ } /* else */ } /* i */ } else if (q<0.0) { m=na; if (fabs(h[en-1][na-1])>fabs(h[na-1][en-1])) { h[na-1][na-1]=-(h[en-1][en-1]-p)/h[en-1][na-1]; h[na-1][en-1]=-q/h[en-1][na-1]; } /* if */ else { c1 = -h[na-1][en-1]; c2 = h[na-1][na-1]-p + I * q; c3 = c1 / c2; h[na-1][na-1]=creal(c3); h[na-1][en-1]=cimag(c3); } /* else */ h[en-1][na-1]=1.0; h[en-1][en-1]=0.0; for(i=(na-1); i>=1; i--) { w=h[i-1][i-1]-p; ra=h[i-1][en-1]; sa=0.0; for(j=m; j<=na; j++) { ra+=h[i-1][j-1]*h[j-1][na-1]; sa+=h[i-1][j-1]*h[j-1][en-1]; } /* for j */ if (wi[i-1]<0.0) { z=w; r=ra; s=sa; } /* if */ else { m=i; if (wi[i-1]==0.0) { c1 = -ra + I * -sa; c2 = w + I * q; c3 = c1 / c2; h[i-1][na-1]=creal(c3); h[i-1][en-1]=cimag(c3); } /* if */ else { x=h[i-1][i]; y=h[i][i-1]; vr=pow(wr[i-1]-p, 2.0)+wi[i-1]*wi[i-1]-q*q; vi=(wr[i-1]-p)*2.0*q; if ((vr==0.0) && (vi==0.0)) vr=macheps*norm*(fabs(w)+fabs(q)+fabs(x)+fabs(y)+fabs(z)); c1 = x*r-z*ra+q*sa + I * x*s-z*sa-q*ra; c2 = vr + I * vi; c3 = c1 / c2; h[i-1][na-1]=creal(c3); h[i-1][en-1]=cimag(c3); if (fabs(x)>(fabs(z)+fabs(q))) { h[i][na-1]=(-ra-w*h[i-1][na-1]+q*h[i-1][en-1])/x; h[i][en-1]=(-sa-w*h[i-1][en-1]-q*h[i-1][na-1])/x; } /* if */ else { c1 = -r-y*h[i-1][na-1] + I * -s-y*h[i-1][en-1]; c2 = z + I * q; c3 = c1 / c2; h[i][na-1]=creal(c3); h[i][en-1]=cimag(c3); } /* else */ } /* else */ } /* else */ } /* for i */ } /* if */ } /* for en */ for(i=1; i<=(low-1); i++) for(j=(i+1); j<=n; j++) vecs[i-1][j-1]=h[i-1][j-1]; for(i=(upp+1); i<=n; i++) for(j=(i+1); j<=n; j++) vecs[i-1][j-1]=h[i-1][j-1]; for(j=n; j>=low; j--) { if (j<=upp) m=j; else m=upp; l=j-1; if (wi[j-1]<0.0) { for(i=low; i<=upp; i++) { y=z=0.0; for(k=low; k<=m; k++) { y+=vecs[i-1][k-1]*h[k-1][l-1]; z+=vecs[i-1][k-1]*h[k-1][j-1]; } /* for k */ vecs[i-1][l-1]=y; vecs[i-1][j-1]=z; } /* for i */ } /* if */ else if (wi[j-1]==0.0) for(i=low; i<=upp; i++) { z=0.0; for(k=low; k<=m; k++) z+=vecs[i-1][k-1]*h[k-1][j-1]; vecs[i-1][j-1]=z; } /* for i */ } /* for j */ L270: dummy=0; } /* hqr2 */ void Eigen(int n, int ref, double **AJAC, int maxit, double eps, int fixedref, complex double *values, complex double **vectors) { double *wr, *wi, *bald, **T, **A; int i, j, ballow, balhi, block; int *intout; int fail; intout=IntVectorAlloc(n); wr=VectorAlloc(n); wi=VectorAlloc(n); bald=VectorAlloc(n); T=MatrixAlloc(n); A=MatrixAlloc(n); for(i=1; i<=n; i++) for(j=1; j<=n; j++) A[i-1][j-1]=AJAC[i-1][j-1]; Balance(n, 10, A, &ballow, &balhi, bald); Elmhes(n, ballow, balhi, A, intout); Elmtrans(n, ballow, balhi, A, intout, T); hqr2(n, ballow, balhi, maxit, eps, A, T, wr, wi, intout, &fail); if (fail==1) (void) fprintf(stderr, "Failure in hqr2 function. Do not trust the given eigenvectors and -values\n"); /* tmxx=0; for(i=1; i<=n; i++) if (abs(intout[i-1])>tmxx) tmxx=(int)ceil(abs(intout[i-1])); */ for(i=1; i<=n; i++) for(j=1; j<=n; j++) A[i-1][j-1]=0.0; i=1; do { if (wi[i-1]!=0.0) { A[i-1][i-1]=wr[i-1]; A[i][i]=wr[i-1]; A[i-1][i]=wi[i-1]; A[i][i-1]=wi[i]; i+=2; } /* if */ else { A[i-1][i-1]=wr[i-1]; i++; } /* else */ } while (i Date: Thu, 13 Jan 2005 22:40:30 +0100 From: Kenneth Geisshirt To: deforest@boulder.swri.edu Subject: Re: Small Scientific Library use within Perl/PDL? Craig DeForest wrote: > I notice that, while you have made SSL available for download, there is no > indication that it is free software. Are you willing to distribute SSL under > the Perl Artistic License (or some other free software license)? That's my mistake: SSLib is free software. I'll create a new tar ball this weekend (including a license). I'll probably use the MIT X License since it's the less restricted license I know. If you decide to use some of my routines in PDL I'll be very happy. And if you need any help please let me know. SSLib is a very simple library - not that the routines are simple but the API is on a basic level and the application programmer must be very aware of how to call routines and use the data structure. /kneth -- Kenneth Geisshirt, M.Sc., Ph.D. -- http://kenneth.geisshirt.dk/ GPG Fingerprint: CEC4 7449 1B9B C8A5 7679 F062 DDDF 020E F812 4EE3 PDL-2.074/Basic/MatrixOps/matrixops.pd0000644000175000017500000012512714165667420017440 0ustar osboxesosboxespp_addhdr(' #include '); use strict; use warnings; pp_addpm({At=>'Top'},<<'EOD'); use strict; use warnings; =head1 NAME PDL::MatrixOps -- Some Useful Matrix Operations =head1 SYNOPSIS $inv = $x->inv; $det = $x->det; ($lu,$perm,$par) = $x->lu_decomp; $y = lu_backsub($lu,$perm,$z); # solve $x x $y = $z =head1 DESCRIPTION PDL::MatrixOps is PDL's built-in matrix manipulation code. It contains utilities for many common matrix operations: inversion, determinant finding, eigenvalue/vector finding, singular value decomposition, etc. PDL::MatrixOps routines are written in a mixture of Perl and C, so that they are reliably present even when there is no FORTRAN compiler or external library available (e.g. L or any of the PDL::GSL family of modules). Matrix manipulation, particularly with large matrices, is a challenging field and no one algorithm is suitable in all cases. The utilities here use general-purpose algorithms that work acceptably for many cases but might not scale well to very large or pathological (near-singular) matrices. Except as noted, the matrices are PDLs whose 0th dimension ranges over column and whose 1st dimension ranges over row. The matrices appear correctly when printed. These routines should work OK with L objects as well as with normal PDLs. =head1 TIPS ON MATRIX OPERATIONS Like most computer languages, PDL addresses matrices in (column,row) order in most cases; this corresponds to (X,Y) coordinates in the matrix itself, counting rightwards and downwards from the upper left corner. This means that if you print a PDL that contains a matrix, the matrix appears correctly on the screen, but if you index a matrix element, you use the indices in the reverse order that you would in a math textbook. If you prefer your matrices indexed in (row, column) order, you can try using the L object, which includes an implicit exchange of the first two dimensions but should be compatible with most of these matrix operations. TIMTOWDTI.) Matrices, row vectors, and column vectors can be multiplied with the 'x' operator (which is, of course, threadable): $m3 = $m1 x $m2; $col_vec2 = $m1 x $col_vec1; $row_vec2 = $row_vec1 x $m1; $scalar = $row_vec x $col_vec; Because of the (column,row) addressing order, 1-D PDLs are treated as _row_ vectors; if you want a _column_ vector you must add a dummy dimension: $rowvec = pdl(1,2); # row vector $colvec = $rowvec->slice('*1'); # 1x2 column vector $matrix = pdl([[3,4],[6,2]]); # 2x2 matrix $rowvec2 = $rowvec x $matrix; # right-multiplication by matrix $colvec = $matrix x $colvec; # left-multiplication by matrix $m2 = $matrix x $rowvec; # Throws an error Implicit threading works correctly with most matrix operations, but you must be extra careful that you understand the dimensionality. In particular, matrix multiplication and other matrix ops need nx1 PDLs as row vectors and 1xn PDLs as column vectors. In most cases you must explicitly include the trailing 'x1' dimension in order to get the expected results when you thread over multiple row vectors. When threading over matrices, it's very easy to get confused about which dimension goes where. It is useful to include comments with every expression, explaining what you think each dimension means: $x = xvals(360)*3.14159/180; # (angle) $rot = cat(cat(cos($x),sin($x)), # rotmat: (col,row,angle) cat(-sin($x),cos($x))); =head1 ACKNOWLEDGEMENTS MatrixOps includes algorithms and pre-existing code from several origins. In particular, C is the work of Stephen Moshier, C uses an SVD subroutine written by Bryant Marks, and C uses a subset of the Small Scientific Library by Kenneth Geisshirt. They are free software, distributable under same terms as PDL itself. =head1 NOTES This is intended as a general-purpose linear algebra package for small-to-mid sized matrices. The algorithms may not scale well to large matrices (hundreds by hundreds) or to near singular matrices. If there is something you want that is not here, please add and document it! =cut use Carp; use strict; EOD ###################################################################### pp_add_exported('','identity'); pp_addpm(<<'EOD'); =head2 identity =for sig Signature: (n; [o]a(n,n)) =for ref Return an identity matrix of the specified size. If you hand in a scalar, its value is the size of the identity matrix; if you hand in a dimensioned PDL, the 0th dimension is the first two dimensions of the matrix, with higher dimensions preserved. =cut sub identity { my $n = shift; my $out = !UNIVERSAL::isa($n,'PDL') ? zeroes($n,$n) : $n->getndims == 0 ? zeroes($n->at(0),$n->at(0)) : undef; if (!defined $out) { my @dims = $n->dims; $out = zeroes(@dims[0, 0, 2..$#dims]); } (my $tmp = $out->diagonal(0,1))++; # work around perl -d "feature" $out; } EOD ###################################################################### pp_add_exported('','stretcher'); pp_addpm(<<'EOD'); =head2 stretcher =for sig Signature: (a(n); [o]b(n,n)) =for usage $mat = stretcher($eigenvalues); =for ref Return a diagonal matrix with the specified diagonal elements =cut sub stretcher { my $in = shift; my $out = zeroes($in->dim(0),$in->dims); my $tmp; # work around for perl -d "feature" ($tmp = $out->diagonal(0,1)) += $in; $out; } EOD ###################################################################### pp_add_exported('','inv'); pp_addpm(<<'EOD'); =head2 inv =for sig Signature: (a(m,m); sv opt ) =for usage $a1 = inv($a, {$opt}); =for ref Invert a square matrix. You feed in an NxN matrix in $a, and get back its inverse (if it exists). The code is inplace-aware, so you can get back the inverse in $a itself if you want -- though temporary storage is used either way. You can cache the LU decomposition in an output option variable. C uses C by default; that is a numerically stable (pivoting) LU decomposition method. OPTIONS: =over 3 =item * s Boolean value indicating whether to complain if the matrix is singular. If this is false, singular matrices cause inverse to barf. If it is true, then singular matrices cause inverse to return undef. =item * lu (I/O) This value contains a list ref with the LU decomposition, permutation, and parity values for C<$a>. If you do not mention the key, or if the value is undef, then inverse calls C. If the key exists with an undef value, then the output of C is stashed here (unless the matrix is singular). If the value exists, then it is assumed to hold the LU decomposition. =item * det (Output) If this key exists, then the determinant of C<$a> get stored here, whether or not the matrix is singular. =back =cut *PDL::inv = \&inv; sub inv { my $x = shift; my $opt = shift; $opt = {} unless defined($opt); barf "inverse needs a square PDL as a matrix\n" unless(UNIVERSAL::isa($x,'PDL') && $x->dims >= 2 && $x->dim(0) == $x->dim(1) ); my ($lu,$perm,$par); if(exists($opt->{lu}) && ref $opt->{lu} eq 'ARRAY' && ref $opt->{lu}->[0] eq 'PDL') { ($lu,$perm,$par) = @{$opt->{lu}}; } else { ($lu,$perm,$par) = lu_decomp($x); @{$opt->{lu}} = ($lu,$perm,$par) if(ref $opt->{lu} eq 'ARRAY'); } my $det = (defined $lu) ? $lu->diagonal(0,1)->prodover * $par : pdl(0); $opt->{det} = $det if exists($opt->{det}); unless($det->nelem > 1 || $det) { return undef if $opt->{s}; barf("PDL::inv: got a singular matrix or LU decomposition\n"); } my $out = lu_backsub($lu,$perm,$par,identity($x))->transpose->sever; return $out unless($x->is_inplace); $x .= $out; $x; } EOD ###################################################################### pp_add_exported('','det'); pp_addpm(<<'EOD'); =head2 det =for sig Signature: (a(m,m); sv opt) =for usage $det = det($a,{opt}); =for ref Determinant of a square matrix using LU decomposition (for large matrices) You feed in a square matrix, you get back the determinant. Some options exist that allow you to cache the LU decomposition of the matrix (note that the LU decomposition is invalid if the determinant is zero!). The LU decomposition is cacheable, in case you want to re-use it. This method of determinant finding is more rapid than recursive-descent on large matrices, and if you reuse the LU decomposition it's essentially free. OPTIONS: =over 3 =item * lu (I/O) Provides a cache for the LU decomposition of the matrix. If you provide the key but leave the value undefined, then the LU decomposition goes in here; if you put an LU decomposition here, it will be used and the matrix will not be decomposed again. =back =cut *PDL::det = \&det; sub det { my($x) = shift; my($opt) = shift; $opt = {} unless defined($opt); my($lu,$perm,$par); if(exists ($opt->{lu}) and (ref $opt->{lu} eq 'ARRAY')) { ($lu,$perm,$par) = @{$opt->{lu}}; } else { ($lu,$perm,$par) = lu_decomp($x); $opt->{lu} = [$lu,$perm,$par] if(exists($opt->{lu})); } ( (defined $lu) ? $lu->diagonal(0,1)->prodover * $par : 0 ); } EOD ###################################################################### pp_add_exported('','determinant'); pp_addpm(<<'EOD'); =head2 determinant =for sig Signature: (a(m,m)) =for usage $det = determinant($x); =for ref Determinant of a square matrix, using recursive descent (threadable). This is the traditional, robust recursive determinant method taught in most linear algebra courses. It scales like C (and hence is pitifully slow for large matrices) but is very robust because no division is involved (hence no division-by-zero errors for singular matrices). It's also threadable, so you can find the determinants of a large collection of matrices all at once if you want. Matrices up to 3x3 are handled by direct multiplication; larger matrices are handled by recursive descent to the 3x3 case. The LU-decomposition method L is faster in isolation for single matrices larger than about 4x4, and is much faster if you end up reusing the LU decomposition of C<$a> (NOTE: check performance and threading benchmarks with new code). =cut *PDL::determinant = \&determinant; sub determinant { my($x) = shift; my($n); return undef unless( UNIVERSAL::isa($x,'PDL') && $x->getndims >= 2 && ($n = $x->dim(0)) == $x->dim(1) ); return $x->clump(2) if($n==1); if($n==2) { my($y) = $x->clump(2); return $y->index(0)*$y->index(3) - $y->index(1)*$y->index(2); } if($n==3) { my($y) = $x->clump(2); my $y3 = $y->index(3); my $y4 = $y->index(4); my $y5 = $y->index(5); my $y6 = $y->index(6); my $y7 = $y->index(7); my $y8 = $y->index(8); return ( $y->index(0) * ( $y4 * $y8 - $y5 * $y7 ) + $y->index(1) * ( $y5 * $y6 - $y3 * $y8 ) + $y->index(2) * ( $y3 * $y7 - $y4 * $y6 ) ); } my($i); my($sum) = zeroes($x->slice('(0),(0)')); # Do middle submatrices for $i(1..$n-2) { my $el = $x->slice("($i),(0)"); next if( ($el==0)->all ); # Optimize away unnecessary recursion $sum += $el * (1-2*($i%2)) * determinant($x->slice("0:".($i-1).",1:-1")-> append($x->slice(($i+1).":-1,1:-1"))); } # Do beginning and end submatrices $sum += $x->slice("(0),(0)") * determinant($x->slice('1:-1,1:-1')); $sum -= $x->slice("(-1),(0)") * determinant($x->slice('0:-2,1:-1')) * (1 - 2*($n % 2)); return $sum; } EOD ###################################################################### ### eigens_sym ### pp_def("eigens_sym", HandleBad => 0, Pars => '[phys]a(m); [o,phys]ev(n,n); [o,phys]e(n)', GenericTypes => ['D'], Code => ' extern void eigens( double *A, double *RR, double *E, int N ); register int sn = $SIZE (n); if($SIZE (m) != (sn * (sn + 1))/2) { $CROAK("Wrong sized args for eigens_sym"); } eigens($P (a), $P (ev), $P (e), sn); ', PMCode =>' sub PDL::eigens_sym { my ($x) = @_; my (@d) = $x->dims; barf "Need real square matrix for eigens_sym" if $#d < 1 or $d[0] != $d[1]; my ($n) = $d[0]; my ($sym) = 0.5*($x + $x->transpose); my ($err) = PDL::max(abs($sym)); barf "Need symmetric component non-zero for eigens_sym" if $err == 0; $err = PDL::max(abs($x-$sym))/$err; warn "Using symmetrized version of the matrix in eigens_sym" if $err > 1e-5 && $PDL::debug; ## Get lower diagonal form ## Use whichND/indexND because whereND doesn\'t exist (yet?) and ## the combo is threadable (unlike where). Note that for historical ## reasons whichND needs a scalar() around it to give back a ## nice 2xn PDL index. my $lt = PDL::indexND($sym, scalar(PDL::whichND(PDL->xvals($n,$n) <= PDL->yvals($n,$n))) )->copy; my $ev = PDL->zeroes($sym->dims); my $e = PDL->zeroes($sym->index(0)->dims); &PDL::_eigens_sym_int($lt, $ev, $e); return $ev->transpose, $e if(wantarray); $e; #just eigenvalues } ' , Doc => ' =for ref Eigenvalues and -vectors of a symmetric square matrix. If passed an asymmetric matrix, the routine will warn and symmetrize it, by taking the average value. That is, it will solve for 0.5*($a+$a->transpose). It\'s threadable, so if C<$a> is 3x3x100, it\'s treated as 100 separate 3x3 matrices, and both C<$ev> and C<$e> get extra dimensions accordingly. If called in scalar context it hands back only the eigenvalues. Ultimately, it should switch to a faster algorithm in this case (as discarding the eigenvectors is wasteful). The algorithm used is due to J. vonNeumann, which was a rediscovery of L . The eigenvectors are returned in COLUMNS of the returned PDL. That makes it slightly easier to access individual eigenvectors, since the 0th dim of the output PDL runs across the eigenvectors and the 1st dim runs across their components. ($ev,$e) = eigens_sym $x; # Make eigenvector matrix $vector = $ev->slice($n); # Select nth eigenvector as a column-vector $vector = $ev->slice("($n)"); # Select nth eigenvector as a row-vector =for usage ($ev, $e) = eigens_sym($x); # e-vects & e-values $e = eigens_sym($x); # just eigenvalues =cut ',); ###################################################################### ### eigens ### pp_def("eigens", HandleBad => 0, Pars => '[phys]a(m); [o,phys]ev(l,n,n); [o,phys]e(l,n)', GenericTypes => ['D'], Code => ' #include "eigen.h" register int sn = $SIZE(n); int i,j; void **foo; void **bar; New(42, foo, sn, void*); New(111, bar, sn, void*); if($SIZE (l) != 2) { $CROAK("eigens internal error..."); } if($SIZE (m) != (sn * sn )) { fprintf(stderr,"m=%"IND_FLAG", sn=%d\n",$SIZE(m),sn); $CROAK("Wrong sized args for eigens"); } for( i=j=0; i<$SIZE(m); i += sn ) { foo[j] = &( ($P(a))[ i ] ); bar[j] = &( ($P(ev))[ i+i ] ); j++; } Eigen( sn, 0, (double **) foo, 20*sn, 1e-13, 0, (complex double *)( $P(e) ), (complex double **) bar ); Safefree(foo); Safefree(bar); /* Check for invalid values: convenience block */ { int k; char ok, flag; PDL_Double eps = 0; /* First: find maximum eigenvalue */ for(i=0; i< sn; i++ ) { PDL_Double z = fabs ( ($P(e))[i*2] ); if( z > eps ) eps = z; } eps *= 1e-10; /* Next: scan for non-real terms and parallel vectors */ for( i=0; i < sn; i++ ) { ok = ( fabs( ($P(e))[i*2+1] ) < eps ); for( j=0; ok && j< sn; j++) ok &= fabs( ($P(ev))[ 2* (i*sn + j) + 1] ) < eps; for( k=0; ok && k < i; k++ ) { if( isfinite( ($P(ev))[ 2 * (k*sn) ] ) ) { for( flag=1, j=0; ok && flag && j< sn; j++) flag &= ( fabs( ($P(ev))[ 2 * (i*sn + j) ] - ($P(ev))[ 2 * (k*sn + j) ] ) < 1e-10 * ( fabs(($P(ev))[ 2 * (k*sn + j) ]) + fabs(($P(ev))[ 2 * (i*sn + j) ]) ) ); ok &= !flag; } } if (ok) { for(j=0; ok && j' sub PDL::eigens { my ($x) = @_; my (@d) = $x->dims; my $n = $d[0]; barf "Need real square matrix for eigens" if $#d < 1 or $d[0] != $d[1]; my $deviation = PDL::max(abs($x - $x->transpose))/PDL::max(abs($x)); if ( $deviation <= 1e-5 ) { #taken from eigens_sym code my $lt = PDL::indexND($x, scalar(PDL::whichND(PDL->xvals($n,$n) <= PDL->yvals($n,$n))) )->copy; my $ev = PDL->zeroes($x->dims); my $e = PDL->zeroes($x->index(0)->dims); &PDL::_eigens_sym_int($lt, $ev, $e); return $ev->transpose, $e if wantarray; return $e; #just eigenvalues } else { if($PDL::verbose || $PDL::debug) { print "eigens: using the asymmetric case from SSL\n"; } if( !$PDL::eigens_bug_ack && !$ENV{PDL_EIGENS_ACK} ) { print STDERR "WARNING: using sketchy algorithm for PDL::eigens asymmetric case -- you might\n". " miss an eigenvector or two\nThis should be fixed in PDL v2.5 (due 2009), \n". " or you might fix it yourself (hint hint). You can shut off this warning\n". " by setting the variable $PDL::eigens_bug_ack, or the environment variable\n". " PDL_EIGENS_HACK prior to calling eigens() with a non-symmetric matrix.\n"; $PDL::eigens_bug_ack = 1; } my $ev = PDL->zeroes(2, $x->dims); my $e = PDL->zeroes(2, $x->index(0)->dims); &PDL::_eigens_int($x->clump(0,1), $ev, $e); return $ev->index(0)->transpose->sever, $e->index(0)->sever if(wantarray); return $e->index(0)->sever; #just eigenvalues } } ' , Doc => ' =for ref Real eigenvalues and -vectors of a real square matrix. (See also L<"eigens_sym"|/eigens_sym>, for eigenvalues and -vectors of a real, symmetric, square matrix). The eigens function will attempt to compute the eigenvalues and eigenvectors of a square matrix with real components. If the matrix is symmetric, the same underlying code as L<"eigens_sym"|/eigens_sym> is used. If asymmetric, the eigenvalues and eigenvectors are computed with algorithms from the sslib library. If any imaginary components exist in the eigenvalues, the results are currently considered to be invalid, and such eigenvalues are returned as "NaN"s. This is true for eigenvectors also. That is if there are imaginary components to any of the values in the eigenvector, the eigenvalue and corresponding eigenvectors are all set to "NaN". Finally, if there are any repeated eigenvectors, they are replaced with all "NaN"s. Use of the eigens function on asymmetric matrices should be considered experimental! For asymmetric matrices, nearly all observed matrices with real eigenvalues produce incorrect results, due to errors of the sslib algorithm. If your assymmetric matrix returns all NaNs, do not assume that the values are complex. Also, problems with memory access is known in this library. Not all square matrices are diagonalizable. If you feed in a non-diagonalizable matrix, then one or more of the eigenvectors will be set to NaN, along with the corresponding eigenvalues. C is threadable, so you can solve 100 eigenproblems by feeding in a 3x3x100 array. Both C<$ev> and C<$e> get extra dimensions accordingly. If called in scalar context C hands back only the eigenvalues. This is somewhat wasteful, as it calculates the eigenvectors anyway. The eigenvectors are returned in COLUMNS of the returned PDL (ie the the 0 dimension). That makes it slightly easier to access individual eigenvectors, since the 0th dim of the output PDL runs across the eigenvectors and the 1st dim runs across their components. ($ev,$e) = eigens $x; # Make eigenvector matrix $vector = $ev->slice($n); # Select nth eigenvector as a column-vector $vector = $ev->slice("($n)"); # Select nth eigenvector as a row-vector DEVEL NOTES: For now, there is no distinction between a complex eigenvalue and an invalid eigenvalue, although the underlying code generates complex numbers. It might be useful to be able to return complex eigenvalues. =for usage ($ev, $e) = eigens($x); # e\'vects & e\'vals $e = eigens($x); # just eigenvalues =cut ',); ###################################################################### ### svd pp_def( "svd", HandleBad => 0, Pars => 'a(n,m); [o]u(n,m); [o,phys]z(n); [o]v(n,n);', GenericTypes => ['D'], Code => ' extern void SVD( double *W, double *Z, int nRow, int nCol ); int sm = $SIZE (m), sn = $SIZE (n), i; if (sm= n; you have m=%d and n=%d. Try inputting the transpose. See the docs for svd.",sm,sn); } double *w, *t, zv; t = w = (double *) malloc(sn*(sm+sn)*sizeof(double)); loop (m) %{ loop(n) %{ *t++ = $a (); %} %} SVD(w, $P (z), sm, sn); t = w; loop (n) %{ zv = sqrt($z ()); $z () = zv; %} loop (m) %{ loop (n) %{ $u () = *t++/$z (); %} %} loop (n) %{ for (i=0;ii, n1=>n) = *t++; } %} free(w); ', , Doc => q{ =for usage ($u, $s, $v) = svd($x); =for ref Singular value decomposition of a matrix. C is threadable. Given an m x n matrix C<$a> that has m rows and n columns (m >= n), C computes matrices C<$u> and C<$v>, and a vector of the singular values C<$s>. Like most implementations, C computes what is commonly referred to as the "thin SVD" of C<$a>, such that C<$u> is m x n, C<$v> is n x n, and there are <=n singular values. As long as m >= n, the original matrix can be reconstructed as follows: ($u,$s,$v) = svd($x); $ess = zeroes($x->dim(0),$x->dim(0)); $ess->slice("$_","$_").=$s->slice("$_") foreach (0..$x->dim(0)-1); #generic diagonal $a_copy = $u x $ess x $v->transpose; If m==n, C<$u> and C<$v> can be thought of as rotation matrices that convert from the original matrix's singular coordinates to final coordinates, and from original coordinates to singular coordinates, respectively, and $ess is a diagonal scaling matrix. If n>m, C will barf. This can be avoided by passing in the transpose of C<$a>, and reconstructing the original matrix like so: ($u,$s,$v) = svd($x->transpose); $ess = zeroes($x->dim(1),$x->dim(1)); $ess->slice($_,$_).=$s->slice($_) foreach (0..$x->dim(1)-1); #generic diagonal $x_copy = $v x $ess x $u->transpose; EXAMPLE The computing literature has loads of examples of how to use SVD. Here's a trivial example (used in L) of how to make a matrix less, er, singular, without changing the orientation of the ellipsoid of transformation: { my($r1,$s,$r2) = svd $x; $s++; # fatten all singular values $r2 *= $s; # implicit threading for cheap mult. $x .= $r2 x $r1; # a gets r2 x ess x r1 } =cut },); ###################################################################### pp_add_exported('','lu_decomp'); pp_addpm(<<'EOD'); =head2 lu_decomp =for sig Signature: (a(m,m); [o]lu(m,m); [o]perm(m); [o]parity) =for ref LU decompose a matrix, with row permutation =for usage ($lu, $perm, $parity) = lu_decomp($x); $lu = lu_decomp($x, $perm, $par); # $perm and $par are outputs! lu_decomp($x->inplace,$perm,$par); # Everything in place. =for description C returns an LU decomposition of a square matrix, using Crout's method with partial pivoting. It's ported from I. The partial pivoting keeps it numerically stable but means a little more overhead from threading. C decomposes the input matrix into matrices L and U such that LU = A, L is a subdiagonal matrix, and U is a superdiagonal matrix. By convention, the diagonal of L is all 1's. The single output matrix contains all the variable elements of both the L and U matrices, stacked together. Because the method uses pivoting (rearranging the lower part of the matrix for better numerical stability), you have to permute input vectors before applying the L and U matrices. The permutation is returned either in the second argument or, in list context, as the second element of the list. You need the permutation for the output to make any sense, so be sure to get it one way or the other. LU decomposition is the answer to a lot of matrix questions, including inversion and determinant-finding, and C is used by L. If you pass in C<$perm> and C<$parity>, they either must be predeclared PDLs of the correct size ($perm is an n-vector, C<$parity> is a scalar) or scalars. If the matrix is singular, then the LU decomposition might not be defined; in those cases, C silently returns undef. Some singular matrices LU-decompose just fine, and those are handled OK but give a zero determinant (and hence can't be inverted). C uses pivoting, which rearranges the values in the matrix for more numerical stability. This makes it really good for large and even near-singular matrices. There is a non-pivoting version C available which is from 5 to 60 percent faster for typical problems at the expense of failing to compute a result in some cases. Now that the C is threaded, it is the recommended LU decomposition routine. It no longer falls back to C. C is ported from I to PDL. It should probably be implemented in C. =cut *PDL::lu_decomp = \&lu_decomp; sub lu_decomp { my($in) = shift; my($permute) = shift; my($parity) = shift; my($sing_ok) = shift; my $TINY = 1e-30; barf("lu_decomp requires a square (2D) PDL\n") if(!UNIVERSAL::isa($in,'PDL') || $in->ndims < 2 || $in->dim(0) != $in->dim(1)); my($n) = $in->dim(0); my($n1) = $n; $n1--; my($inplace) = $in->is_inplace; my($out) = ($inplace) ? $in : $in->copy; if(defined $permute) { barf('lu_decomp: permutation vector must match the matrix') if(!UNIVERSAL::isa($permute,'PDL') || $permute->ndims != 1 || $permute->dim(0) != $out->dim(0)); $permute .= PDL->xvals($in->dim(0)); } else { $permute = $in->slice("(0)")->xvals; } if(defined $parity) { barf('lu_decomp: parity must be a scalar PDL') if(!UNIVERSAL::isa($parity,'PDL') || $parity->dim(0) != 1); $parity .= 1.0; } else { $parity = $in->slice('(0),(0)')->ones; } my($scales) = $in->copy->abs->maximum; # elementwise by rows if(($scales==0)->sum) { return undef; } # Some holding tanks my($tmprow) = $out->slice('(0)')->double->zeroes; my($tmpval) = $tmprow->slice('(0)')->sever; my($col,$row); for $col(0..$n1) { for $row(1..$n1) { my($klim) = $row<$col ? $row : $col; if($klim > 0) { $klim--; my($el) = $out->index2d($col,$row); $el -= ( $out->slice("($col),0:$klim") * $out->slice("0:$klim,($row)") )->sumover; } } # Figure a_ij, with pivoting if($col < $n1) { # Find the maximum value in the rest of the row my $sl = $out->slice("($col),$col:$n1"); my $wh = $sl->abs->maximum_ind; my $big = $sl->index($wh)->sever; # Permute if necessary to make the diagonal the maximum # if($wh != 0) { # Permute rows to place maximum element on diagonal. my $whc = $wh+$col; my $sl1 = $out->mv(1,0)->index($whc->slice("*$n")); my $sl2 = $out->slice(":,($col)"); $tmprow .= $sl1; $sl1 .= $sl2; $sl2 .= $tmprow; $sl1 = $permute->index($whc); $sl2 = $permute->index($col); $tmpval .= $sl1; $sl1 .= $sl2; $sl2 .= $tmpval; { my $tmp; ($tmp = $parity->where($wh>0)) *= -1.0; } } # Sidestep near-singularity (NR does this; not sure if it is helpful) my $notbig = $big->where(abs($big) < $TINY); $notbig .= $TINY * (1.0 - 2.0*($notbig < 0)); # Divide by the diagonal element (which is now the largest element) my $tout; ($tout = $out->slice("($col),".($col+1).":$n1")) /= $big->slice('*1'); } # end of pivoting part } # end of column loop if(wantarray) { return ($out,$permute,$parity); } $out; } EOD ###################################################################### pp_add_exported('','lu_decomp2'); pp_addpm(<<'EOD'); =head2 lu_decomp2 =for sig Signature: (a(m,m); [o]lu(m,m)) =for ref LU decompose a matrix, with no row permutation =for usage ($lu, $perm, $parity) = lu_decomp2($x); $lu = lu_decomp2($x,$perm,$parity); # or $lu = lu_decomp2($x); # $perm and $parity are optional lu_decomp($x->inplace,$perm,$parity); # or lu_decomp($x->inplace); # $perm and $parity are optional =for description C works just like L, but it does B pivoting at all. For compatibility with L, it will give you a permutation list and a parity scalar if you ask for them -- but they are always trivial. Because C does not pivot, it is numerically B -- that means it is less precise than L, particularly for large or near-singular matrices. There are also specific types of non-singular matrices that confuse it (e.g. ([0,-1,0],[1,0,0],[0,0,1]), which is a 90 degree rotation matrix but which confuses C). On the other hand, if you want to invert rapidly a few hundred thousand small matrices and don't mind missing one or two, it could be the ticket. It can be up to 60% faster at the expense of possible failure of the decomposition for some of the input matrices. The output is a single matrix that contains the LU decomposition of C<$a>; you can even do it in-place, thereby destroying C<$a>, if you want. See L for more information about LU decomposition. C is ported from I into PDL. =cut *PDL::lu_decomp2 = \&lu_decomp2; sub lu_decomp2 { my($in) = shift; my($perm) = shift; my($par) = shift; my($sing_ok) = shift; my $TINY = 1e-30; barf("lu_decomp2 requires a square (2D) PDL\n") if(!UNIVERSAL::isa($in,'PDL') || $in->ndims < 2 || $in->dim(0) != $in->dim(1)); my($n) = $in->dim(0); my($n1) = $n; $n1--; my($inplace) = $in->is_inplace; my($out) = ($inplace) ? $in : $in->copy; if(defined $perm) { barf('lu_decomp2: permutation vector must match the matrix') if(!UNIVERSAL::isa($perm,'PDL') || $perm->ndims != 1 || $perm->dim(0) != $out->dim(0)); $perm .= PDL->xvals($in->dim(0)); } else { $perm = PDL->xvals($in->dim(0)); } if(defined $par) { barf('lu_decomp: parity must be a scalar PDL') if(!UNIVERSAL::isa($par,'PDL') || $par->nelem != 1); $par .= 1.0; } else { $par = pdl(1.0); } my $diagonal = $out->diagonal(0,1); my($col,$row); for $col(0..$n1) { for $row(1..$n1) { my($klim) = $row<$col ? $row : $col; if($klim > 0) { $klim--; my($el) = $out->index2d($col,$row); $el -= ( $out->slice("($col),0:$klim") * $out->slice("0:$klim,($row)") )->sumover; } } # Figure a_ij, with no pivoting if($col < $n1) { # Divide the rest of the column by the diagonal element my $tmp; # work around for perl -d "feature" ($tmp = $out->slice("($col),".($col+1).":$n1")) /= $diagonal->index($col)->dummy(0,$n1-$col); } } # end of column loop if(wantarray) { return ($out,$perm,$par); } $out; } EOD ###################################################################### pp_add_exported('','lu_backsub'); pp_addpm(<<'EOD'); =head2 lu_backsub =for sig Signature: (lu(m,m); perm(m); b(m)) =for ref Solve A x = B for matrix A, by back substitution into A's LU decomposition. =for usage ($lu,$perm,$par) = lu_decomp($A); $x = lu_backsub($lu,$perm,$par,$A); # or $x = lu_backsub($lu,$perm,$B); # $par is not required for lu_backsub lu_backsub($lu,$perm,$B->inplace); # modify $B in-place $x = lu_backsub(lu_decomp($A),$B); # (ignores parity value from lu_decomp) # starting from square matrix A and columns matrix B, with mathematically # correct dimensions $A = identity(4) + ones(4, 4); $A->slice('2,0') .= 0; # break symmetry to see if need transpose $B = sequence(2, 4); # all these functions take B as rows, interpret as though notional columns # mathematically confusing but can't change as back-compat and also # familiar to Fortran users, so just transpose inputs and outputs # using lu_backsub ($lu,$perm,$par) = lu_decomp($A); $x = lu_backsub($lu,$perm,$par, $B->transpose)->transpose; # or with Slatec LINPACK use PDL::Slatec; gefa($lu=$A->copy, $ipiv=null, $info=null); # 1 = do transpose because Fortran's idea of rows vs columns gesl($lu, $ipiv, $x=$B->transpose->copy, 1); $x = $x->inplace->transpose; # or with LAPACK use PDL::LinearAlgebra::Real; getrf($lu=$A->copy, $ipiv=null, $info=null); getrs($lu, 1, $x=$B->transpose->copy, $ipiv, $info=null); # again, need transpose $x=$x->inplace->transpose; # or with GSL use PDL::GSL::LINALG; LU_decomp(my $lu=$A->copy, my $p=null, my $signum=null); # $B and $x, first dim is because GSL treats as vector, higher dims thread # so we transpose in and back out LU_solve($lu, $p, $B->transpose, my $x=null); $x=$x->inplace->transpose; # proof of the pudding is in the eating: print $A x $x; =for description Given the LU decomposition of a square matrix (from L), C does back substitution into the matrix to solve C for given vector C. It is separated from the C method so that you can call the cheap C multiple times and not have to do the expensive LU decomposition more than once. C acts on single vectors and threads in the usual way, which means that it treats C<$y> as the I of the input. If you want to process a matrix, you must hand in the I of the matrix, and then transpose the output when you get it back. that is because pdls are indexed by (col,row), and matrices are (row,column) by convention, so a 1-D pdl corresponds to a row vector, not a column vector. If C<$lu> is dense and you have more than a few points to solve for, it is probably cheaper to find C with L, and just multiply C.) in fact, L works by calling C with the identity matrix. C is ported from section 2.3 of I. It is written in PDL but should probably be implemented in C. =cut *PDL::lu_backsub = \&lu_backsub; sub lu_backsub { my ($lu, $perm, $y, $par); print STDERR "lu_backsub: entering debug version...\n" if $PDL::debug; if(@_==3) { ($lu, $perm, $y) = @_; } elsif(@_==4) { ($lu, $perm, $par, $y) = @_; } barf("lu_backsub: LU decomposition is undef -- probably from a singular matrix.\n") unless defined($lu); barf("Usage: \$x = lu_backsub(\$lu,\$perm,\$y); all must be PDLs\n") unless(UNIVERSAL::isa($lu,'PDL') && UNIVERSAL::isa($perm,'PDL') && UNIVERSAL::isa($y,'PDL')); my $n = $y->dim(0); my $n1 = $n; $n1--; # Make sure threading dimensions are compatible. # There are two possible sources of thread dims: # # (1) over multiple LU (i.e., $lu,$perm) instances # (2) over multiple B (i.e., $y) column instances # # The full dimensions of the function call looks like # # lu_backsub( lu(m,m,X), perm(m,X), b(m,Y) ) # # where X is the list of extra LU dims and Y is # the list of extra B dims. We have several possible # cases: # # (1) Check that m dims are compatible my $ludims = pdl($lu->dims); my $permdims = pdl($perm->dims); my $bdims = pdl($y->dims); print STDERR "lu_backsub: called with args: \$lu$ludims, \$perm$permdims, \$y$bdims\n" if $PDL::debug; my $m = $ludims->slice("(0)"); # this is the sig dimension unless ( ($ludims->slice(0) == $m) and ($ludims->slice(1) == $m) and ($permdims->slice(0) == $m) and ($bdims->slice(0) == $m)) { barf "lu_backsub: mismatched sig dimensions"; } my $lunumthr = $ludims->dim(0)-2; my $permnumthr = $permdims->dim(0)-1; my $bnumthr = $bdims->dim(0)-1; unless ( ($lunumthr == $permnumthr) and ($ludims->slice("1:-1") == $permdims)->all ) { barf "lu_backsub: \$lu and \$perm thread dims not equal! \n"; } # (2) If X == Y then default threading is ok if ( ($bnumthr==$permnumthr) and ($bdims==$permdims)->all) { print STDERR "lu_backsub: have explicit thread dims, goto THREAD_OK\n" if $PDL::debug; goto THREAD_OK; } # (3) If X == (x,Y) then add x dummy to lu,perm # (4) If ndims(X) > ndims(Y) then must have #3 # (5) If ndims(X) < ndims(Y) then foreach # non-trivial leading dim in X (x0,x1,..) # insert dummy (x0,x1) into lu and perm # This means that threading occurs over all # leading non-trivial (not length 1) dims of # B unless all the thread dims are explicitly # matched to the LU dims. THREAD_OK: # Permute the vector and make a copy if necessary. my $out = $y->dummy(1,$y->dim(0))->index($perm->dummy(1)); $out = $out->sever if !$y->is_inplace; print STDERR "lu_backsub: starting with \$out" . pdl($out->dims) . "\n" if $PDL::debug; # Make sure threading over lu happens OK... if($out->ndims < $lu->ndims-1) { print STDERR "lu_backsub: adjusting dims for \$out" . pdl($out->dims) . "\n" if $PDL::debug; do { $out = $out->dummy(-1,$lu->dim($out->ndims+1)); } while($out->ndims < $lu->ndims-1); } ## Do forward substitution into L my $row; my $r1; for $row(1..$n1) { $r1 = $row-1; my $tmp; # work around perl -d "feature ($tmp = $out->index($row)) -= ($lu->slice("0:$r1,$row") * $out->slice("0:$r1") )->sumover; } ## Do backward substitution into U, and normalize by the diagonal my $ludiag = $lu->diagonal(0,1); { my $tmp; # work around for perl -d "feature" ($tmp = $out->index($n1)) /= $ludiag->index($n1)->dummy(0); # TODO: check threading } for ($row=$n1; $row>0; $row--) { $r1 = $row-1; my $tmp; # work around for perl -d "feature" ($tmp = $out->index($r1)) -= ($lu->slice("$row:$n1,$r1") * # TODO: check thread dims $out->slice("$row:$n1") )->sumover; ($tmp = $out->index($r1)) /= $ludiag->index($r1)->dummy(0); # TODO: check thread dims } if ($y->is_inplace) { $y->setdims([$out->dims]) if !PDL::all($y->shape == $out->shape); # assgn needs same shape $y .= $out; } $out; } EOD ###################################################################### ### simq ### # XXX Destroys a!!! # To use the new a again, must store both a and ips. pp_def("simq", HandleBad => 0, Pars => '[phys]a(n,n); [phys]b(n); [o,phys]x(n); int [o,phys]ips(n)', OtherPars => 'int flag;', GenericTypes => ['D'], Code => ' extern int simq( double *A, double *B, double *X, int n, int flag, int *IPS ); simq($P(a), $P(b), $P(x), $SIZE(n), $COMP(flag), $P(ips)); ', Doc => ' =for ref Solution of simultaneous linear equations, C. C<$a> is an C matrix (i.e., a vector of length C), stored row-wise: that is, C, where C. While this is the transpose of the normal column-wise storage, this corresponds to normal PDL usage. The contents of matrix a may be altered (but may be required for subsequent calls with flag = -1). C<$y>, C<$x>, C<$ips> are vectors of length C. Set C to solve. Set C to do a new back substitution for different C<$y> vector using the same a matrix previously reduced when C (the C<$ips> vector generated in the previous solution is also required). See also L, which does the same thing with a slightly less opaque interface. =cut '); ###################################################################### ### squaretotri ### # this doesn't need to be changed to support bad values # I could put 'HandleBad => 1', but it would just cause an # unnecessary increase (admittedly small) in the amount of # code # pp_def("squaretotri", Pars => 'a(n,n); b(m)', Code => ' register int mna=0, nb=0, ns = $SIZE (n); if($SIZE (m) != (ns * (ns+1))/2) { $CROAK("Wrong sized args for squaretotri"); } threadloop %{ loop(m) %{ $b() = $a(n0 => mna, n1 => nb); mna++; if(mna > nb) {mna = 0; nb ++;} %} %} ', Doc => ' =for ref Convert a symmetric square matrix to triangular vector storage. =cut ', ); pp_addpm({At=>'Bot'},<<'EOD'); =head1 AUTHOR Copyright (C) 2002 Craig DeForest (deforest@boulder.swri.edu), R.J.R. Williams (rjrw@ast.leeds.ac.uk), Karl Glazebrook (kgb@aaoepp.aao.gov.au). There is no warranty. You are allowed to redistribute and/or modify this work under the same conditions as PDL itself. If this file is separated from the PDL distribution, then the PDL copyright notice should be included in this file. =cut EOD pp_done(); PDL-2.074/Basic/MatrixOps/eigens.c0000644000175000017500000000622114160714722016465 0ustar osboxesosboxes/* eigens.c * * Eigenvalues and eigenvectors of a real symmetric matrix * * * * SYNOPSIS: * * int n; * double A[n*(n+1)/2], EV[n*n], E[n]; * void eigens( A, EV, E, n ); * * * * DESCRIPTION: * * The algorithm is due to J. vonNeumann. * - - * A[] is a symmetric matrix stored in lower triangular form. * That is, A[ row, column ] = A[ (row*row+row)/2 + column ] * or equivalently with row and column interchanged. The * indices row and column run from 0 through n-1. * * EV[] is the output matrix of eigenvectors stored columnwise. * That is, the elements of each eigenvector appear in sequential * memory order. The jth element of the ith eigenvector is * EV[ n*i+j ] = EV[i][j]. * * E[] is the output matrix of eigenvalues. The ith element * of E corresponds to the ith eigenvector (the ith row of EV). * * On output, the matrix A will have been diagonalized and its * orginal contents are destroyed. * * ACCURACY: * * The error is controlled by an internal parameter called RANGE * which is set to 1e-10. After diagonalization, the * off-diagonal elements of A will have been reduced by * this factor. * * ERROR MESSAGES: * * None. * */ /* Copyright 1973, 1991 by Stephen L. Moshier Copyleft version. */ void eigens( A, RR, E, N ) double A[], RR[], E[]; int N; { int IND, L, LL, LM, M, MM, MQ, I, J, IA, LQ; int IQ, IM, IL, NLI, NMI; double ANORM, ANORMX, AIA, THR, ALM, ALL, AMM, X, Y; double SINX, SINX2, COSX, COSX2, SINCS, AIL, AIM; double RLI, RMI; double sqrt(), fabs(); static double RANGE = 1.0e-10; /*3.0517578e-5;*/ /* Initialize identity matrix in RR[] */ for( J=0; J ANORMX ) { THR=THR/N; do { /* while IND != 0 */ IND = 0; for( L=0; L M) IM=M+IQ; else IM=I+MQ; if(I >= L) IL=L+IQ; else IL=I+LQ; AIL=A[IL]; AIM=A[IM]; X=AIL*COSX-AIM*SINX; A[IM]=AIL*SINX+AIM*COSX; A[IL]=X; } NLI = N*L + I; NMI = N*M + I; RLI = RR[ NLI ]; RMI = RR[ NMI ]; RR[NLI]=RLI*COSX-RMI*SINX; RR[NMI]=RLI*SINX+RMI*COSX; } X=2.0*ALM*SINCS; A[LL]=ALL*COSX2+AMM*SINX2-X; A[MM]=ALL*SINX2+AMM*COSX2+X; A[LM]=(ALL-AMM)*SINCS+ALM*(COSX2-SINX2); } /* for M=L+1 to N-1 */ } /* for L=0 to N-2 */ } while( IND != 0 ); } /* while THR > ANORMX */ done: ; /* Extract eigenvalues from the reduced matrix */ L=0; for( J=1; J<=N; J++ ) { L=L+J; E[J-1]=A[L-1]; } } PDL-2.074/Basic/MatrixOps/eigen.h0000644000175000017500000000120314160714722016302 0ustar osboxesosboxes/* * eigen.c - calculation of eigen values and vectors. * * (C) Copyright 2001 by NetGroup A/S. All rights reserved. * * $Log$ * Revision 1.1 2006/06/20 15:57:22 djburke * Hopefully a saner way to build Basic/MatrixOps * * Revision 1.1 2005/01/08 09:22:57 zowie * Added non-symmetric matrices to eigens; updated version to 2.4.2cvs. * * Revision 1.1.1.1 2001/07/06 13:39:35 kneth * Initial import of code. * * */ #ifndef SSL_EIGEN_H_ #define SSL_EIGEN_H_ #include #include "complex.h" extern void Eigen(int, int, double **, int, double, int, complex double *, complex double **); #endif /* SSL_EIGEN_SSL */ PDL-2.074/Basic/MatrixOps/Makefile.PL0000644000175000017500000000071214160015533017012 0ustar osboxesosboxesuse strict; use warnings; use ExtUtils::MakeMaker; my @pack = (["matrixops.pd", qw(MatrixOps PDL::MatrixOps)]); my %hash = pdlpp_stdargs_int(@pack); $hash{OBJECT} = "" unless exists $hash{OBJECT}; foreach my $file (qw (eigens simq svd eigen matrix sslib)) { $hash{OBJECT} .= " $file\$(OBJ_EXT)"; } $hash{LIBS}->[0] .= " -lm "; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile( %hash ); PDL-2.074/Basic/MatrixOps/svd.c0000644000175000017500000001747614160714722016025 0ustar osboxesosboxes/* From bryant@sioux.stanford.edu Sat Apr 3 14:57:54 1993 Return-Path: Received: from sioux.stanford.edu by alnitak.usc.edu (4.1/SMI-4.1+ucs-3.6) id AA12724; Sat, 3 Apr 93 14:57:52 PST Received: from oglala.ice (oglala.Stanford.EDU) by sioux.stanford.edu (4.1/inc-1.0) id AA07300; Sat, 3 Apr 93 14:53:25 PST Date: Sat, 3 Apr 93 14:53:25 PST From: bryant@sioux.stanford.edu (Bryant Marks) Message-Id: <9304032253.AA07300@sioux.stanford.edu> To: ajayshah@rcf.usc.edu Subject: Re: SVD Status: ORr > Hi! Long ago you sent me an svd routine in C based on code > from Nash in Pascal. Has this changed any over the years? (Your > email is dated July 1992). Is your code available by anon ftp? Hi Ajay, I don't think I have changed the code -- but here's my most recent version of the code, you can check to see if it's any different. Currently it's not available via anonymous ftp but feel free to redistribute the code -- it seems to work well in the application I'm using it in. Bryant */ /* This SVD routine is based on pgs 30-48 of "Compact Numerical Methods for Computers" by J.C. Nash (1990), used to compute the pseudoinverse. Modifications include: Translation from Pascal to ANSI C. Array indexing from 0 rather than 1. Float replaced by double everywhere. Support for the Matrix structure. I changed the array indexing so that the matricies (float [][]) could be replaced be a single list (double *) for more efficient communication with Mathematica. */ /* rjrw 7/7/99: changed z back to a vector, moved one line... */ /* Derek A. Lamb 2016: added comments to aid understanding, since Nash's book will only get more difficult to find in the future. */ /* Form a singular value decomposition of matrix A which is stored in the first nRow*nCol elements of working array W. Upon return, the first nRow*nCol elements of W will become the product U x S of a thin svd, where S is the diagonal (rectangular) matrix of singular values. The last nCol*nCol elements of W will be the square matrix V of a thin svd. On return, Z will contain the squares of the singular values. The input matrix A is assumed to have nRows >= nCol. If it does not, one should input the transpose of A, A", to find the the svd of A, since A = U x S x V" and A" = V x S x U". (The " means transpose.) */ #include #define TOLERANCE 1.0e-22 #ifdef MAIN #include #define NC 2 #define NR 2 int main() { int i,j,n,m; double w[NC*(NR+NC)], z[NC*NC]; void SVD(double *W, double *Z, int nRow, int nCol); for (i=0;i=0) { cos(phi) = sqrt((v+q)/(2*v)); sin(phi) = p/(v*cos(phi)); } else if (q<0) {, (sgn(p)=+1 for p>=0, -1 for p<0); sin(phi) = sgn(p)*sqrt((v-q)/(2*v)); cos(phi) = p/(v*sin(phi)); } This formulation avoids the subtraction of two nearly equal numbers, which is bound to happen to q and v as the matrix approaches orthogonality. */ for (i=0; i= r) /* check if columns are ordered */ { /* columns are ordered, so try convergence test */ if (q<=e2*Z[0] || fabs(p)<=tol*q) RotCount--; /* There is no more work on this particular pair of columns in the current sweep. The first condition checks for very small column norms in BOTH columns, for which no rotation makes sense. The second condition determines if the inner product is small with respect to the larger of the columns, which implies a very small rotation angle. */ else {/* columns are in order, but their inner product is not small */ p /= q; r = 1 - r/q; vt = sqrt(4*p*p+r*r); /* DAL thinks the fabs is unnecessary in the next line: vt is non-negative; q>=r, r/q <=1 so after the assignment 0<= r <=1, so r/vt is positive, so everything inside the sqrt should be positive even without the fabs. abs isn't in Nash's book. c0 and s0 are cos(phi) and sin(phi) as above for q>=0*/ c0 = sqrt(fabs(.5*(1+r/vt))); s0 = p/(vt*c0); /* this little for loop (and the one below) is just rotation, inlined here for efficiency */ for (i=0; iq, and cannot be zero since both are sums of squares for the svd. In the case of a real symmetric matrix, this assumption must be questioned. */ p /= r; q = q/r-1; vt = sqrt(4*p*p+q*q); s0 = sqrt(fabs(.5*(1-q/vt))); /* DAL wondering about the fabs again, since after assignment q is <0 and vt is again positive, so everything inside the fabs should be positive already */ if (p<0) s0 = -s0; /*s0 and c0 are sin(phi) and cos(phi) as above for q<0 */ c0 = p/(vt*s0); for (i=0; i=3 && Z[(EstColRank-1)]<=Z[0]*tol+tol*tol) EstColRank--; } #if DEBUG if (SweepCount > slimit) fprintf(stderr, "Sweeps = %d\n", SweepCount); #endif } PDL-2.074/Basic/MatrixOps/matrix.h0000644000175000017500000000400014160714722016515 0ustar osboxesosboxes/* * matrix.h - misc. routines for manipulating matrices and solving linear * equations. Matrices are assumed to be declared as **double and * allocated by the function MatrixAlloc. A matrix can be freed by * MatrixFree. Similar for vectors. * * (C) Copyright 2001 by NetGroup A/S. All rights reserved. * * $Log$ * Revision 1.1 2006/06/20 15:57:22 djburke * Hopefully a saner way to build Basic/MatrixOps * * Revision 1.1 2005/01/08 09:22:57 zowie * Added non-symmetric matrices to eigens; updated version to 2.4.2cvs. * * Revision 1.1.1.1 2001/07/06 13:39:35 kneth * Initial import of code. * * */ #ifndef SSL_MATRIX_H_ #define SSL_MATRIX_H_ #include "sslib.h" #include extern double **MatrixAlloc(const int); extern double *VectorAlloc(const int); extern int *IntVectorAlloc(const int); extern complex double *SSL_ComplexVectorAlloc(const int); extern complex double **SSL_ComplexMatrixAlloc(const int); extern void MatrixMul(const int, double **, double **, double **); extern void Transpose(const int, double **, double **); extern void MatrixFree(const int, double **); extern void VectorFree(const int, double *); extern void IntVectorFree(const int, int *); extern void SSL_ComplexMatrixFree(const int, complex double **); extern void SSL_ComplexVectorFree(const int, complex double *); extern void LUfact(const int, double **, int *); extern void LUsubst(const int, double **, int *, double *); extern void GaussSeidel(const int, double **, double *, double *, double, int); extern void Jacobi(const int, double **, double *, double *, double, int); extern double DotProd(const int, double *, double *); extern void MatrixVecProd(const int, double **, double *, double *); extern void MatrixCopy(const int, double **, double **); extern void GSR(const int, double **); extern double L2VectorNorm(const int, double *); extern void InversMatrix(const int, double **, double **); #endif /* SSL_MATRIX_H_ */ PDL-2.074/Basic/PDL.pm0000644000175000017500000001405614200406207014072 0ustar osboxesosboxespackage PDL; use strict; use warnings; =head1 NAME PDL - the Perl Data Language =head1 DESCRIPTION (For the exported PDL constructor, pdl(), see L) PDL is the Perl Data Language, a perl extension that is designed for scientific and bulk numeric data processing and display. It extends perl's syntax and includes fully vectorized, multidimensional array handling, plus several paths for device-independent graphics output. PDL is fast, comparable and often outperforming IDL and MATLAB in real world applications. PDL allows large N-dimensional data sets such as large images, spectra, etc to be stored efficiently and manipulated quickly. =head1 VECTORIZATION For a description of the vectorization (also called "threading"), see L. =head1 INTERACTIVE SHELL The PDL package includes an interactive shell. You can learn about it, run C, or run the shell C or C and type C. =head1 LOOKING FOR A FUNCTION? If you want to search for a function name, you should use the PDL shell along with the "help" or "apropos" command (to do a fuzzy search). For example: pdl> apropos xval xlinvals X axis values between endpoints (see xvals). xlogvals X axis values logarithmicly spaced... xvals Fills an ndarray with X index values... yvals Fills an ndarray with Y index values. See the CAVEAT for xvals. zvals Fills an ndarray with Z index values. See the CAVEAT for xvals. To learn more about the PDL shell, see L or L. =head1 LANGUAGE DOCUMENTATION Most PDL documentation describes the language features. The number of PDL pages is too great to list here. The following pages offer some guidance to help you find the documentation you need. =over 5 =item L Frequently asked questions about PDL. This page covers a lot of questions that do not fall neatly into any of the documentation categories. =item L A guide to PDL's tutorial-style documentation. With topics from beginner to advanced, these pages teach you various aspects of PDL step by step. =item L A guide to PDL's module reference. Modules are organized by level (foundation to advanced) and by category (graphics, numerical methods, etc) to help you find the module you need as quickly as possible. =item L This page compiles PDL's tutorial and reference pages into a comprehensive course that takes you from a complete beginner level to expert. =item L List of all available documentation, sorted alphabetically. If you cannot find what you are looking for, try here. =back =head1 DATA TYPES PDL comes with support for most native numeric data types available in C. 2.027 added support for C99 complex numbers. See L, L and L for details on usage and behaviour. =head1 MODULES PDL includes about a dozen perl modules that form the core of the language, plus additional modules that add further functionality. The perl module "PDL" loads all of the core modules automatically, making their functions available in the current perl namespace. Some notes: =over 5 =item Modules loaded by default See the SYNOPSIS section at the end of this document for a list of modules loaded by default. =item L and L These are lighter-weight alternatives to the standard PDL module. Consider using these modules if startup time becomes an issue. =item Exports C exports a large number of routines into the calling namespace. If you want to avoid namespace pollution, you must instead C, and include any additional modules explicitly. =item L Note that the L syntax is NOT automatically loaded by C. If you want to use the extended slicing syntax in a standalone script, you must also say C. =item L The L module has been added to the list of modules for versions later than 2.3.1. Note that PDL::Math is still I included in the L and L start-up modules. =back =head1 SYNOPSIS use PDL; # Is equivalent to the following: use PDL::Core; use PDL::Ops; use PDL::Primitive; use PDL::Ufunc; use PDL::Basic; use PDL::Slices; use PDL::Bad; use PDL::MatrixOps; use PDL::Math; use PDL::IO::Misc; use PDL::IO::FITS; use PDL::IO::Pic; use PDL::IO::Storable; use PDL::Lvalue; =cut # set the version: our $VERSION = '2.074'; # Main loader of standard PDL package sub import { my $pkg = (caller())[0]; eval <<"EOD"; package $pkg; # Load the fundamental packages use PDL::Core; use PDL::Ops; use PDL::Primitive; use PDL::Ufunc; use PDL::Basic; use PDL::Slices; use PDL::Bad; use PDL::Math; use PDL::MatrixOps; use PDL::Lvalue; # for TPJ compatibility use PDL::IO::Misc; # Misc IO (Ascii) use PDL::IO::FITS; # FITS IO (rfits/wfits; used by rpic/wpic too) use PDL::IO::Pic; # rpic/wpic use PDL::Config; # so config/install info is available use PDL::IO::Storable; # to avoid mysterious Storable segfaults EOD die $@ if $@; } # support: use Inline with => 'PDL'; # Returns a hash containing parameters accepted by recent versions of # Inline, to tweak compilation. Not normally called by anyone but # the Inline API. # # If you're trying to debug the actual code, you're looking for "IFiles.pm" # which is currently in the Core directory. --CED 23-Feb-2015 sub Inline { require PDL::Install::Files; goto &PDL::Install::Files::Inline; } ################################################## # Rudimentary handling for multiple Perl threads # ################################################## our $no_clone_skip_warning = 0; sub CLONE_SKIP { warn <<'EOF' if !$no_clone_skip_warning; * If you need to share PDL data across threads, use memory mapped data, or * check out PDL::Parallel::threads, available on CPAN. * You can silence this warning by saying `$PDL::no_clone_skip_warning = 1;' * before you create your first thread. EOF $no_clone_skip_warning = 1; # always return 1 to tell Perl not to clone PDL data return 1; } 1; PDL-2.074/Basic/Bad/0000755000175000017500000000000014200406301013570 5ustar osboxesosboxesPDL-2.074/Basic/Bad/bad.pd0000644000175000017500000006441514167116774014705 0ustar osboxesosboxesuse strict; use warnings; use PDL::Types qw(ppdefs_all types); my $A = [ppdefs_all()]; my $AF = [map $_->ppsym, grep !$_->integer, types()]; # all including complex ######################################################### pp_addhdr(' #include #include "pdlperl.h" '); pp_add_exported( '', 'badflag check_badflag badvalue orig_badvalue nbad nbadover ngood ngoodover ' . 'setbadat ' ); ## Header pp_addpm({At=>'Top'},<<'!NO!SUBS!'); =head1 NAME PDL::Bad - PDL always processes bad values =head1 DESCRIPTION This module is loaded when you do C, C or C. Implementation details are given in L. =head1 SYNOPSIS use PDL::Bad; print "\nBad value per PDL support in PDL is turned " . $PDL::Bad::PerPdl ? "on" : "off" . ".\n"; =head1 VARIABLES =over 4 =item $PDL::Bad::UseNaN Set to 0 as of PDL 2.040, as no longer available, though NaN can be used as a badvalue for a given PDL object. =item $PDL::Bad::PerPdl Set to 1 as of PDL 2.040 as always available. =item $PDL::Bad::Status Set to 1 as of PDL 2.035 as always available. =back =cut !NO!SUBS! pp_addpm(<<'!NO!SUBS!'); # really should be constants $PDL::Bad::Status = 1; $PDL::Bad::UseNaN = 0; $PDL::Bad::PerPdl = 1; use strict; use PDL::Types; use PDL::Primitive; ############################################################ ############################################################ !NO!SUBS! # we want the following to be in PDL, not PDL::Bad, hence my $xshdr = "MODULE = PDL::Bad PACKAGE = PDL"; # # we want badflag() to avoid unnecessary calls to PDL->propagate_badflag(), # since it has to recurse through all the children of an ndarray # pp_addxs( <<"!WITH!SUBS!"); $xshdr int badflag(x,newval=0) pdl *x int newval CODE: if (items>1) { int oldval = ((x->state & PDL_BADVAL) > 0); if ( !newval && oldval ) { /* asked to unset, present value is set */ x->state &= ~PDL_BADVAL; PDL->propagate_badflag( x, 0 ); } else if ( newval && !oldval ) { /* asked to set, present value is unset */ x->state |= PDL_BADVAL; PDL->propagate_badflag( x, 1 ); } } RETVAL = ((x->state & PDL_BADVAL) > 0); OUTPUT: RETVAL !WITH!SUBS! pp_addpm(<<'!NO!SUBS!'); ############################################################ ############################################################ *badflag = \&PDL::badflag; *badvalue = \&PDL::badvalue; *orig_badvalue = \&PDL::orig_badvalue; ############################################################ ############################################################ =head2 badflag =for ref getter/setter for the bad data flag =for example if ( $x->badflag() ) { print "Data may contain bad values.\n"; } $x->badflag(1); # set bad data flag $x->badflag(0); # unset bad data flag When called as a setter, this modifies the ndarray on which it is called. This always returns a Perl scalar with the final value of the bad flag. A return value of 1 does not guarantee the presence of bad data in an ndarray; all it does is say that we need to I for the presence of such beasties. To actually find out if there are any bad values present in an ndarray, use the L method. =for bad This function works with ndarrays that have bad values. It always returns a Perl scalar, so it never returns bad values. =head2 badvalue =for ref returns the value used to indicate a missing (or bad) element for the given ndarray type. You can give it an ndarray, a PDL::Type object, or one of C<$PDL_B>, C<$PDL_S>, etc. =for example $badval = badvalue( float ); $x = ones(ushort,10); print "The bad data value for ushort is: ", $x->badvalue(), "\n"; This can act as a setter (e.g. C<< $x->badvalue(23) >>), including with the value C for floating-point types. Note that this B. That is, if C<$x> already has bad values, they will not be changed to use the given number and if any elements of C<$x> have that value, they will unceremoniously be marked as bad data. See L, L, and L for ways to actually modify the data in ndarrays It is possible to change the bad value on a per-ndarray basis, so $x = sequence (10); $x->badvalue (3); $x->badflag (1); $y = sequence (10); $y->badvalue (4); $y->badflag (1); will set $x to be C<[0 1 2 BAD 4 5 6 7 8 9]> and $y to be C<[0 1 2 3 BAD 5 6 7 8 9]>. =for bad This method does not care if you call it on an input ndarray that has bad values. It always returns a Perl scalar with the current or new bad value. =head2 orig_badvalue =for ref returns the original value used to represent bad values for a given type. This routine operates the same as L, except you can not change the values. It also has an I name. =for example $orig_badval = orig_badvalue( float ); $x = ones(ushort,10); print "The original bad data value for ushort is: ", $x->orig_badvalue(), "\n"; =for bad This method does not care if you call it on an input ndarray that has bad values. It always returns a Perl scalar with the original bad value for the associated type. =head2 check_badflag =for ref Clear the bad-value flag of an ndarray if it does not contain any bad values Given an ndarray whose bad flag is set, check whether it actually contains any bad values and, if not, clear the flag. It returns the final state of the bad-value flag. =for example print "State of bad flag == ", $pdl->check_badflag; =for bad This method accepts ndarrays with or without bad values. It returns an ndarray with the final bad-value. =cut *check_badflag = \&PDL::check_badflag; sub PDL::check_badflag { my $pdl = shift; $pdl->badflag(0) if $pdl->badflag and $pdl->nbad == 0; return $pdl->badflag; } # sub: check_badflag() !NO!SUBS! my $str = <<'EOF'; pdl * _badvalue_int(val, type) PDL_Anyval val int type CODE: { PDL_Anyval newval = {type, {0}}; pdl* p = PDL->scalar(newval); if (!p) PDL->pdl_barf("Error making new pdl"); if ( val.type != -1 ) { #define X(datatype, ctype, ppsym, shortctype, ...) \ ANYVAL_TO_CTYPE(PDL->bvals.shortctype, ctype, val); PDL_GENERICSWITCH(PDL_TYPELIST2_ALL, type, X, croak("Not a known data type code=%d", type)) #undef X } #define X(datatype, ctype, ppsym, shortctype, ...) \ *((ctype *)p->data) = PDL->bvals.shortctype; PDL_GENERICSWITCH(PDL_TYPELIST2_ALL, type, X, croak("Not a known data type code=%d", type)) #undef X RETVAL = p; } OUTPUT: RETVAL pdl * _badvalue_per_pdl_int(pdl_val, val, type) pdl* pdl_val PDL_Anyval val int type CODE: { PDL_Anyval newval = {type, {0}}; pdl* p = PDL->scalar(newval); if (!p) PDL->pdl_barf("Error making new pdl"); if ( val.type != -1) { pdl_val->badvalue = val; pdl_val->has_badvalue = 1; PDL->propagate_badvalue( pdl_val ); } if (pdl_val->has_badvalue == 0) { #define X(datatype, ctype, ppsym, shortctype, ...) \ *((ctype *)p->data) = PDL->bvals.shortctype; PDL_GENERICSWITCH(PDL_TYPELIST2_ALL, type, X, croak("Not a known data type code=%d", type)) #undef X } else { #define X(datatype, ctype, ...) \ ANYVAL_TO_CTYPE(*((ctype *)p->data), ctype, pdl_val->badvalue); PDL_GENERICSWITCH(PDL_TYPELIST2_ALL, type, X, croak("Not a known data type code=%d", type)) #undef X } RETVAL = p; } OUTPUT: RETVAL pdl * _default_badvalue_int(type) int type CODE: PDL_Anyval val = {type, {0}}; pdl* p = PDL->scalar(val); if (!p) PDL->pdl_barf("Error making new pdl"); #define X(datatype, ctype, ppsym, shortctype, defbval, ...) \ *((ctype *)p->data) = defbval; PDL_GENERICSWITCH(PDL_TYPELIST2_ALL, type, X, croak("Not a known data type code=%d", type)) #undef X RETVAL = p; OUTPUT: RETVAL EOF pp_addxs( "\n$xshdr\n\n$str\n" ); pp_addpm(<<'!NO!SUBS!'); # note: # if sent an ndarray, we have to change its bad values # (but only if it contains bad values) # - there's a slight overhead in that the badflag is # cleared and then set (hence propagating to all # children) but we'll ignore that) # - we can ignore this for float/double types # since we can't change the bad value # sub PDL::badvalue { no strict 'refs'; my ( $self, $val ) = @_; my $num; if ( UNIVERSAL::isa($self,"PDL") ) { $num = $self->get_datatype; if ( $num < $PDL_F && defined($val) && $self->badflag ) { $self->inplace->setbadtoval( $val ); $self->badflag(1); } return PDL::_badvalue_per_pdl_int($self, $val, $num); } elsif ( UNIVERSAL::isa($self,"PDL::Type") ) { $num = $self->enum; } else { # assume it's a number $num = $self; } PDL::_badvalue_int( $val, $num ); } sub PDL::orig_badvalue { no strict 'refs'; my $self = shift; my $num; if ( UNIVERSAL::isa($self,"PDL") ) { $num = $self->get_datatype; } elsif ( UNIVERSAL::isa($self,"PDL::Type") ) { $num = $self->enum; } else { # assume it's a number $num = $self; } PDL::_default_badvalue_int($num); } ############################################################ ############################################################ !NO!SUBS! pp_def('isbad' . <<'=cut', =head2 isbad =for sig Signature: (a(); int [o]b()) =for ref Returns a binary mask indicating which values of the input are bad values Returns a 1 if the value is bad, 0 otherwise. Similar to L. =for example $x = pdl(1,2,3); $x->badflag(1); set($x,1,$x->badvalue); $y = isbad($x); print $y, "\n"; [0 1 0] =for bad This method works with input ndarrays that are bad. The output ndarray will never contain bad values, but its bad value flag will be the same as the input ndarray's flag. =cut HandleBad => 1, Code => '$b() = 0;', BadCode => '$b() = $ISBAD(a());', CopyBadStatusCode => '', GenericTypes => $A, ); pp_def('isgood' . <<'=cut', =head2 isgood =for sig Signature: (a(); int [o]b()) =for ref Is a value good? Returns a 1 if the value is good, 0 otherwise. Also see L. =for example $x = pdl(1,2,3); $x->badflag(1); set($x,1,$x->badvalue); $y = isgood($x); print $y, "\n"; [1 0 1] =for bad This method works with input ndarrays that are bad. The output ndarray will never contain bad values, but its bad value flag will be the same as the input ndarray's flag. =cut HandleBad => 1, Code => '$b() = 1;', BadCode => '$b() = $ISGOOD(a());', CopyBadStatusCode => '', GenericTypes => $A, ); # perhaps these should have pm code which returns the # answer if the bad flag is not set pp_def('nbadover' . <<'=cut', =head2 nbadover =for sig Signature: (a(n); indx [o] b()) =for ref Find the number of bad elements along the 1st dimension. This function reduces the dimensionality of an ndarray by one by finding the number of bad elements along the 1st dimension. In this sense it shares much in common with the functions defined in L. In particular, by using L and similar dimension rearranging methods, it is possible to perform this calculation over I dimension. =for usage $x = nbadover($y); =for example $spectrum = nbadover $image->transpose =for bad nbadover processes input values that are bad. The output ndarray will not have any bad values, but the bad flag will be set if the input ndarray had its bad flag set. =cut HandleBad => 1, Code => '$b() = 0;', BadCode => q{ PDL_Indx cnt = 0; loop(n) %{ if ( $ISBAD(a()) ) { cnt++; } %} $b() = cnt; }, GenericTypes => $A, ); pp_def('ngoodover' . <<'=cut', =head2 ngoodover =for sig Signature: (a(n); indx [o] b()) =for ref Find the number of good elements along the 1st dimension. This function reduces the dimensionality of an ndarray by one by finding the number of good elements along the 1st dimension. By using L etc. it is possible to use I dimension. =for usage $x = ngoodover($y); =for example $spectrum = ngoodover $image->transpose =for bad ngoodover processes input values that are bad. The output ndarray will not have any bad values, but the bad flag will be set if the input ndarray had its bad flag set. =cut HandleBad => 1, Code => '$b() = (PDL_Indx) $SIZE(n);', BadCode => 'PDL_Indx cnt = 0; loop(n) %{ if ( $ISGOOD(a()) ) { cnt++; } %} $b() = cnt;', GenericTypes => $A, ); # Generate small ops functions to do entire array foreach my $op ( ['nbad','nbadover'], ['ngood','ngoodover'], ) { pp_addpm(<<"EOD"); *$op->[0] = \\&PDL::$op->[0]; sub PDL::$op->[0] { my(\$x) = \@_; my \$tmp; \$x->clump(-1)->$op->[1](\$tmp=PDL->nullcreate(\$x) ); return \$tmp; } EOD } # for $op pp_addpm(<<'!NO!SUBS!'); =head2 nbad =for ref Returns the number of bad values in an ndarray =for usage $x = nbad($data); =for bad Accepts good and bad input ndarrays; output is a Perl scalar and therefore is always good. =head2 ngood =for ref Returns the number of good values in an ndarray =for usage $x = ngood($data); =for bad Accepts good and bad input ndarrays; output is a Perl scalar and therefore is always good. =head2 setbadat =for ref Set the value to bad at a given position. =for usage setbadat $ndarray, @position C<@position> is a coordinate list, of size equal to the number of dimensions in the ndarray. This is a wrapper around L and is probably mainly useful in test scripts! =for example pdl> $x = sequence 3,4 pdl> $x->setbadat 2,1 pdl> p $x [ [ 0 1 2] [ 3 4 BAD] [ 6 7 8] [ 9 10 11] ] =for bad This method can be called on ndarrays that have bad values. The remainder of the arguments should be Perl scalars indicating the position to set as bad. The output ndarray will have bad values and will have its badflag turned on. =cut *setbadat = \&PDL::setbadat; sub PDL::setbadat { barf 'Usage: setbadat($pdl, $x, $y, ...)' if $#_<1; my $self = shift; PDL::Core::set_c ($self, [@_], $self->badvalue); $self->badflag(1); return $self; } !NO!SUBS! # NOTE: the Code section uses SETBAD # # have removed inplace stuff because: # $x->inplace->setbadif( $x % 2 ) # actually sets the badflag in a for ($x % 2) - this is # done inplace, and the flag cleared. Hence the setbadif() # call is NOT done inplace. # # Don't want to play around with inplace-type code to # try and fix this (doubt will be easy) # my %setbadif_extra = ( ); if ( 0 ) { ## ie if fix inplace issues $setbadif_extra{Inplace} = [ 'a' ]; $setbadif_extra{CopyBadStatusCode} = 'if ( a == b && $ISPDLSTATEGOOD(a) ) PDL->propagate_badflag( b, 1 ); /* propagate badflag if inplace */ $SETPDLSTATEBAD(b); /* always make sure the output is "bad" */ '; } else { # always make sure the output is "bad" $setbadif_extra{CopyBadStatusCode} = '$SETPDLSTATEBAD(b);'; } # note: have made the mask be an integer pp_def('setbadif' . <<'=cut', =head2 setbadif =for sig Signature: (a(); int mask(); [o]b()) =for ref Set elements bad based on the supplied mask, otherwise copy across the data. =for example pdl> $x = sequence(5,5) pdl> $x = $x->setbadif( $x % 2 ) pdl> p "a badflag: ", $x->badflag, "\n" a badflag: 1 pdl> p "a is\n$x" [ [ 0 BAD 2 BAD 4] [BAD 6 BAD 8 BAD] [ 10 BAD 12 BAD 14] [BAD 16 BAD 18 BAD] [ 20 BAD 22 BAD 24] ] Unfortunately, this routine can I be run inplace, since the current implementation can not handle the same ndarray used as C and C (eg C<< $x->inplace->setbadif($x%2) >> fails). Even more unfortunate: we can't catch this error and tell you. =for bad The output always has its bad flag set, even if it does not contain any bad values (use L to check whether there are any bad values in the output). The input ndarray can have bad values: any bad values in the input ndarrays are copied across to the output ndarray. Also see L and L. =cut HandleBad => 1, %setbadif_extra, Code => 'if ( $mask() ) { $SETBAD(b()); } else { $b() = $a(); }', BadCode => '/* if the bad value == 0 then all points are going to be selected ... */ if ( $ISBAD(mask()) || $mask() ) { $SETBAD(b()); } else { $b() = $a(); }', GenericTypes => $A, ); # pp_def: setbadif # this is useful because $x->setbadif( $x == 23 ) # is common and that can't be done inplace # # this doesn't need a BadCode section pp_def('setvaltobad' . <<'=cut', =head2 setvaltobad =for sig Signature: (a(); [o]b(); double value) =for ref Set bad all those elements which equal the supplied value. =for example $x = sequence(10) % 3; $x->inplace->setvaltobad( 0 ); print "$x\n"; [BAD 1 2 BAD 1 2 BAD 1 2 BAD] This is a simpler version of L, but this function can be done inplace. See L if you want to convert NaN to the bad value. =for bad The output always has its bad flag set, even if it does not contain any bad values (use L to check whether there are any bad values in the output). Any bad values in the input ndarrays are copied across to the output ndarray. =cut HandleBad => 1, Inplace => 1, CopyBadStatusCode => q{ if ( a == b && $ISPDLSTATEGOOD(a) ) PDL->propagate_badflag( b, 1 ); /* propagate badflag if inplace */ $SETPDLSTATEBAD(b); /* always make sure the output is "bad" */ }, Code => q[ if ( $a() == ($GENERIC(a)) $COMP(value) ) { $SETBAD(b()); } else { $b() = $a(); } ], GenericTypes => $A, ); # pp_def: setvaltobad pp_def('setnantobad' . <<'=cut', =head2 setnantobad =for sig Signature: (a(); [o]b()) =for ref Sets NaN values (for complex, where either is NaN) in the input ndarray bad (only relevant for floating-point ndarrays). Can be done inplace. =for usage $y = $x->setnantobad; $x->inplace->setnantobad; =for bad This method can process ndarrays with bad values: those bad values are propagated into the output ndarray. Any value that is not a number (before version 2.040 the test was for "not finite") is also set to bad in the output ndarray. If all values from the input ndarray are good, the output ndarray will B have its bad flag set. =cut HandleBad => 1, GenericTypes => $AF, Inplace => 1, CopyBadStatusCode => q{ /* note: not quite the normal check since set b bad within Code */ /* we propagate the bad flag even if a was originally bad since */ /* there is no easy way to pass this information around */ if ( a == b && $ISPDLSTATEBAD(b) ) PDL->propagate_badflag( b, 1 ); /* propagate badflag if inplace */ }, Code => q[ int flag = 0; threadloop %{ if ( PDL_ISNAN_$PPSYM()($a()) ) { $SETBAD(b()); flag = 1; } else { $b() = $a(); } %} if ( flag ) $PDLSTATESETBAD(b); ], ); # pp_def: setnantobad pp_def('setinftobad' . <<'=cut', =head2 setinftobad =for sig Signature: (a(); [o]b()) =for ref Sets non-finite values (for complex, where either is non-finite) in the input ndarray bad (only relevant for floating-point ndarrays). Can be done inplace. =for usage $y = $x->setinftobad; $x->inplace->setinftobad; =for bad This method can process ndarrays with bad values: those bad values are propagated into the output ndarray. Any value that is not finite is also set to bad in the output ndarray. If all values from the input ndarray are finite, the output ndarray will B have its bad flag set. =cut HandleBad => 1, GenericTypes => $AF, Inplace => 1, CopyBadStatusCode => q{ /* note: not quite the normal check since set b bad within Code */ /* we propagate the bad flag even if a was originally bad since */ /* there is no easy way to pass this information around */ if ( a == b && $ISPDLSTATEBAD(b) ) PDL->propagate_badflag( b, 1 ); /* propagate badflag if inplace */ }, Code => q[ int flag = 0; threadloop %{ if ( !PDL_ISFINITE_$PPSYM()($a()) && !PDL_ISNAN_$PPSYM()($a()) ) { $SETBAD(b()); flag = 1; } else { $b() = $a(); } %} if ( flag ) $PDLSTATESETBAD(b); ], ); # pp_def: setinftobad pp_def('setnonfinitetobad' . <<'=cut', =head2 setnonfinitetobad =for sig Signature: (a(); [o]b()) =for ref Sets non-finite values (for complex, where either is non-finite) in the input ndarray bad (only relevant for floating-point ndarrays). Can be done inplace. =for usage $y = $x->setnonfinitetobad; $x->inplace->setnonfinitetobad; =for bad This method can process ndarrays with bad values: those bad values are propagated into the output ndarray. Any value that is not finite is also set to bad in the output ndarray. If all values from the input ndarray are finite, the output ndarray will B have its bad flag set. =cut HandleBad => 1, GenericTypes => $AF, Inplace => 1, CopyBadStatusCode => q{ /* note: not quite the normal check since set b bad within Code */ /* we propagate the bad flag even if a was originally bad since */ /* there is no easy way to pass this information around */ if ( a == b && $ISPDLSTATEBAD(b) ) PDL->propagate_badflag( b, 1 ); /* propagate badflag if inplace */ }, Code => q[ int flag = 0; threadloop %{ if ( !PDL_ISFINITE_$PPSYM()($a()) ) { $SETBAD(b()); flag = 1; } else { $b() = $a(); } %} if ( flag ) $PDLSTATESETBAD(b); ], ); # pp_def: setnonfinitetobad pp_def('setbadtonan' . <<'=cut', =head2 setbadtonan =for sig Signature: (a(); [o] b();) =for ref Sets Bad values to NaN This is only relevant for floating-point ndarrays. The input ndarray can be of any type, but if done inplace, the input must be floating point. =for usage $y = $x->setbadtonan; $x->inplace->setbadtonan; =for bad This method processes input ndarrays with bad values. The output ndarrays will not contain bad values (insofar as NaN is not Bad as far as PDL is concerned) and the output ndarray does not have its bad flag set. As an inplace operation, it clears the bad flag. =cut HandleBad => 1, GenericTypes => $AF, Inplace => 1, CopyBadStatusCode => q{ /* propagate cleared badflag if inplace */ if ( a == b ) PDL->propagate_badflag( b, 0 ); /* always make sure the output is "good" */ $SETPDLSTATEGOOD(b); }, Code => q{ if ( $ISBAD(a()) ) { $b() = $TFDEGCH(NAN,NAN,NAN,NAN+I*NAN,NAN+I*NAN,NAN+I*NAN); } else { $b() = $a(); } }, ); # pp_def: setbadtonan # renamed replacebad by setbadtoval pp_def('setbadtoval' . <<'=cut', =head2 setbadtoval =for sig Signature: (a(); [o]b(); double newval) =for ref Replace any bad values by a (non-bad) value. Can be done inplace. Also see L. =for example $x->inplace->setbadtoval(23); print "a badflag: ", $x->badflag, "\n"; a badflag: 0 =for bad The output always has its bad flag cleared. If the input ndarray does not have its bad flag set, then values are copied with no replacement. =cut HandleBad => 1, Inplace => 1, Code => '$b() = $a();', BadCode => q{ $GENERIC(b) replace = ($GENERIC(b)) $COMP(newval); $GENERIC(b) a_val; threadloop %{ a_val = $a(); if ( $ISBADVAR(a_val,a) ) { $b() = replace; } else { $b() = a_val; } %} }, CopyBadStatusCode => q{ /* propagate badflag if inplace AND its changed */ if ( a == b && $ISPDLSTATEBAD(a) ) PDL->propagate_badflag( b, 0 ); /* always make sure the output is "good" */ $SETPDLSTATEGOOD(b); }, GenericTypes => $A, ); # pp_def: setbadtoval pp_def('copybad'.<<'=cut', =head2 copybad =for sig Signature: (a(); mask(); [o]b()) =for ref Copies values from one ndarray to another, setting them bad if they are bad in the supplied mask. Can be done inplace. =for example $x = byte( [0,1,3] ); $mask = byte( [0,0,0] ); $mask->badflag(1); set($mask,1,$mask->badvalue); $x->inplace->copybad( $mask ); p $x; [0 BAD 3] It is equivalent to: $c = $x + $mask * 0 =for bad This handles input ndarrays that are bad. If either C<$x> or C<$mask> have bad values, those values will be marked as bad in the output ndarray and the output ndarray will have its bad value flag set to true. =cut HandleBad => 1, Inplace => [ 'a' ], Code => '$b() = $a();', BadCode => q{ if ( $ISBAD(mask()) ) { $SETBAD(b()); } else { $b() = $a(); } }, CopyBadStatusCode => q{ if ( $BADFLAGCACHE() ) { if ( a == b && $ISPDLSTATEGOOD(a) ) { /* have inplace op AND badflag has changed */ PDL->propagate_badflag( b, 1 ); } $SETPDLSTATEBAD(b); } }, GenericTypes => $A, ); # pp_def: copybad pp_def('locf', Pars => 'a(n); [o]b(n);', HandleBad => 1, GenericTypes => $A, Doc => <<'EOF', =for ref Last Observation Carried Forward - replace every BAD value with the most recent non-BAD value prior to it. Any leading BADs will be set to 0. EOF Code => q{ $GENERIC() tmp = 0; loop(n) %{ if ( $ISGOOD(a()) ) tmp = $a(); $b() = tmp; %} }, ); ######################################################### pp_addpm({At=>'Bot'},<<'!WITHOUT!SUBS!'); =head1 AUTHOR Doug Burke (djburke@cpan.org), 2000, 2001, 2003, 2006. The per-ndarray bad value support is by Heiko Klein (2006). CPAN documentation fixes by David Mertens (2010, 2013). 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 !WITHOUT!SUBS! ## End pp_done(); PDL-2.074/Basic/Bad/Makefile.PL0000644000175000017500000000054214163275513015564 0ustar osboxesosboxesuse strict; use warnings; use ExtUtils::MakeMaker; use File::Spec::Functions; my @pack = (["bad.pd",qw(Bad PDL::Bad)]); my %hash = pdlpp_stdargs_int(@pack); $hash{depend} = { 'Bad$(OBJ_EXT)' => catfile(updir, qw(Core pdlperl.h)) }; undef &MY::postamble; # suppress warning *MY::postamble = sub { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); PDL-2.074/INTERNATIONALIZATION0000644000175000017500000000067113460433355015075 0ustar osboxesosboxesTODO PDL currently does not have internationalization support for its error messages although perl itself does support i18n and locales. Some of the tests for names and strings are specific to ASCII and English. Please report any issues regarding internationalization to the perldl mailing lists. Of course, volunteers to implement this or help with the translations would be welcome. We need to see how other perl modules handle this. PDL-2.074/META.json0000644000175000017500000000514014200406302013503 0ustar osboxesosboxes{ "abstract" : "Perl Data Language", "author" : [ "PerlDL Developers " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.44, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "PDL", "no_index" : { "directory" : [ "t", "inc" ], "file" : [ "Doc/scantree.pl" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0", "File::Path" : "0" } }, "configure" : { "recommends" : { "ExtUtils::F77" : "1.10", "PGPLOT" : "0" }, "requires" : { "Carp" : "1.2", "Devel::CheckLib" : "1.01", "ExtUtils::Depends" : "0.402", "ExtUtils::MakeMaker" : "7.12", "ExtUtils::ParseXS" : "3.01", "File::Path" : "0" } }, "runtime" : { "recommends" : { "ExtUtils::F77" : "1.26", "Inline" : "0.83", "Inline::C" : "0.62", "OpenGL" : "0.70", "OpenGL::GLUT" : "0.72", "Term::ReadKey" : "2.34" }, "requires" : { "Data::Dumper" : "2.121", "File::Map" : "0.57", "File::Which" : "0", "Filter::Simple" : "0.88", "Filter::Util::Call" : "0", "List::Util" : "1.33", "Math::Complex" : "0", "Pod::Parser" : "0", "Pod::Select" : "0", "Scalar::Util" : "0", "Storable" : "1.03", "Text::Balanced" : "1.89", "perl" : "5.010" }, "suggests" : { "Astro::FITS::Header" : "0" } }, "test" : { "requires" : { "CPAN::Meta" : "2.120900", "IPC::Cmd" : "0.72", "Test::Deep" : "0", "Test::Exception" : "0", "Test::Warn" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/PDLPorters/pdl/issues" }, "homepage" : "http://pdl.perl.org/", "repository" : { "type" : "git", "url" : "git://github.com/PDLPorters/pdl.git", "web" : "https://github.com/PDLPorters/pdl" }, "x_IRC" : "irc://irc.perl.org/#pdl" }, "version" : "2.074", "x_serialization_backend" : "JSON::PP version 4.04" } PDL-2.074/DEVELOPMENT0000644000175000017500000001451214146003631013601 0ustar osboxesosboxesThis file has some information on how to get access to the latest PDL sources (mainly of interest for potential developers). This should not be confused with the latest public release which will always be available from CPAN (if you don't know what that is check the FAQ). Public Git repository -------------------------------------------- From version PDL-2.4.4 onwards the source distribution is in a publicly accessible Git repository. From version PDL-2.019 onwards the project is hosted at the GitHub site at https://github.com/PDLPorters/pdl See Basic/Pod/FAQ.pod section 4.9 for instructions on this. If you do not know how to use Git try 'man git' or have a look at some of the online tutorials available on the web. The main Git home page is at http://www.git-scm.org/ and two good online Git references are the Git User's Manual at http://www.kernel.org/pub/software/scm/git/docs/user-manual.html and Git Magic at http://www-cs-students.stanford.edu/~blynn/gitmagic/ PDL Developer Guidelines: ------------------------- The following guidelines are for any developer that has access to the PDL Git repository. 1) Before committing a change with new files to the repository you should update: - MANIFEST (if files were added, using 'make manifest') - MANIFEST.SKIP (if applicable) 2) Make sure you add a test case in the 't' directory for any significant additional capability you add to PDL. Please use Test::More or one the of the Test modules available via perl modules rather than doing-it-yourself! 3) Please include POD documentation for any functions you add to the distribution. - See Basic/Core/Core.pm for an example of including POD documentation in .pm files. - See Basic/Core/Primitive/Primitive.pd for an example of including POD documentation in PDL .pd files. - read the documentation in PDL::Doc for a detailed description of the PDL documentation conventions. 4) Don't commit before you successfully built and passed 'make test'. 5) Bugs reported on the list should be entered into the bug database and bugs closed when a patch has been committed as a fix. (Primary responsibility for this task is the pumpking, but other devels should be able to help.) PDL Developer Recommended Workflow: ----------------------------------- See Basic/Pod/FAQ.pod section 4.11 for instructions on this. PDL Developer Notes: -------------------- A (small) collection of random musings to note if you feel the need to improve or add to PDL (please do): *) git supports file-by-file commits so it is helpful to commit your changes to git a little at a time where each commit corresponds to a single change. This makes it easy in the log to determine what was done and to locate any desired commit in case of issues that need to be resolved. *) Need help? See the pdl-devel email list; details for subscription and access to the archives can be found on the PDL web page at: http://pdl.perl.org/?page=mailing-lists *) Access to PDL's configuration If you need to access the configuration for PDL then use the %PDL::Config variable. Prior to 2.4.1 this was a mess since you had to use %PDL_CONFIG within Makefile.PL and PDL::Config from *.pm/tests. The build process has been changed (I hesitate to say "cleaned up" ;) to just use %PDL::Config consistently throughout. - %PDL::Config is automatically available to you when you are in a Makefile.PL within the PDL distribution. You can change the hash and these changes will be stored in the PDL::Config module. You should only change values when it makes sense (e.g. if the user has specified that a module should be built but you find out this is not possible). - use PDL; now loads PDL::Config by default - Otherwise you can say 'use PDL::Config;' or - perhaps something like eval 'require "' . whereami_any() . '/Core/Config.pm";'; where whereami_any() is from PDL::Core::Dev; ------------------------------------------------------------- Notes on transferring an external PDL module to the PDL source tree for distribution with PDL. ------------------------------------------------------------- Suppose you have developed a PDL module that resides in a standalone source tree. You typically will need to have PDL installed on your system before you can build this module. If you wish to migrate the module into the PDL distribution you will need to make certain changes to the module source in order to built in the PDL distribution. You will need to removed dependecies on a pre-existing PDL installation for configuration and build of your module. This is because as part of the PDL distribution, it is possible that PDL has never been installed. Build processes based on PDL will then fail. Following is some specific advice that can help you do this. [ These notes are very preliminary and are expected to be ] [ revised and/or replaced by improved documentation. ] Changes that must be made to files in your module source tree if you are building the module from a .pd file : Makefile.PL: -- You must remove the line 'use PDL::Core::Dev;'. -- The line 'PDL::Core::Dev->import();' must be present -- You must change the call from 'pdlpp_postamble' to a call to 'pdlpp_postamble_int' (with the same arguments.) -- It seems that most modules in the PDL source use VERSION_FROM => '../../Basic/PDL.pm', but not all of them in order that their version tracks the PDL release version. It is possible to maintain separate versioning even within the PDL source tree but it may make things confusing. Make certain that you make these changes to each 'Makefile.PL' in your source tree. Changes to the existing PDL source tree: -- Edit the 'Makefile.PL' in the directory above your module source to add your module directory name to 'DIR => [ qw/Module1 AnotherModule / ]'. -- Add your test files (.t files) to the PDL/t directory renaming if required to avoid namespace conflicts. -- Does your module depend on any libraries or external programs ? If so, doocument the required programs with version numbers in PDL/DEPENDENCIES and add the PREREQ_* option to the main Makefile.PL if required. -- If your module requires external libraries or header files, add a section to perldl.conf. The hash values with be available in your module's 'Makefile.PL' as $PDL::Config{WITH_MYMODULE},... PDL-2.074/Example/0000755000175000017500000000000014200406301013454 5ustar osboxesosboxesPDL-2.074/Example/Fit/0000755000175000017500000000000014200406301014176 5ustar osboxesosboxesPDL-2.074/Example/Fit/lmfit_example.pl0000644000175000017500000000534214146003631017375 0ustar osboxesosboxesuse PDL; use PDL::Math; use PDL::Fit::LM; use strict; ### fit using pdl's lmfit (Marquardt-Levenberg non-linear least squares fitting) ### ### `lmfit' Syntax: ### ### ($ym,$finalp,$covar,$iters) ### = lmfit $x, $y, $sigma, \&fn, $initp, {Maxiter => 300, Eps => 1e-3}; ### ### Explanation of variables ### ### OUTPUT ### $ym = pdl of fitted values ### $finalp = pdl of parameters ### $covar = covariance matrix ### $iters = number of iterations actually used ### ### INPUT ### $x = x data ### $y = y data ### $sigma = ndarray of y-uncertainties for each value of $y (can be set to scalar 1 for equal weighting) ### \&fn = reference to function provided by user (more on this below) ### $initp = initial values for floating parameters ### (needs to be explicitly set prior to use of lmfit) ### Maxiter = maximum iterations ### Eps = convergence criterion (maximum normalized change in Chi Sq.) ### Example: # make up experimental data: my $xdata = pdl sequence 5; my $ydata = pdl [1.1,1.9,3.05,4,4.9]; # set initial prameters in a pdl (order in accord with fit function below) my $initp = pdl [0,1]; # Weight all y data equally (else specify different uncertainties in a pdl) my $sigma = 1; # Use lmfit. Fourth input argument is reference to user-defined # subroutine ( here \&linefit ) detailed below. my ($yf,$pf,$cf,$if) = lmfit $xdata, $ydata, $sigma, \&linefit, $initp; # Note output print "\nXDATA\n$xdata\nY DATA\n$ydata\n\nY DATA FIT\n$yf\n\n"; print "Slope and Intercept\n$pf\n\nCOVARIANCE MATRIX\n$cf\n\n"; print "NUMBER ITERATIONS\n$if\n\n"; # simple example of user defined fit function. Guidelines included on # how to write your own function subroutine. sub linefit { # leave this line as is my ($x,$par,$ym,$dyda) = @_; # $m and $c are fit parameters, internal to this function # call them whatever make sense to you, but replace (0..1) # with (0..x) where x is equal to your number of fit parameters # minus 1 my ($m,$c) = map { $par->slice("($_)") } (0..1); # Write function with dependent variable $ym, # independent variable $x, and fit parameters as specified above. # Use the .= (dot equals) assignment operator to express the equality # (not just a plain equals) $ym .= $m * $x + $c; # Edit only the (0..1) part to (0..x) as above my (@dy) = map {$dyda -> slice(",($_)") } (0..1); # Partial derivative of the function with respect to first # fit parameter ($m in this case). Again, note .= assignment # operator (not just "equals") $dy[0] .= $x; # Partial derivative of the function with respect to next # fit parameter ($c in this case) $dy[1] .= 1; # Add $dy[ ] .= () lines as necessary to supply # partial derivatives for all floating parameters. } PDL-2.074/Example/TriD/0000755000175000017500000000000014200406301014316 5ustar osboxesosboxesPDL-2.074/Example/TriD/3dtest.pl0000644000175000017500000000053114166713036016101 0ustar osboxesosboxes#!/usr/bin/perl # # This program is a simple diagnostic example to # check if TriD imagrgb is working # use PDL; use PDL::NiceSlice; use PDL::Graphics::TriD; # $PDL::debug_trid=1; $PDL::Graphics::TriD::verbose //= 0; $im = sequence(640,480)/640.0/480.0; $im3 = $im->dummy(0,3); # print "\$im3 has dims of @{[$im3->dims()]}\n"; imagrgb $im3; PDL-2.074/Example/TriD/line3d.pl0000644000175000017500000000057614166713036016062 0ustar osboxesosboxes#!/usr/bin/perl # # This program is a simple diagnostic example to # check if TriD line3d is working # use PDL; use PDL::NiceSlice; use PDL::Graphics::TriD; # $PDL::debug_trid=1; $PDL::Graphics::TriD::verbose //= 0; $size = 25; $cz = (xvals zeroes $size+1) / $size; # interval 0..1 $cx = sin($cz*12.6); # Corkscrew $cy = cos($cz*12.6); line3d [$cx,$cy,$cz]; # Draw a line PDL-2.074/Example/TriD/old_trid_clip.pl0000644000175000017500000000561614014062163017501 0ustar osboxesosboxes#!/usr/local/bin/perl # # This is an example program from the legacy TriD/OpenGL/examples # directory moved here for reference. It only uses OpenGL features # so can probably be deprecated in favor of the Perl OpenGL # examples eventually. # # clip # # This program demonstrates arbitrary clipping planes. # Based on the "clip.c" program in the # OpenGL Programming Guide, Chapter 3, page 108, Listing 3-5. # However this program clips the front part of a rotating cube # with flat shaded faces instead of a wire frame sphere. # # the C synopsis of glClipPlane is # # void glClipPlane(GLenum plane,const GLdouble *equation ) # # For PERL the routine glpClipPlane was added, and the synopsis is: # # void glpClipPlane(GLenum plane,GLdouble a,GLdouble b,GLdouble c,GLdouble d) # # and the 4 double vector (equasion) is packaged by the XSUB. # Or you can still use glClipPlane but then you have to pack() the structure # # note: the statement f(@a) is equivalent to f($a[0],$a[1], ... $a[n]) # i.e. elements of a list are put on the call stack # use PDL::Graphics::OpenGL::Perl::OpenGL; use OpenGL qw(:all); sub tacky_cube { local($s) = @_; local(@x,@y,@z,@f); local($i,$j,$k); local(@r,@g,@b); $s = $s/2.0; @x=(-$s,-$s,-$s,-$s,$s,$s,$s,$s); @y=(-$s,-$s,$s,$s,-$s,-$s,$s,$s); @z=(-$s,$s,$s,-$s,-$s,$s,$s,-$s); @f=( 0, 1, 2, 3, 3, 2, 6, 7, 7, 6, 5, 4, 4, 5, 1, 0, 5, 6, 2, 1, 7, 4, 0, 3, ); @r=(1.0, 0, 0, 1.0, 1.0, 0); @g=(0, 1.0, 0, 1.0, 0, 1.0); @b=(0, 0, 1.0, 0, 1.0, 1.0); for($i=0;$i<6;$i++){ glColor3f($r[$i],$g[$i],$b[$i]); glBegin(GL_POLYGON); for($j=0;$j<4;$j++){ $k=$f[$i*4+$j]; glVertex3d($x[$k],$y[$k],$z[$k]); } glEnd(); } } sub add_clip_plane { # give the plane a slight tilt-away to prove we're not just # clipping against the view volume @eqn = (0.0, -0.3, -1.0, 1.2); OpenGL::glpClipPlane(GL_CLIP_PLANE0, @eqn); glEnable(GL_CLIP_PLANE0); } sub display{ glClear(GL_COLOR_BUFFER_BIT | GL_DEPTH_BUFFER_BIT); glPushMatrix(); glRotatef($spin, 0.0, 1.0, 0.0); tacky_cube(3.0); glPopMatrix(); glFlush(); glXSwapBuffers; } sub myReshape { # glViewport(0, 0, w, h); glMatrixMode(GL_PROJECTION); glLoadIdentity(); gluPerspective(60.0, 1.0 , 1.0, 20.0); glMatrixMode(GL_MODELVIEW); glLoadIdentity (); } OpenGL::glpOpenWindow(width => 400, height => 400, attributes => [GLX_RGBA,GLX_DOUBLEBUFFER]); glClearColor(0,0,0,1); glShadeModel (GL_FLAT); myReshape(); glDisable(GL_CULL_FACE); glEnable(GL_DEPTH_TEST); glLoadIdentity (); glTranslatef (0.0, 0.0, -5.0); add_clip_plane; # test glGetClipPlane() ($x,$y,$c,$d)=OpenGL::glpGetClipPlane(GL_CLIP_PLANE0); print "Clipping plane (x,y,c,d) = ($x,$y,$c,$d)\n"; $spin=0; while(1) {$spin += 1.0; display;} PDL-2.074/Example/doc-pp0000755000175000017500000000137314160015533014600 0ustar osboxesosboxes#!/usr/bin/env perl die "Usage: $0 outfile\n" if !@ARGV; use strict; use warnings; use PDL::PP; use Graph; use GraphViz2; my $g = Graph->new; # should really be hypergraph but GraphViz2 not do yet for my $r (@{$PDL::PP::deftbl}) { for my $t (@{$r->{targets}}) { $g->add_vertex($t); $g->add_edge($t, $_) for map s/_//gr, @{$r->{conditions}||[]}; } } my ($fmt) = $ARGV[0] =~ /\.([^.]+)$/; $g->set_graph_attribute(graphviz=>{graph=>{rankdir=>'LR'}}); GraphViz2->from_graph($g)->run(format=>$fmt,output_file=>$ARGV[0]); =head1 NAME doc-pp - Generate graph of pp_def key dependencies with graphviz =head1 SYNOPSIS doc-pp deps.svg =head1 DESCRIPTION Uses L and L to visualise the dependencies between keys in L. PDL-2.074/Example/InlinePdlpp/0000755000175000017500000000000014200406301015672 5ustar osboxesosboxesPDL-2.074/Example/InlinePdlpp/inlppminimal.pl0000644000175000017500000000102414014062163020724 0ustar osboxesosboxesuse blib; # we're inside the dist tree use PDL; # this must be called before (!) 'use Inline Pdlpp' calls use PDL::NiceSlice; # only used to demonstrate how to switch off below use Inline Pdlpp; # the actual code is in the __Pdlpp__ block below $x = sequence 10; print $x(0:4),"\n"; print $x->inc->(0:4),"\n"; # important! no PDL::NiceSlice; # disable NiceSlice before(!) the data section __END__ __Pdlpp__ # a silly function, really ;) pp_def('inc', Pars => 'i();[o] o()', Code => '$o() = $i() + 1;', ); PDL-2.074/Example/InlinePdlpp/Module/0000755000175000017500000000000014200406301017117 5ustar osboxesosboxesPDL-2.074/Example/InlinePdlpp/Module/MyInlineMod.pm0000644000175000017500000000475314165670147021677 0ustar osboxesosboxes# Below is the stub of documentation for your module. You better edit it! =head1 NAME PDL::MyInlineMod - a simple PDL module containing inlined Pdlpp code =head1 SYNOPSIS use PDL::MyInlineMod; $x = zeroes 10, 10; $twos = $x->plus2; # a simple function =head1 DESCRIPTION A simple example module that demonstrates the usage of inlined Pdlpp in a module that can be installed in the usual way. =head1 FUNCTIONS =cut package PDL::MyInlineMod; use strict; use warnings; require PDL::Exporter; our @ISA = qw(PDL::Exporter); # functions you want to export into the caller's name space our @EXPORT_OK = qw(myinc plus2); our %EXPORT_TAGS = (Func=>[@EXPORT_OK]); our $VERSION; BEGIN { # in BEGIN to make sure we can use $VERSION in the # 'use Inline...' call below $VERSION = '0.60'; # Inline requires this to be a *string* that matches # /^\d\.\d\d$/ # see Inline-FAQ for more info } use PDL::LiteF; # quirk 1 follows use Inline::MakePdlppInstallable; # allow installation of this module use Inline Pdlpp => DATA => # inlined PP code is below in DATA section NAME => PDL::MyInlineMod, # required info for module installation VERSION => $VERSION; # ditto, see Inline-FAQ for more info # quirk 2 follows Inline->init; # you need this if you want to 'use' your module # from within perldl or pdl2 and your Pdlpp code # resides in the DATA section (as in this example) # following required to make exported functions work! # PDL::PP used to make these automatically but now we have # to make them manually since *we* are writing the pm-file *myinc = \&PDL::myinc; # make alias in this module's name space *plus2 = \&PDL::plus2; # ditto 1; __DATA__ __Pdlpp__ # some simple functions to test the whole thing =head2 myinc =for ref a very simple pp function that increments its argument =for sig myinc(i();[o] o()) =cut pp_def('myinc', Pars => 'i();[o] o()', Code => '$o() = $i() + 1;', ); =head2 plus2 =for ref a very simple pp function that increments its argument by 2 =for sig plus2(i();[o] o()) =cut pp_def('plus2', Pars => 'i();[o] o()', Code => '$o() = $i() + 2;', ); =head1 AUTHOR C. Soeller (C) 2002. All rights reserved. This code can be distributed under the same terms as PDL itself (see the file COPYING in the PDL distribution). =head1 SEE ALSO perl(1). L. L. PDL-2.074/Example/InlinePdlpp/Module/t/0000755000175000017500000000000014200406301017362 5ustar osboxesosboxesPDL-2.074/Example/InlinePdlpp/Module/t/myinlinemod.t0000644000175000017500000000027214165325070022111 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::MyInlineMod; use PDL::LiteF; my $x = zeroes 10; my $y = $x->myinc; ok all $y == 1; my $c = $x->plus2; ok all $c == 2; done_testing; PDL-2.074/Example/InlinePdlpp/Module/Makefile.PL0000644000175000017500000000051714014062163021103 0ustar osboxesosboxesuse strict; use warnings; use Inline::MakeMaker; # to allow us to install the inlined code ! # Note use of 'WriteInlineMakefile' in place of the normal # 'WriteMakefile' call! Syntax of args is identical to MakeMaker. WriteInlineMakefile( 'NAME' => 'PDL::MyInlineMod', 'VERSION_FROM' => 'MyInlineMod.pm', # finds $VERSION ); PDL-2.074/Example/InlinePdlpp/inlpp_link.pl0000644000175000017500000000200314014062163020370 0ustar osboxesosboxesuse blib; # when using inside the dist tree use PDL; # this must be called before (!) 'use Inline Pdlpp' calls # for this example you need the numerical recipes library # edit the INC and LIBS info below to point # Inline towards the location of include and library files use Inline Pdlpp => Config => INC => "-I$ENV{HOME}/include", LIBS => "-L$ENV{HOME}/lib -lnr -lm", AUTO_INCLUDE => <<'EOINC', #include #include "nr.h" /* for poidev */ #include "nrutil.h" /* for err_handler */ static void nr_barf(char *err_txt) { fprintf(stderr,"Now calling croak...\n"); croak("NR runtime error: %s",err_txt); } EOINC BOOT => 'set_nr_err_handler(nr_barf);'; # catch errors at the perl level use Inline Pdlpp; # the actual code is in the __Pdlpp__ block below $x = zeroes(10) + 30;; print $x->poidev(-3),"\n"; __DATA__ __Pdlpp__ # poisson deviates pp_def('poidev', Pars => 'xm(); [o] pd()', GenericTypes => [L,F,D], OtherPars => 'long idum', Code => '$pd() = poidev((float) $xm(), &$COMP(idum));', ); PDL-2.074/Example/InlinePdlpp/inlpp.pl0000644000175000017500000000124214014062163017357 0ustar osboxesosboxesuse blib; use PDL; # this must be called before (!) 'use Inline Pdlpp' calls use Inline Pdlpp; # the actual code is in the __Pdlpp__ block below $x = sequence 10; print $x->inc,"\n"; print $x->inc->dummy(1,10)->tcumul,"\n"; __DATA__ __Pdlpp__ # a rather silly increment function pp_def('inc', Pars => 'i();[o] o()', Code => '$o() = $i() + 1;', ); # a cumulative product # essentially the same functionality that is # already implemented by prodover # in the base distribution pp_def('tcumul', Pars => 'in(n); float+ [o] mul()', Code => '$mul() = 1; loop(n) %{ $mul() *= $in(); %}', ); PDL-2.074/Example/PGPLOT/0000755000175000017500000000000014200406301014461 5ustar osboxesosboxesPDL-2.074/Example/PGPLOT/pgplot.pl0000644000175000017500000002057413457205473016357 0ustar osboxesosboxes=head1 NAME std_pgplot - Examples of PGPLOT routines. =head1 SYNOPSIS std_pgplot.pl =head1 DESCRIPTION This file is intended to show the use of PGPLOT routines using the object-oriented approach. =cut use PDL; use PDL::Graphics::PGPLOT::Window; ## ## Test all PGPLOT routines. ## my $random = grandom(1000); my ($xc, $yc)=hist $random; my $x=zeroes(100)->xlinvals(-5,5); my $y=exp(-$x*$x/2); print "First we will test all functions in PGPLOT.\n"; print "We also will show most of the options\n"; print "After each plot - please press to proceed - type q to quit.\n"; function_to_do ('dev(), env(), hold(), release(), bin(), line()'); # # Create a window object to which we will subsequently plot. # my $w = PDL::Graphics::PGPLOT::Window->new({Device => '/xw', Aspect => 1, WindowWidth => 7}); # Note how we call the functions via the window object. This particular # call will set the axis colour to Red. $w->env(-5, 5, 0, max($yc)*1.1, {Axiscolour => 'Red'}); # Plot a histogram. $w->bin($xc, $yc); # Hold the plot. You can subsequently test whether the plot is held # by calling held() - which returns true (1) if the plot is held. $w->hold(); # This draws a line plot on top of the histogram. Note that you can # refer to options using only the first part of their name - and case # doesn't matter either. It is advised however to use the full name # for options since in some cases you could imagine getting the # wrong result. $w->line($x, $y*max($yc), {LineSty => 'Dashed', Color => 'Blue', LineWidth => 5}); # Release your connection so that the next plotting command will # erase the screen and create a new plot. $w->release(); # These two are just a convenience functions for this demo.. next_plot(); function_to_do ('errb() & points()'); # Create some more data - this time for plots with errorbars. my $xd = pdl(1,3,7,10); my $yd = pdl(2, 7,5,7); my $dy = sqrt($yd**2/12+0.2**2); # This is how you set titles on plots. If you forget to you can # use the label_axes() command (see below) to set them later. $w->env(0, 15, 0, 10, {Xtitle => 'X-data', Ytitle=>'Y-data', Title => 'An example of errb and points', Font => 'Italic'}); # Plot the data as points $w->points($xd, $yd); # Overplot (implicit) the points with error-bars. $w->errb($xd, $yd, $dy); $w->release(); next_plot(); function_to_do('line() poly(), cont(), label_axes() and text()'); # Create an image. my $im = rvals(100, 100); # Draw contours - and hold the plot because will clutter it some more. $w->cont($im, {NCOn => 4}); $w->hold(); # Note that the colours can be specified also in upper case. They can # also be referred to with numbers in keeping with the PGPLOT tradition. $w->line(pdl(0, 50), pdl(0, 50), {Color => 'RED'}); # The corners of a polygon - note that the last should be equal to the # first to get the expected results. my $px = pdl(20, 40, 40, 20, 20); my $py = pdl(80, 80, 100, 100, 80); # The poly function draws polygons - note that we set the fill using # the numerical notation here - this sets a hatched fill. $w->poly($px, $py, {Fill => 3}); # Pay attention to the hatching command as it sets the properties using # an anonymous hash again. I would normally construct this separately # and use a variable for this for readability. $w->poly($px, $py, {Color=>'Red', Fill => 3, Hatch => {Phase => 0.5}}); # label_axes() is a separate function to set the axis titles. This is # often clearer although less compact than setting it directly in the # env() function. $w->label_axes('X-direction', 'Y-direction', 'Title', {Color => 'Yellow'}); # The text() command puts text on the display and can be displayed using # different justifications, angles and fonts as well as colours. $w->text('Towards the centre', 24, 25, {Justification => 0.5, Angle=>45, Font => 'Italic'}); next_plot(); function_to_do('imag(), ctab(), hi2d and several panels'); # # We now create a new window for image display since we want several # panels in the plot window. This requires a new window to be created # at present - changes to the code welcome. # $w->close(); $w = PDL::Graphics::PGPLOT::Window->new({Device => '/xw', Aspect => 0.5, NX => 2, NY => 2, CharSize => 2}); # Display the image using a transform between the pixel coordinates # and the display coordinates. $w->imag($im, {Transform => pdl([0, 0.1, 0, 0, 0, 0.1])}); # This command will go in the next panel and will display the image using # a square root transfer function and square pixels (PIX => 1) $w->imag1($im, {PIX => 1, ITF=>'Sqrt'}); # You set the colour table using ctab() $w->ctab('Fire'); $w->imag($im); # A hold command in a multi-panel situation keeps you in the same panel. $w->hold(); # So that you can overplot a contour plot for instance... $w->cont($im, {Color => 'Yellow'}); $w->release(); # The hi2d() function draws a 2D histogram of the data and could very # likely be improved by someone with some extra time on their hands. $w->hi2d($im->slice('0:-1:10,0:-1:10')); next_plot(); function_to_do('Several plot windows. focus_window(), window_list()'); # # Multiple windows - the secret unveiled... Well, it is easy actually # at least when you use the OO interface! # $w->close(); my $w1 = PDL::Graphics::PGPLOT::Window->new({Device => '/xw', Aspect => 1, AxisColour => 'Blue', WindowName => 'First', WindowWidth => 6}); my $w2 = PDL::Graphics::PGPLOT::Window->new({Device => '/xw', Aspect => 0.618, AxisColour => 'Red', WindowWidth => 6}); # First draw something in Window 1 $w1->line($x, $x**2); $w1->hold(); # Then switch to window 2... my $ii = which($x>=0); $w2->points($x->index($ii), sqrt($x->index($ii))); $w2->hold(); $w2->line($x->index($ii), sqrt($x->index($ii)), {Color => 'Red', Linestyle => 'dashed'}); $w2->release(); # Switch back to window 1 - note how easier it is with the OO interface. $w1->points($x, $x**2+$x->grandom()); $w1->release(); # In the OO interface there is no built-in way to keep track of different # windows in the way that the non-OO interface does, but on the other hand # you don't really need it. # See the std_pgplot.pl file for an example of this. next_plot(); function_to_do('legend(), cursor()'); # Let's close Window2 and continue our examples in window 1. $w2->close(); # The legend function draws legends on plots which can be for different # symbols, linestyles, widths and mixtures. $w1->legend(['Parabola', 'Scatter points'], -2, 20, {Width => 5, LineStyle => ['Solid', undef], Symbol => [undef, 'Default']}); # # Now read the cursor - different types of cursor can be chosen print "Select a point using the cursor:\n"; my ($xp, $yp)=$w1->cursor({Type => 'CrossHair'}); print "(X, Y)=($xp, $yp)\n"; next_plot(); function_to_do('circle(), ellipse(), rectangle() and arrow()'); # The circle, ellipse and rectangle functions do not take note of the # intrinsic display aspect ratio so if you want a really round circle, # you must make sure that the aspect ratio is 1. $w1->close(); $w1 = PDL::Graphics::PGPLOT::Window->new({Device => '/xs', Aspect => 1, WindowWidth => 6}); $w1->env(0, 100, 0,100); # Draw a circle - at the moment the default fill-style is solid so we need # to specify the outline fill to get a non-filled circle.. $w1->circle(50, 50, 10, {Fill => 'Outline'}); # The ellipse can be specified with major and minor axis and the rotation # angle for the ellipse, but note that the angle must be specified in radians.. $w1->ellipse(40, 20, {MajorAxis => 30, MinorAxis=> 10, Theta => 30*3.14/180, Colour => 'Red'}); # The angle must be specified in radians for the rectangle too.... $w1->rectangle(70, 70, {XSide => 10, Angle => 45*3.14/180}); # And finally draw an arrow... $w1->arrow(40, 20, 70, 20, {Color => 'Green'}); next_plot(); $w1->close(); $w1 = PDL::Graphics::PGPLOT::Window->new({Device => '/xs', Aspect => 1, NX => 2, NY => 2}); $w1->line($x, $y); # The important thing here is to show that you can jump directly to a given # panel and start drawing in this.. $w1->bin($xc, $yc, {Panel => 3}); $w1->env(0, 1, 0, 1, {Axis => 'Box'}); $w1->text("That's all folks!", 0.5, 0.5, {Justification => 0.5, CharSize => 5, Color => 'Yellow'}); next_plot(); sub function_to_do { print "\n**************************\n"; print "* $_[0]\n"; print "**************************\n\n"; } sub next_plot { my $message = shift; $message ||=''; print $message."\n"; my $in = ; if ($in =~ /^q/i) { exit; } } PDL-2.074/Example/PGPLOT/std_pgplot.pl0000644000175000017500000001000713457205473017217 0ustar osboxesosboxes=head1 NAME std_pgplot - Examples of PGPLOT routines. =head1 SYNOPSIS std_pgplot.pl =head1 DESCRIPTION This file is intended to show the use of PGPLOT routines using the standard interface. See the C file for an object-oriented version of the same (the object-oriented interface is strongly recommended.) =cut use PDL; use PDL::Graphics::PGPLOT; ## ## Test all PGPLOT routines. ## my $random = grandom(1000); my ($xc, $yc)=hist $random; my $x=zeroes(100)->xlinvals(-5,5); my $y=exp(-$x*$x/2); print "First we will test all functions in PGPLOT.\n"; print "We also will show most of the options\n"; print "After each plot - please press to proceed - type q to quit.\n"; function_to_do ('dev(), env(), hold(), release(), bin(), line()'); my $win1 = dev('/xw', {Aspect => 1, WindowWidth => 7}); env(-5, 5, 0, max($yc)*1.1, {Axiscolour => 'Red'}); bin $xc, $yc; hold; line $x, $y*max($yc), {LineSty => 'Dashed', Color => 'Blue', LineWidth => 5}; release; #close_window($win); next_plot(); function_to_do ('errb() & points()'); my $xd = pdl(1,3,7,10); my $yd = pdl(2, 7,5,7); my $dy = sqrt($yd**2/12+0.2**2); env(0, 15, 0, 10, {Xtitle => 'X-data', Ytitle=>'Y-data', Title => 'An example of errb and points', Font => 'Italic'}); points $xd, $yd; errb $xd, $yd, $dy; release; next_plot(); function_to_do('line() poly(), cont(), label_axes() and text()'); my $im = rvals(100, 100); cont $im, {NCOn => 4}; hold; line pdl(0, 50), pdl(0, 50), {Color => 'RED'}; my $px = pdl(20, 40, 40, 20, 20); my $py = pdl(80, 80, 100, 100, 80); poly $px, $py, {Fill => 3}; poly $px, $py, {Color=>'Red', Fill => 3, Hatch => {Phase => 0.5}}; label_axes('X-direction', 'Y-direction', 'Title', {Color => 'Yellow'}); text 'Towards the centre', 24, 25, {Justification => 0.5, Angle=>45, Font => 'Italic'}; next_plot(); function_to_do('imag(), ctab(), hi2d and several panels'); $win1= dev('/xw', 2, 2, {Aspect => 0.5, CharSize => 2}); imag $im, {Transform => pdl([0, 0.1, 0, 0, 0, 0.1])}; imag1 $im, {PIX => 1, ITF=>'Sqrt'}; ctab('Fire'); imag $im; hold; cont $im, {Color => 'Yellow'}; release; hi2d $im->slice('0:-1:10,0:-1:10'); next_plot(); function_to_do('Several plot windows. focus_window(), window_list()'); close_window($win1); $win1 = dev('/xw', {Aspect => 1, AxisColour => 'Blue', WindowName => 'First', WindowWidth => 6}); my $win2 = dev('/xw', {Aspect => 0.618, AxisColour => 'Red', WindowWidth => 6, NewWindow => 1}); focus_window('First'); line $x, $x**2; hold; focus_window($win2); my $ii = which($x>=0); points $x->index($ii), sqrt($x->index($ii)); hold; line $x->index($ii), sqrt($x->index($ii)), {Color => 'Red', Linestyle => 'dashed'}; release; focus_window($win1); points $x, $x**2+$x->grandom(); release; my ($nums, $names)=window_list(); print "Window list:\n"; for (my $i=0; $i <= $#$nums; $i++) { print " $$nums[$i]: $$names[$i]\n"; } next_plot(); function_to_do('legend(), cursor()'); close_window($win2); legend ['Parabola', 'Scatter points'], -2, 20, {Width => 5, LineStyle => ['Solid', undef], Symbol => [undef, 'Default']}; print "Select a point using the cursor:\n"; my ($xp, $yp)=cursor({Type => 'CrossHair'}); print "(X, Y)=($xp, $yp)\n"; next_plot(); function_to_do('circle(), ellipse(), rectangle() and arrow()'); dev('/xs', {Aspect => 1, WindowWidth => 6}); env(0, 100, 0,100); circle(50, 50, 10, {Fill => 'Outline'}); ellipse(40, 20, {MajorAxis => 30, MinorAxis=> 10, Theta => 30*3.14/180, Colour => 'Red'}); rectangle(70, 70, {XSide => 10, Angle => 45*3.14/180}); next_plot(); close_window($win1); $win1 = dev('/xw', 2, 2, {Aspect => 1}); line $x, $y; bin $xc, $yc, {Panel => 3}; env(0, 1, 0, 1, {Axis => 'Box'}); text "That's all folks!", 0.5, 0.5, {Justification => 0.5, CharSize => 3, Color => 'Yellow'}; next_plot(); sub function_to_do { print "\n**************************\n"; print "* $_[0]\n"; print "**************************\n\n"; } sub next_plot { my $message = shift; $message ||=''; print $message."\n"; my $in = ; if ($in =~ /^q/i) { exit; } } PDL-2.074/Example/Simplex/0000755000175000017500000000000014200406301015075 5ustar osboxesosboxesPDL-2.074/Example/Simplex/tsimp_needs_pgplot.pl0000644000175000017500000000134514014062163021343 0ustar osboxesosboxes#use blib; use PDL; use PDL::Primitive; use PDL::Graphics::PGPLOT; use PDL::Opt::Simplex; use Carp; $SIG{__DIE__} = sub {print Carp::longmess(@_); die FOO}; # First, a 1-dimensional test: sub func1 { my($x) = @_; return ($x**2)->slice('(0)'); } sub logs1 { print "NOW: $_[0],$_[1]\n\n"; } simplex(ones(1)*10,0.3,0.01,15,\&func1,\&logs1); # Try a simple ellipsoid: my $mult = pdl 4,1; dev "/XSERVE"; env -15,5,-15,5; hold; sub func { my($x) = @_; my $y = ($mult * $x) ** 2; sumover($y,(my $res = null)); $res; } sub logs { print "NOW: $_[0],$_[1]\n\n"; line($_[0]->slice("(0)"),$_[0]->slice("(1)")); line($_[0]->slice("(0),0:2:2"),$_[0]->slice("(1),0:2:2")); } simplex(pdl(-10,-10), 0.5, 0.01, 30, \&func, \&logs ); PDL-2.074/Example/Simplex/tsimp2.pl0000644000175000017500000000372114014062163016662 0ustar osboxesosboxesuse PDL; use PDL::Opt::Simplex; # # Simplex Demo - Alison Offer (aro@aaocbn.aao.gov.au) # # # this is some sort of convergence criterion $minsize = 1.e-6; # max number of iterations ? $maxiter = 100; # # number of evaluation $count = 0; print " \n 1: least squares gaussian fit to data + noise \n 32 *exp (-((x-10)/6)^2) + noise 2: minimise polynomial \n (x-3)^2 + 2.*(x-3)*(y-2.5) + 3.*(y-2.5)^2 \n Please make your choice (1 or 2):"; chop($choice = <>); if ($choice == 1) { print "Please enter noise factor (small number, 0-6):"; chop($factor = <>); # # data : gaussian + noise # foreach $j (0..19) { $data[$j] = 32*exp(-(($j-10)/6)**2) + $factor * (rand() - 0.5); } # # initial guess - $initsize controls the size of the initial simplex (I think) # $init = pdl [ 33, 9, 12 ]; $initsize = 2; # # ($optimum,$ssize,$optval) = simplex($init,$initsize,$minsize,$maxiter, # this sub returns the function to be minimised. sub {my ($xv) =@_; my $x = $xv->slice("(0)"); my $y = $xv->slice("(1)"); my $c = $xv->slice("(2)"); $count += $x->dim(0); my $sum = $x * 0.0; foreach $j (0..19) { $sum += ($data[$j] - $x*exp(-(($j-$y)/$c)**2))**2; } return $sum; }); } else { $init = pdl [ 2 , 2 ]; $initsize = 2; ($optimum,$ssize,$optval) = simplex($init,$initsize,$minsize,$maxiter, sub {my ($xv) =@_; my $x = $xv->slice("(0)"); my $y = $xv->slice("(1)"); $count += $x->dim(0); return ($x-3)**2 + 2.*($x-3)*($y-2.5) + 3.*($y-2.5)**2; }); } print "N_EVAL = $count\n"; print "OPTIMUM = $optimum \n"; print "SSIZE = $ssize\n"; print "OPTVAL = $optval\n"; PDL-2.074/Example/Benchmark/0000755000175000017500000000000014200406301015346 5ustar osboxesosboxesPDL-2.074/Example/Benchmark/Bench.xs0000644000175000017500000000200114160714722016750 0ustar osboxesosboxes#ifdef __cplusplus extern "C" { #endif #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #ifdef __cplusplus } #endif MODULE = PDL::Bench PACKAGE = PDL::Bench void c_use_pp(sv) SV *sv; CODE: /* Let's hope the C compiler isn't smart enough to optimize * away everything */ double *p = (double *) SvPV(sv,PL_na); int i = SvCUR(sv) / sizeof(double); while(i--) { (*p)++; p++; } void c_use_add(sv1,sv2,sv3) SV *sv1; SV *sv2; SV *sv3; CODE: double *p1 = (double *) SvPV(sv1,PL_na); int i = SvCUR(sv1) / sizeof(double); double *p2 = (double *) SvPV(sv2,PL_na); double *p3 = (double *) SvPV(sv3,PL_na); while(i--) { *p1 = *p2 + *p3; p1 ++; p2 ++; p3 ++; } void c_use_add_incr(sv1,sv2,sv3,i1,i2,i3) SV *sv1; SV *sv2; SV *sv3; int i1; int i2; int i3; CODE: double *p1 = (double *) SvPV(sv1,PL_na); int i = SvCUR(sv1) / sizeof(double); double *p2 = (double *) SvPV(sv2,PL_na); double *p3 = (double *) SvPV(sv3,PL_na); while(i--) { *p1 = *p2 + *p3; p1 += i1; p2 += i2; p3 += i3; } PDL-2.074/Example/Benchmark/time.pl0000644000175000017500000000005214146002234016644 0ustar osboxesosboxesuse PDL; use PDL::Bench; do_benchmark(); PDL-2.074/Example/Benchmark/Bench.pm0000644000175000017500000000141314165332241016735 0ustar osboxesosboxes# Old results: approx. 1.91_03: 34 secs (512, 10 iter) # With simply folded-out threading: 3.4 secs (10fold!) # For 512,30iter: package PDL::Bench; use strict; use warnings; require Exporter; require DynaLoader; our @ISA = qw(Exporter DynaLoader); our @EXPORT = qw( do_benchmark ); bootstrap PDL::Bench; use Benchmark; sub do_benchmark { $size = 512; $niter = 10000; $ndarray = (PDL->zeroes($size,$size)); $dref = ${$ndarray->get_dataref()}; timethese($niter, { # 'With double ndarray' => 'for($i=0; $i<100; $i++) {$ndarray++}', 'With double ndarray' => '$ndarray++;', 'C using ++' => 'c_use_pp($dref)', 'C using foo = bar + baz' => 'c_use_add($dref,$dref,$dref)', 'C using incrs and foo = bar + baz' => 'c_use_add_incr($dref,$dref,$dref,1,1,1)' }); } 1; PDL-2.074/Example/Benchmark/README.md0000644000175000017500000000033314146002234016632 0ustar osboxesosboxes# Usage ``` perl Makefile.PL make perl -Mblib time.pl ``` You can edit `Bench.pm` for different parameters / running times if your machine is very slow or very fast. Currently only compares XS/C "++" with a PDL one. PDL-2.074/Example/Benchmark/Makefile.PL0000644000175000017500000000045214146003631017331 0ustar osboxesosboxesuse strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'PDL::Bench', 'VERSION_FROM' => '../../Basic/PDL.pm', # finds $VERSION 'LIBS' => [''], # e.g., '-lm' 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' 'INC' => '', # e.g., '-I/usr/include/other' ); PDL-2.074/macosx/0000755000175000017500000000000014200406301013353 5ustar osboxesosboxesPDL-2.074/macosx/README0000644000175000017500000000044213265417442014255 0ustar osboxesosboxesNOTE: The PDL::Graphics::TriD window controls are based on having a mouse with 2 or more buttons. For Macs with one button, you can use Ctrl+Click to generate the needed Right-click. It is also possible to configure the Macbook tracpad to generate a secondary click via the control panel. PDL-2.074/pdl.c0000644000175000017500000000353314172737500013030 0ustar osboxesosboxes/****************************** * pdl.c - perldl spawner * Works around a problem with many unices that you can't use an interpreter * to run an interpreter -- so "#!/usr/bin/perldl" won't work. * This is a compiled piece of code that launches perldl "directly", * so that the poor kernel's mind isn't blown. * * If you feed in a single non-switch argument it gets prepended with a * "-" to let perldl know that it's an input file. That way you can be lazy * and say "#!/usr/bin/pdl" at the top of your script. * * CED 21-Jul-2004 */ #include #include #include #include #include int main(int argc, char **argv) { char perldl[BUFSIZ]; int pipes[2]; int pid,i; int status; if(pipe(pipes)) {perror("pdl (perldl spawn wrapper)"); exit(1);} pid = fork(); if(pid==0) { dup2(pipes[1],1); dup2(pipes[1],2); exit(system("which perldl")); } pid = wait(&status); if(! WIFEXITED(status) ) { fprintf(stderr,"Hmmm... couldn't seem to find perldl anywhere. Quitting.\n"); goto exit; } if( read(pipes[0],perldl,BUFSIZ) <= 0 ) { fprintf(stderr, "Read error - quitting.\n"); goto exit; } /* Remove trailing newline */ for(i=0;i the list to post to for PDL problems. The pdl-devel list is I for PDL development and often contains discussions of a rather technical nature relating to PDL internals. This is I the list for general PDL discussion or questions: L. B: Both pdl-general and pdl-devel are read by the PDL developers so you don't save time or increase the probability of response by posting to pdl-devel or by cross-posting to pdl-devel. Please stick to pdl-general list posts unless you want to talk PDL implementation and development. B: There is also a PDL IRC channel which can be useful for immediate questions if populated. However, it has the big disadvantage of not being easily searched or routinely read by all PDL developers and users. As a result, if you get an answer there, it may be incorrect or incomplete depending on who happens to be chatting at the time. It is definitely not readily searchable. =head1 REPORTING BUGS Please submit bug reports via the GitHub issue tracker at L. where you can review the previously submitted bug reports. Click on C to generate a bug report. If you do not already have a GitHub account, you will need to create one to submit the report. Try to include any information you think might help someone isolate, reproduce, and fix your problem. At a I, include the following information: =over =item * PDL version number (e.g. PDL-2.007) =item * Perl version information. Output from C or C (even better!) =item * Your operating System. You can run the C command on many unix systems =item * The full output of C If you are reporting a bug with an already installed PDL. If the PDL has compiled and built but not been installed, you may run C from the top level of the PDL build directory. =item * The bug description and how to reproduce it. Short examples using the PDL shells, C or C, are excellent! Don't forget to include needed input data (as small as possible) so that the code can be run with a cut and paste. =back Other things that are often helpful: =over =item * Details about your operating environment that might be related to the problem =item * Exact cut and pasted error or warning messages =item * The shortest, clearest code you can manage to write which reproduces the bug described. =item * A patch against the latest released version of this distribution which fixes this bug. =back Alternatively, send an e-mail report with the above information (including the output of C) to the pdl-devel mailing list. See L for info on how to subscribe to this list. =head1 BEFORE YOU SEND A REPORT BEFORE you report a bug make sure you got the latest release version of PDL, always available from CPAN, check L. Also, you can check the FAQ at L. and the mailing list archives for hints. You can find links to the searchable archives at L. and there is a Google enable search box on the top right of L which usually gives the best results. =head1 PATCHES Patches can be submitted in several ways, in order of decreasing preference: =over 4 =item 1 Fork the pdl repository on GitHub, make and test your changes, and submit a pull request; =item 2 Edit (or suggesting an edit to) the files in-place on GitHub; =item 3 Email a patch to the pdl-devel mailing list. =back Patches should be made against the latest released PDL or, ideally, against the current git sources which you can browse and check out at L. Thanks, The PDL developers. =cut PDL-2.074/MANIFEST.SKIP0000644000175000017500000001126614174703521014003 0ustar osboxesosboxes%$ -stamp$ .*/TAGS$ .*Version_check$ .*\#$ .*\.0$ .*\.orig$ .*\.rej$ \.swp$ .exe$ /\.\#.* /pm_to_blib$ /tmp.* Benchmark/Bench.c Benchmark/blib/ MANIFEST\.bak$ MANIFEST\.old META\.json META\.yml Makefile$ Makefile\.aperl Makefile\.old RCS \.(tmp|new|diff|ori)$ \.BAK$ \.bck$ \.bs \.bundle$ \.cvsignore$ \.inlinewith \.inlinepdlpp \.lck$ \.m$ \.o$ \.out$ \.patch$ \.so$ \.tar\.gz$ /core$ \b_eumm/ ^Basic/Bad/Bad\.c$ ^Basic/Bad/Bad\.pm$ ^Basic/Bad/Bad\.xs$ ^Basic/Complex/Complex\.c ^Basic/Complex/Complex\.pm ^Basic/Complex/Complex\.xs ^Basic/Core/Config\.pm ^Basic/Core/Core\.c$ ^Basic/Core/Types\.pm$ ^Basic/Core/pdl\.h$ ^Basic/Core/pdlperl\.h$ ^Basic/Core/pdlsimple\.h$ ^Basic/Gen/PP/Dump\.pm$ ^Basic/Gen/PP/Dump\.pm\.tmp$ ^Basic/Gen/pptemplate.pod$ ^Basic/Math/Math\.c$ ^Basic/Math/Math\.pm$ ^Basic/Math/Math\.xs$ ^Basic/MatrixOps/MatrixOps\.c ^Basic/MatrixOps/MatrixOps\.pm ^Basic/MatrixOps/MatrixOps\.xs ^Basic/Ops/Ops\.c$ ^Basic/Ops/Ops\.pm$ ^Basic/Ops/Ops\.xs$ ^Basic/Pod/Export\.pod$ ^Basic/Pod/PP-Inline\.pod$ ^Basic/Primitive/Primitive\.c$ ^Basic/Primitive/Primitive\.pm$ ^Basic/Primitive/Primitive\.xs$ ^Basic/Slices/Slices\.c$ ^Basic/Slices/Slices\.pm$ ^Basic/Slices/Slices\.xs$ ^Basic/Test/Tests\..* ^Basic/Ufunc/Ufunc\.c ^Basic/Ufunc/Ufunc\.pm ^Basic/Ufunc/Ufunc\.xs ^CVS ^Demos/BAD2_demo.pm$ ^Demos/BAD_demo.pm$ ^Demos/TkTriD_demo.pm$ ^Demos/TriD/test6.p$ ^Doc/Doc/Config.pm$ ^Doc/Pod/pod2usage$ ^Doc/Pod/podselect$ ^Doc/docscan$ ^Doc/pdlfunc\.pod ^Doc/pdlhead2item$ ^Graphics/IIS/IIS\..* ^Graphics/PGPLOT/PGPLOT.c ^Graphics/PGPLOT/Window/Window.c ^Graphics/TriD/OpenGL/OpenGL.pm ^Graphics/TriD/OpenGL/OpenGL.xs ^Graphics/TriD/OpenGL/OpenGL\.c$ ^Graphics/TriD/OpenGL/X.h.cpp ^Graphics/TriD/OpenGL/blib ^Graphics/TriD/OpenGL/gl.h.cpp ^Graphics/TriD/OpenGL/glu.h.cpp ^Graphics/TriD/OpenGL/glx.h.cpp ^Graphics/TriD/OpenGL/glxtokens.h.cpp ^Graphics/TriD/OpenGL/ppcode.out ^Graphics/TriD/OpenGL/typemap ^Graphics/TriD/OpenGLQ/OpenGLQ\.* ^Graphics/TriD/OpenGLQ/blib ^Graphics/TriD/OpenGLQ/oglq-expand.pl$ ^Graphics/TriD/Rout/Rout\.* ^Graphics/TriD/TriD/Tk.pm$ ^IO/Browser/Browser\..* ^IO/Browser/[Pp][Dd][Cc] ^IO/ENVI/envi-data ^IO/ENVI/envi-data.hdr ^IO/GD/GD\.c ^IO/GD/GD\.pm ^IO/GD/GD\.xs ^IO/HDF/SD/SD\.c ^IO/HDF/SD/SD\.pm ^IO/HDF/SD/SD\.xs ^IO/HDF/VS/VS\.c ^IO/HDF/VS/VS\.pm ^IO/HDF/VS/VS\.xs ^IO/Misc/Misc.* ^IO/NDF/NDF.pm$ ^IO/Pnm/Pnm\..* ^IO/Pnm/converters$ ^IO/Pnm/converters/README ^IO/Pnm/converters/pnmtotiff$ ^IO/Pnm/converters/pnmtotiff.c ^IO/Pnm/converters/tifftopnm$ ^IO/Pnm/converters/tifftopnm.c ^IO/Storable/Storable\.c ^IO/Storable/Storable\.pm ^IO/Storable/Storable\.xs ^IO/tmp0 ^IO/tmp0.hdr ^Image2D/Image2D\..* ^LOG$ ^Libtmp/CallExt/CallExt\.c$ ^Libtmp/Compression/Compression.c ^Libtmp/Compression/Compression.pm ^Libtmp/Compression/Compression.xs ^Libtmp/FFT/FFT\.* ^Libtmp/Fit/Gaussian/Gaussian\.c ^Libtmp/Fit/Gaussian/Gaussian\.pm ^Libtmp/Fit/Gaussian/Gaussian\.xs ^Libtmp/GIS/Proj/Proj\.c ^Libtmp/GIS/Proj/Proj\.pm ^Libtmp/GIS/Proj/Proj\.xs ^Libtmp/GSL/.*\.pm$ ^Libtmp/GSL/.*\.xs$ ^Libtmp/GSL/CDF/CDF\.c ^Libtmp/GSL/CDF/CDF\.pm ^Libtmp/GSL/CDF/CDF\.xs ^Libtmp/GSL/DIFF/D.*\.c$ ^Libtmp/GSL/INTEG/I.*\.c$ ^Libtmp/GSL/INTERP/.*\.c$ ^Libtmp/GSL/LINALG/LINALG\.c$ ^Libtmp/GSL/LINALG/LINALG\.pm$ ^Libtmp/GSL/LINALG/LINALG\.xs$ ^Libtmp/GSL/MROOT/M.*\.c$ ^Libtmp/GSL/RNG/.*\.c$ ^Libtmp/GSL/RNG\.(pm|xs|c) ^Libtmp/GSL/SF/.*\.c$ ^Libtmp/Image2D/Image2D\..* ^Libtmp/ImageND/ImageND\..* ^Libtmp/ImageRGB/ImageRGB\..* ^Libtmp/Minuit/.*\.a$ ^Libtmp/Minuit/.*\.pm$ ^Libtmp/Minuit/.*\.xs$ ^Libtmp/Minuit/M.*\.c$ ^Libtmp/Slatec/Slatec.c ^Libtmp/Slatec/Slatec.pm ^Libtmp/Slatec/Slatec.xs ^Libtmp/Slatec/SlatecProtos.h$ ^Libtmp/Slatec/slatec/.*\.c$ ^Libtmp/Transform/Cartography/earth_day.ppm ^Libtmp/Transform/Cartography/earth_night.ppm ^Libtmp/Transform/Proj4/Makefile.PL-gis$ ^Libtmp/Transform/Proj4/Proj4\.c ^Libtmp/Transform/Proj4/Proj4\.pm ^Libtmp/Transform/Proj4/Proj4\.xs ^Libtmp/Transform/Transform\.c ^Libtmp/Transform/Transform\.pm ^Libtmp/Transform/Transform\.xs ^Perldl2/logo3d.pdl ^Perldl2/pdl2.pod$ ^Perldl2/tctrl-c.pl ^Perldl2/trgnu-ctrl-c.txt$ ^Perldl2/work \b[\._]Inline ^\.\#.* ^\.exists ^\.git ^a3x3.txt ^a4x4.txt ^a9-3x3.txt ^a9-4x4.txt ^blib/ ^chm-notes/.* ^core ^cygwin/fix-max-memory.txt ^cygwin/max_memory.c ^cygwin/rtool.txt ^cygwin/tmalloc.pl ^gsl.pl ^inv-data.pl ^patch ^pdl$ ^pdl.*-log.txt$ ^pdldoc.db$ ^pdldoc.pod ^perl$ ^perldl.conf-fast ^perldl.conf-orig ^perldl.pod ^pm_to_blib$ ^podsel$ ^t/.*\.dll(.a)?$ ^t/.*\.pnm$ ^tbyte\.tif$ ^test\.wis$ ^tmp.* ^tushort\.(tif|rgb)$ ^win32/pbmwin32.tar.gz ^work makemakerdflt manifypods pdlbasicops\.c$ pdlexamples\.c$ pdlmoremaths\.c$ pdlstats\.c$ pure_all so_locations subdirs ~$ ^xt/ ^README\.md ^\.github/ ^Example/Benchmark/\.git ^cover_db/ ^nytprof(/|\.out) \.gc(ov|no|da)$ pp-\w*\.c$ ^debian/ PDL-2.074/Perldl2/0000755000175000017500000000000014200406301013365 5ustar osboxesosboxesPDL-2.074/Perldl2/Plugin/0000755000175000017500000000000014200406301014623 5ustar osboxesosboxesPDL-2.074/Perldl2/Plugin/CleanErrors.pm0000644000175000017500000000260214165654461017426 0ustar osboxesosboxespackage PDL::Perldl2::Plugin::CleanErrors; use strict; use warnings; use Devel::REPL::Plugin; use namespace::clean -except => [ 'meta' ]; around 'error_return' => sub { my ($orig, $self) = (shift, shift); my ($type, $error) = @_; return $orig->($self, $type, clean_error_string($error)); }; # filter out the Devel::REPL, Class::MOP, ... from pdl2 errors sub clean_error_string { my $bigerr = $_[0]; $bigerr =~ s/^\s+Devel::REPL.*$//ms; $bigerr =~ s/^\s+Class::MOP.*$//ms; $bigerr =~ s/^\s+Lexical::Persistence.*$//ms; $bigerr =~ s/^\s+main::.*$//ms; $bigerr =~ s/^\s+eval \{.*$//ms; $bigerr =~ s/^\s+PDL::Core::barf.*$//ms; return $bigerr; } 1; __END__ =head1 NAME PDL::Perldl2::Plugin::CleanErrors - filter out Moose cruft =head1 DESCRIPTION Runtime errors in pdl2 are extremely verbose since they include the entire call chain from the start of the interactive Devel::REPL shell, through the Moose and Class::MOP stuff and including Lexical::Persistence as well. This plugin, which is loaded by default, strips out the non-PDL stuff to make the error messages much more concise. =head1 SEE ALSO C =head1 AUTHOR Chris Marshall, C<< >> =head1 COPYRIGHT AND LICENSE Copyright (C) 2011 by Christopher Marshall This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut PDL-2.074/Perldl2/Plugin/PrintControl.pm0000644000175000017500000000430214165654536017646 0ustar osboxesosboxespackage PDL::Perldl2::Plugin::PrintControl; use strict; use warnings; use Devel::REPL::Plugin; use namespace::clean -except => [ 'meta' ]; has 'print_by_default' => ( is => 'rw', default => 0, ); around 'format_result' => sub { my ($orig, $self) = (shift, shift); my ($lines, @args) = @_; return $self->print_by_default ? $orig->($self, @_) : (); }; # convenience method to set/toggle print default settings # sets like accessor if given a value, otherwise toggles status sub do_print { my ($repl, $value) = @_; $value = (defined $value) ? $value : ! $repl->print_by_default; return $repl->print_by_default($value); } 1; __END__ =head1 NAME PDL::Perldl2::Plugin::PrintControl - disable default print output =head1 SYNOPSIS pdl> $x = 3; 3 pdl> $_REPL->load_plugin('PDL::Perldl2::Plugin::PrintControl'); pdl> $x; pdl> $_REPL->print_by_default(1); 1 pdl> $x; 3 =head1 DESCRIPTION By default the Devel::REPL always prints the results of its evaluation. This is fine for small objects but for things like large data objects (e.g. a 100x100 matrix in PDL) the result can be hundreds of lines of output for each command. This plugin disables the default print output and adds an attribute with accessor method C which can be used to toggle the print default on or off. =head1 METHODS =head2 print_by_default By default, the C plugin sets C to 0 (false), which disables automatic printing of results. Call the print_by_default accessor with a 1 (true value) to enable default printing. =head2 do_print This is a convenience accessor for the print_by_default attribute. If you call this method without a value, it toggles the current setting. Otherwise, it just sets print_by_default to the value. It is also available in the C shell as the do_print sub with the same operation but with an implicit use of C<$_REPL>. =head1 SEE ALSO C =head1 AUTHOR Chris Marshall, C<< >> =head1 COPYRIGHT AND LICENSE Copyright (C) 2010 by Christopher Marshall This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut PDL-2.074/Perldl2/Plugin/PDLCommands.pm0000644000175000017500000000561614165654512017315 0ustar osboxesosboxespackage PDL::Perldl2::Plugin::PDLCommands; use strict; use warnings; use Devel::REPL::Plugin; use namespace::clean -except => [ 'meta' ]; # The atomic option---need to deconflict Turtle command injection # using qr{\#} and perldl's usage for command escapes. Just # exclude for now to get things working excludes 'Turtles'; around 'read' => sub { my $orig = shift; my ($self, @args) = @_; # using $lines here because that is the usage from perldl # and I want to cut and paste existing code if possible my $lines = $self->$orig(@args); # Execute the list of auto-code (TODO) ## for my $c (@PERLDL::AUTO) { ## my $mess = eval_and_report($c); ## warn $mess if $mess; ## } # Filter out PDL shell prefixes from cut-n-pasted lines if ( defined($lines) and $lines =~ s/$PERLDL::PREFIX_RE// ) { if ($PERLDL::TERM->can('GetHistory') and $PERLDL::TERM->can('SetHistory')) { my @hist = $PERLDL::TERM->GetHistory(); foreach my $entry (@hist) { $entry =~ s/$PERLDL::PREFIX_RE//; } $PERLDL::TERM->SetHistory(@hist); } } return $lines unless defined $lines; # print STDERR "PDLCommands: got '$lines'\n"; if ( lc $lines eq 'q' || lc $lines eq 'x' || lc $lines eq 'exit' ) { return "quit"; }; $lines =~ s/^\s*\?\?\s*/apropos /; # Make '??' = 'apropos' $lines =~ s/^\s*\?\s*/help /; # Make lone '?' = 'help' if ( $lines =~ /^\s*(help|usage|apropos|sig|badinfo|demo)\s+/) { # Allow help foo (no quotes) my @t = split(/\s+/,$lines); my $x; foreach $x(@t) { $x=~s/^["']+//; $x=~s/['"]+$//; }; $t[1] = "'".$t[1]."'" if ($#t == 1 && !($t[1] =~ /^\$/)); $lines = join(' ',@t); } $PERLDL::ESCAPE = $PERLDL::ESCAPE if defined $PERLDL::ESCAPE; if (substr($lines,0,1) eq substr($PERLDL::ESCAPE,0,1) and substr($lines,0,2) ne '#!') { # Allow escapes, avoid shebang my @lines = split /\n/, $lines; system(substr(shift @lines,1)); # Shell escape $lines = join("\n",@lines); } return $lines; }; 1; __END__ =head1 NAME PDL::Perldl2::Plugin::PDLCommands - implement perldl aliases/escapes =head1 DESCRIPTION This plugin implements the various convenience features of the perldl shell which correspond, roughly, to aliases and some structured pre-processing of the command line entered: =over 4 =item q|x|exit|quit as shortcuts to quit the shell =item ?? as an alias for apropos =item ? as an alias for help =item Autoquoting for arguments to help|usage|apropos|sig|badinfo|demo =item C<$PERLDL::ESCAPE> at the start of a command line to escape to the shell, defaults to C<#> =back =head1 SEE ALSO C, C =head1 AUTHOR Chris Marshall, C<< >> =head1 COPYRIGHT AND LICENSE Copyright (C) 2010 by Christopher Marshall This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut PDL-2.074/Perldl2/Plugin/NiceSlice.pm0000644000175000017500000000265314165654473017056 0ustar osboxesosboxespackage PDL::Perldl2::Plugin::NiceSlice; use strict; use warnings; use Devel::REPL::Plugin; use namespace::clean -except => [ 'meta' ]; use PDL::Lite; use PDL::NiceSlice; my $preproc = sub { my ($txt) = @_; my $new = PDL::NiceSlice::perldlpp('main',$txt); return $new; }; around 'compile' => sub { my ($orig, $self) = (shift, shift); my ($lines, @args) = @_; no PDL::NiceSlice; $lines = $preproc->($lines); $self->$orig($lines, @args); }; 1; __END__ =head1 NAME PDL::Perldl2::Plugin::NiceSlice - enable PDL NiceSlice syntax =head1 DESCRIPTION This plugin enables one to use the PDL::NiceSlice syntax in an instance of C such as the new Perldl2 shell, C. Without the plugin, array slicing looks like this: pdl> use PDL; pdl> $x = sequence(10); $PDL1 = [0 1 2 3 4 5 6 7 8 9]; pdl> $x->slice("2:9:2"); $PDL1 = [2 4 6 8]; After the NiceSlice plugin has been loaded, you can use this: pdl> $x(2:9:2) $PDL1 = [2 4 6 8]; =head1 CAVEATS C uses Perl source preprocessing. If you need 100% pure Perl compatibility, use the slice method instead. =head1 SEE ALSO C, C, C =head1 AUTHOR Chris Marshall, C<< >> =head1 COPYRIGHT AND LICENSE Copyright (C) 2010 by Christopher Marshall This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut PDL-2.074/Perldl2/Plugin/Makefile.PL0000644000175000017500000000066114146003631016610 0ustar osboxesosboxesuse strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'PDL::Perldl2::Plugin', 'VERSION' => '2.001', 'PM' => { 'CleanErrors.pm' => '$(INST_LIBDIR)/Plugin/CleanErrors.pm', 'NiceSlice.pm' => '$(INST_LIBDIR)/Plugin/NiceSlice.pm', 'PDLCommands.pm' => '$(INST_LIBDIR)/Plugin/PDLCommands.pm', 'PrintControl.pm' => '$(INST_LIBDIR)/Plugin/PrintControl.pm', }, NO_MYMETA => 1, ); PDL-2.074/Perldl2/pdl20000755000175000017500000000565614172737500014210 0ustar osboxesosboxes#!/usr/bin/perl BEGIN { $ENV{DEVEL_REPL_PROFILE} = 'PDL::Perldl2::Profile::Perldl2'; # This should be based on $HOME = $ENV{HOME}; # Useful in shell if ($^O =~ /win32/i and (! defined($HOME)) or (defined($HOME) and $HOME eq "")) { $HOME = $ENV{USERPROFILE}; $HOME =~ s/\\/\//g; } $ENV{PERLREPL_HISTFILE} = "$HOME/.perldl_hist"; $ENV{PERLREPL_HISTLEN} = 500; } BEGIN { my $minversion = "1.003011"; eval " use Devel::REPL $minversion "; if ($@) { my ($perldl) = $0; $perldl =~ s/pdl2\.bat$/perldl.bat/; $perldl =~ s/pdl2$/perldl/; warn "pdl2: Devel::REPL version $minversion not found, running '$perldl' instead...\n"; do $perldl; warn "pdl2: could not 'do $perldl'\n"; $perldl =~ s{^[^/\\]*[/\\]}{}; do $perldl; die "pdl2: could not 'do $perldl'\n"; } } use PDL::Perldl2::Script 'run'; __END__ =head1 NAME pdl2 - Simple shell (version 2) for PDL =head1 SYNOPSIS Use PDL interactively: %> pdl2 pdl> $x = sequence(10) # or any other perl or PDL command pdl> print "\$x = $x\n"; $x = [0 1 2 3 4 5 6 7 8 9] =head1 DESCRIPTION The C program, also known as the Perldl2 shell, is a second generation version of the original C interactive PDL shell. It attempts to be backward compatible in usage while providing improved features, better support for Perl syntax, and an more easily extended framework based on the L shell. If you have L version 1.003011 or later, then C will start with full functionality. If L is not installed or found then C will print a warning and run the legacy C shell command instead. By default, command lines beginning with the default prompt of either C or C (one of 'pdl> ', 'PDL> ', or 'perldl> ') will have the prefix string and surrounding whitespace stripped. This allows for easy cut-and-paste from sample PDL shell sessions or other examples into another PDL shell session. =head1 FUNCTIONS =head2 do_print =for ref Toggle print-by-default on and off (default value: off) By default, C does not print the results of operations since the results can be very large (e.g., a small 640x480 RGBA image is still more than 1_000_000 elements). However, for experimenting and debugging more complex structures, it helps to see the results of I operation. The C routine allows you to toggle between the default "quiet" operation and a full Read, Evaluate, Loop style. =for example pdl> $x = pdl(3,2) pdl> do_print 1 pdl> $x = pdl(3,2) $PDL1 = [3 2]; pdl> do_print pdl> $x = pdl(3,2) =head1 VARIABLES =over 4 =item $PDL::toolongtoprint The maximal size pdls to print (defaults to 10000 elements). This is not just a C or C variable but it is something that is usually needed in an interactive debugging session. =back =head1 SEE ALSO L, L =cut PDL-2.074/Perldl2/Profile/0000755000175000017500000000000014200406301014765 5ustar osboxesosboxesPDL-2.074/Perldl2/Profile/Perldl2.pm0000644000175000017500000002147614165654307016666 0ustar osboxesosboxespackage PDL::Perldl2::Profile::Perldl2; use strict; use warnings; use Moose; use namespace::clean -except => [ 'meta' ]; our $VERSION = 0.008; $PERLDL::PROMPT = $PERLDL::PROMPT; # suppress warning with 'Devel::REPL::Profile'; sub plugins { qw( CleanErrors Commands Completion CompletionDriver::INC CompletionDriver::Keywords CompletionDriver::LexEnv CompletionDriver::Methods DDS History LexEnv MultiLine::PPI Packages NiceSlice PrintControl ReadLineHistory PDLCommands ); # CompletionDriver::Globals } sub apply_profile { my ($self, $repl) = @_; # check for Term::ReadLine::Stub if ($repl->term->ReadLine =~ /Stub/) { $repl->print("WARNING:\n Term::ReadLine::Stub does not support pdl2 features.\n"); $repl->print(" Please install either Term::ReadLine::Perl or Term::ReadLine::Gnu.\n"); $repl->print(" Falling back to perldl in the meantime...\n"); $repl->print("------------------------------------------\n\n"); exec 'perldl'; } # add PDL::Perldl2 for plugin search push @{$repl->_plugin_app_ns}, 'PDL::Perldl2'; foreach my $plug ($self->plugins) { if ($plug =~ 'CompletionDriver::INC') { eval 'use File::Next'; next if $@; } if ($plug =~ 'CompletionDriver::Keywords') { eval 'use B::Keywords'; next if $@; } $repl->load_plugin($plug); } # these plugins don't work on win32 unless ($^O =~ m/win32/i) { $repl->load_plugin('Interrupt'); } # enable Term::ReadLine file expansion by default $repl->do_readline_filename_completion(1) if $repl->can('do_readline_filename_completion'); # do perldl stuff here $repl->eval('package main'); $repl->eval('use PDL'); $repl->eval('use PDL::Config'); $repl->eval('use PDL::Dbg'); $repl->eval('use PDL::Doc::Perldl'); $repl->eval('use PDL::IO::Dumper'); $repl->eval('use PDL::IO::FlexRaw'); $repl->eval('use PDL::IO::Pic'); $repl->eval('use PDL::Image2D'); $repl->eval('use PDL::AutoLoader'); $repl->eval('no strict qw(vars)'); # declare PERLDL package variables # most are not used but they are here if needed $repl->eval( q[ @PERLDL::AUTO = (); # code string/refs to run after user enters a new line $PERLDL::ESCAPE = '#'; # Default shell escape character $PERLDL::HISTFILESIZE = $ENV{PERLREPL_HISTLEN}; # Number of lines to keep in history $PERLDL::MULTI = 1; # Enable multi-lines by default $PERLDL::NO_EOF = 1; # Enable EOF protection by default $PERLDL::PAGE = 0; $PERLDL::PAGER = ((exists $ENV{PAGER}) ? $ENV{PAGER} : 'more'); $PERLDL::PAGING = 0; $PERLDL::PROMPT = "pdl> "; # string or code reference $PERLDL::PREFIX_RE = qr(^\s*(?:pdl|perldl)>\s*); # RE for shell prompts $PERLDL::TERM = $_REPL->term; ] ); #autoflush STDOUT $repl->eval('$|=1;'); # p command (NOTE: this is not an alias for print) $repl->eval('sub p { local $, = " "; print @_,"\n" };'); # list history command $repl->eval('sub l { my $n = $#_ > -1 ? shift : 20; my @h = $_REPL->term->GetHistory(); my $min = $#h < $n-1 ? 0 : $#h-$n+1; map { printf "%d: %s\n", $_+1, $h[$_] } ($min..$#h); #map {print "$_: $h[$_]\n"} ($min..$#h); };'); # preliminary support for PDL demos $repl->eval( q{ sub demo { local $_ = lc $_[0] ; if(/^$/) { print < 'PDL::Demos::General', # have to protect pdl as it means something '3d' => 'PDL::Demos::TriD1', '3d2' => 'PDL::Demos::TriD2', '3dgal' => 'PDL::Demos::TriDGallery', 'pgplot' => 'PDL::Demos::PGPLOT_demo', 'ooplot' => 'PDL::Demos::PGPLOT_OO_demo', # note: lowercase 'bad' => 'PDL::Demos::BAD_demo', 'bad2' => 'PDL::Demos::BAD2_demo', 'transform' => 'PDL::Demos::Transform_demo', 'cartography' => 'PDL::Demos::Cartography_demo', 'gnuplot' => 'PDL::Demos::Gnuplot_demo', 'prima' => 'PDL::Demos::Prima', ); if ( exists $demos{$_} ) { require PDL::Demos::Screen; # Get the routines for screen demos. my $name = $demos{$_}; eval "require $name;"; # see docs on require for need for eval $name .= "::run"; no strict 'refs'; &{$name}(); } else { print "No such demo!\n"; } } } ); if ($repl->can('do_print')) { $repl->eval('sub do_print { $_REPL->do_print(@_) };'); } if ($repl->can('exit_repl')) { $repl->eval('sub quit { $_REPL->exit_repl(1) };'); } else { $repl->eval('sub quit { $_REPL->print("Use Ctrl-D or exit to quit" };'); } $repl->prompt($PERLDL::PROMPT); # new prompt if ( defined $ENV{TERM} and $ENV{TERM} eq 'dumb' ) { $repl->print("\n"); $repl->print("******************************************\n"); $repl->print("* Warning: TERM type is dumb! *\n"); $repl->print("* Limited ReadLine functionality will be *\n"); $repl->print("* available. Please unset TERM or use a *\n"); $repl->print("* different terminal type. *\n"); $repl->print("******************************************\n"); $repl->print("\n"); } $repl->print("Perldl2 Shell v$PDL::Perldl2::Profile::Perldl2::VERSION PDL comes with ABSOLUTELY NO WARRANTY. For details, see the file 'COPYING' in the PDL distribution. This is free software and you are welcome to redistribute it under certain conditions, see the same file for details.\n"); $repl->print("Loaded plugins:\n"); { my @plugins = (); foreach my $pl ( $repl->_plugin_locator->plugins ) { # print names of ones that have been loaded my $plug = $pl; $plug =~ s/^.*Plugin::/ /; push @plugins, $plug if $repl->does($pl); } # Need smarter display of plugins, fill out the line # and list CompletionDrivers under Completion $repl->print(join "\n", sort(@plugins)); $repl->print("\n"); } $repl->print("Type 'help' for online help\n"); $repl->print("Type Ctrl-D or quit to exit\n"); $repl->print("Loaded PDL v$PDL::VERSION\n"); } 1; __END__ =head1 NAME PDL::Perldl2::Profile::Perldl2 - profile for Perldl2 shell =head1 SYNOPSIS system> re.pl --profile=PDL::Perldl2::Profile::Perldl2 # unix-ish shell system> re --profile=PDL::Perldl2::Profile::Perldl2 # win32 CMD shell Perldl2 Shell v0.008 PDL comes with ABSOLUTELY NO WARRANTY. For details, see the file 'COPYING' in the PDL distribution. This is free software and you are welcome to redistribute it under certain conditions, see the same file for details. Loaded plugins: CleanErrors Commands Completion CompletionDriver::INC CompletionDriver::Keywords CompletionDriver::LexEnv CompletionDriver::Methods DDS FindVariable History Interrupt LexEnv MultiLine::PPI NiceSlice PDLCommands Packages PrintControl ReadLineHistory Type 'help' for online help Type Ctrl-D or quit to exit Loaded PDL v2.006 pdl> =head1 DESCRIPTION This profile is for development of the new PDL shell (version 2). The preferred method to start the new shell is via the C command. This documentation is provided for C coders that may wish to use this profile directly for their development. =head1 SEE ALSO C, C, and C. =head1 AUTHOR Chris Marshall, C<< >> =head1 COPYRIGHT AND LICENSE Copyright (C) 2010 by Christopher Marshall This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut PDL-2.074/Perldl2/Profile/Makefile.PL0000644000175000017500000000033414146003631016747 0ustar osboxesosboxesuse strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'PDL::Perldl2::Profile', 'VERSION' => '2.000', 'PM' => { 'Perldl2.pm' => '$(INST_LIBDIR)/Profile/Perldl2.pm' }, NO_MYMETA => 1, ); PDL-2.074/Perldl2/TODO0000644000175000017500000003103014146003631014062 0ustar osboxesosboxesCreated on: Thu 10 Dec 2009 10:32:58 PM Last saved: Tue 09 Jul 2013 09:05:18 AM +-------------------------------------------------------------------+ | TODO for Missing Perldl Functionality | +-------------------------------------------------------------------+ Set readline_name to 'PDL Shell' instead of the default 'Perl REPL' but need to figure how to do so first (override default term?). Add syntax highlighting to help ensure correct entries (e.g., in matlab keywords are blue, strings are purple, unterminated strings are maroon...) We could also specifically color ndarrays and objects from the current session space. Add "blink to matching delimiter" for input or even color highlight matching delimiters Add Colors plugin support to the pdl2 p command. Add enhanced filter support to remove leading prompt strings (or other text) from input lines. Need to be able to toggle on/off and set the regexp used. Allow Ctrl-C to interrupt a line but keep the entry in history for edit... Fix q alias for quit which broke as a side effect of a fix to the MultiLine::PPI handling. Perhaps using around continue_reading_if_necessary would do the trick. Need to sort out the Moose/Plugin/Roles issues and document. Implement ^C/^D to end PPI multiline if it makes sense. E.g., make sure that Ctrl-C can exit an incomplete block. Right now ^C does not interrupt a multiline entry. Need to see about implementing the Ctrl-D option to close all blocks as well. It would be nice to have the prompt display the matching delims as in perldl. Fix Term::ReadLine::Perl completion in win32 to use the appropriate path separator character. It appears to use / which is fine inside perl but not for system command escapes. Need to detect the two cases. Maybe we could autoquote the paths when using backslashes. Add auto-quoting/close quotes to Term::ReadLine::Perl expansion as does Term::ReadLine::Gnu. Fix Term::ReadLine::Perl completion to not append identifier characters on the inserted filenames: e.g. it is ok to list file.exe* in the possible completions part but the result should only insert file.exe (the actual file name). Fix Term::ReadLine::Perl TAB expansion for paths to work with win32 paths (i.e. backslashes). Add expansion to the pdl2 help/? command. Track pdl2 session variables for PDL, including: vars (global and lexical), subs that were defined, modules loaded, and plugins for the REPL. It should be possible to complete for these. Add tracking and expansion for all graphics windows that are open/active (PGPLOT, PLplot, Prima, GLUT/FreeGLUT...) windows for reference. It would be nice to have a list/table of currently active figures. IDEA: Associate metadata with image or figure windows (e.g., the commands that generated the figure). Add SIGINT handler for pdl2 for win32. Also need to add feature to ignore EOF to the read routine (around read modifier should work here---need to decide where to put it) Investigate why Ctrl-L on win32 is issuing a 'clear' command. ANSWER: readline.pm from Term::ReadLine::Perl is doing a qx{clear) to determine the escape sequence to clear the screen. This doesn't work on win32 since there is no clear command and the console does not support ANSI escape sequences. Plan to fix by calling the DOS cls command to clear the screen or by using Win32::Console and Win32::Console::ANSI to implement the missing ANSI support. Need to implement a routine readline::F_ClearScreen() to override the default function for win32 systems. Add runtime PDL module load list so you know what has been loaded with use/require. Maybe a pop-up info window would work here (curses based or GUI based). Maybe there could be a runtime list/variable in PDL::Config that is updated as each module is loaded. Override '*CORE::GLOBAL::use'? It would also be possible to use MOP features of Moose. Review and integrate $PERLDL::XX parameters. Some are not needed or useful for Perldl2. Others need code to tie in with the new framework. Implement perldl command line options: -M load module -m unload module -I

Add to include path. -V print PDL version info (e.g. for a bug report) -f execute file before starting perldl -glut try to load OpenGL module (Enables readline event-loop processing). -tk try to load Tk module (Enables readline event-loop processing). -w run with warning messages turned-on - Following arguments are files for input. Add @PERLDL::AUTO processing to the PDLCommands plugin. Should be able to just run the code after the line is read but before it is eval'd. Add ability to run $PERLDL::PROMPT if it is a code reference and not a string. Use the same logic as in perldl but set the prompt with the $_REPL->prompt(&$code) instead of using $_REPL->prompt($string). Implement support for @PERLDL::PREPROCESS filters. Update perldl documentation to match Perldl2 capabilities. Any way to transparently select the correct docs at runtime? Fix the newline differences between new line handling for TR::Perl (on win32 and cygwin and unix) and TR::Gnu (on cygwin and unix). TR::Gnu seems to have an extra newline inserted per command. Is it possible to add support for Term::ReadLine::Zoid? It would be nice if the most possible could be done using the Term::ReadLine::Stub. Add MultiLine prompt with continuation character marking the open structures. (e.g. MultiLine::TextBalanced). Add generic event loop support to Term::ReadLine::Perl and Term::ReadLine::Gnu. Need to figure out a clean way to map this into the original modules. Skip command lines that are too short and don't put quit/q/x/exit in the history log. Maybe remove duplicate entries as well as list history commands. Don't put history !-syntax into the history, put the actual command that resulted. e.g., not !6 but 'p "Hello, world.\n"; Be sure to add a line to history if it closes out a multi-line block. This should not be an issue once we have multi-line history entries supported. It would be nice if history entries were by blocks with the ability to go by lines within if desired. Make !-syntax history more restrictive so that it does not conflict with perl usage for negation. Maybe it should only be good for completion? At least if it is the first char and do_print(0). Add !:p support to print history commands and fix the problem where the ! command is different then the one actually inserted by History... Add runtime control options for NiceSlice: i.e., report, trans, and notrans Add a CompletionDriver for Plugins for load_plugin() as well as the ability to toggle plugins on and off (or at least enable and disable them). Would it simplify PDL::NiceSlice if the implementation were migrated to Filter::Simple? Make pdl2 fall back cleanly to a basic Devel::REPL or even perldl if requirements to run are not installed. (falls back to perldl right now) Fix glob pattern completion display for shell escapes in pdl2 (e.g., file* will list out tab.a tab.b and tab.c if those are the valid expansions. It should act just like bash directly from the command line---ideally). Add documentation for the startup files for unix-en and win32 systems. Right now, the only doc is in the code. Add startup checks for the various Devel::REPL plugins loaded to be sure that they can run before the load_plugin call to avoid nasty compile error traces. Fix 'demo 3d' so that it shifts focus to the display window at the start and returns focus to the CMD or shell window at then end. This shouldn't be needed with GLUT event loop support in readline. Is there a way to fix the GNU readline where it doesn't process the Ctrl-C interrupt until after has been typed? There are some hooks in GNU readline for handling signals that may help here. Add option for quiet startup for use when piping to the shell or taking input from a file. Add INPUT and OUTPUT handle args for PDL shells. How do we add this to the default term from Devel::REPL? NOTE: Also need to fix perldl v.1.x not to use STDIN/STDOUT. Verify that input from terminal and/or files works correctly and consistently with perldl. NOTE: This should make it possible to implement some tests of the interactive shell from file input. It would be nice if variable completion followed by a method call would collapse the extra space. E.g., the first in line#1 completes to the $_REPL varible followed by a space as seen in line#2. Then typing the ->do_p in line#3 triggers a method completion to ->do_print followed by a space shown in line#4. #1 PDL> $_RE #2 PDL> $_REPL _ #3 PDL> $_REPL ->do_p #4 PDL> $_REPL ->do_print _ What we would like is the trailing space in line#2 to be collapsed once the -> is typed following the completion. Similarly, we would like the space at the end of line#4 to be collapsed once a '(' is typed to start the arglist. Enhance completion strategy for Perldl2: (1) sort and prioritze completions to remove long lists of useless options [see completion paper], (2) allow chained PDL method completions by recognizing that the output of many (all?) PDL methods is a pdl so we could do method completion again... Make Perldl2 fail/degrade gracefully if various files and configuration stuff is not available. Lines and lines of backtrace isn't a help to anyone! Improve the error returns from evaluations in pdl2 as they seem to cut off the root error line for failures which makes it very difficult to debug things, e.g. I was getting errors from Core.pm instead of in my routine that had the failure. When I looked at the entire call stack in the debugger, I got the actual line with the bad code---of course I had to give up the nice pdl2 environment. Filter out error tracebacks from pdl2/perldl. It looks like these are internal to Devel::REPL and not the code being executed and could be filtered out: + eval {...} # both pdl2 and perldl + main::__ANON__ # both pdl2 and perldl | main::process_input # perldl | main::eval_and_report # perldl - main::BEGIN # pdl2 - Lexical::Persistence:: # pdl2 - Devel::REPL:: # pdl2 - Class::MOP:: # pdl2 +-------------------------------------------------------------------+ | Features perldl pdl2 | +-------------------------------------------------------------------+ preproc_add/del yes TBD ?,?? aliases yes yes quit,x,exit aliases yes yes User AUTO commands yes TBD Autoquoting doc commands yes yes Load user startup file yes yes Load local.perldlrc yes yes $_ preserved by line/block by session User extendable rewrite/hard plugins/easy History save/recall yes yes !-history expansion yes/partial yes Lexical variables yes/1-command only yes Multiline expression entry yes/Text::Balanced yes/PPI based NiceSlice syntax yes yes package NAMESPACE support no yes Readline editing yes/partial yes TAB completion: @INC no yes TAB completion: filename yes yes TAB completion: globals no yes TAB completion: keyword no yes TAB completion: lexicals no yes TAB completion: methods no yes print p alias yes yes list history yes yes help vars (package) yes yes help vars (lexical) no TBD PDL-2.074/Perldl2/Script.pm0000644000175000017500000000225714165654150015216 0ustar osboxesosboxespackage PDL::Perldl2::Script; use strict; use warnings; use Moose; use namespace::clean -except => [ qw(meta) ]; extends 'Devel::REPL::Script'; sub _startup_def { return "PDL/default.pdl" if $^O =~ /win32/i; return "PDL/default.perldlrc"; } sub load_rcfile { my ($self, $rc_file) = @_; my $HOME = $ENV{HOME}; if ($^O =~ /win32/i and (! defined($HOME)) or (defined($HOME) and $HOME eq "")) { $HOME = $ENV{USERPROFILE}; $HOME =~ s/\\/\//g; } print STDERR "load_rcfile: got \$HOME = $HOME\n"; # get rc file name my $startup_file = _startup_def(); foreach my $startup_suffix (qw( .pdlrc .perldlrc )) { if ( -e "$HOME/$startup_suffix" ) { $startup_file = "$HOME/$startup_suffix"; last; } } print STDERR "load_rcfile: loading $startup_file\n"; $self->apply_script($startup_file); # load local.perldlrc if it exists foreach my $local_startup_file (qw( local.pdlrc local.perldlrc )) { if ( -e $local_startup_file ) { print STDERR "load_rcfile: loading $local_startup_file\n"; $self->apply_script($local_startup_file); last; } } } # Global and local startup 1; PDL-2.074/Perldl2/README0000644000175000017500000001103614014062163014255 0ustar osboxesosboxesCreated on: Thu 10 Dec 2009 10:32:58 PM Last saved: Tue 09 Jul 2013 08:51:39 AM +-----------------------------------------------------------+ | OS/Platforms supported: ALL | +-----------------------------------------------------------+ This directory contains development efforts for a new and improved perldl shell (Perldl2). You need to install the version 1.003011 of Devel::REPL and have installed either Term::ReadLine::Perl or Term::ReadLine::Gnu in order to use the new Perldl2 shell capabilities. +-----------------------------------------------------------+ | CONTENTS | +-----------------------------------------------------------+ README This file TODO Development list for Perldl2 shell Makefile.PL Perl configuration/build script for Perldl2 Plugin/ Profile/ Script.pm Perl modules and directories with modules for Perldl2 pdl2 A perl script for starting the Perldl2 shell. (Falls back to the original perldl if either Devel::REPL or neither Term::ReadLine::Gnu nor Term::ReadLine::Perl are installed.) +-----------------------------------------------------------+ | INSTALLATION | +-----------------------------------------------------------+ By default, the Perldl2 shell is always built and the pdl2 script installed. To disable this, edit the WITH_DEVEL_REPL option in the perldl.conf file. You will need to install Devel::REPL version 1.003011 or greater and either of Term::ReadLine::Gnu or Term::ReadLine::Perl to access the new pdl2 capabilities. +-----------------------------------------------------------+ | USE | +-----------------------------------------------------------+ To use the Perldl2 shell, from the PDL build directory run the following: perl -Mblib Perldl2/pdl2 If you have installed the just built PDL, you should be able to run: pdl2 To exit the Perldl2 shell from the 'pdl> ' prompt, type Ctrl-D or quit, (q, x, and exit shortcuts are also available). If Devel::REPL is not installed (or you don't have either TR::Gnu or TR::Perl), pdl2 will use perldl instead but the new Perldl2 features will not be available. The idea is that one just uses pdl2 where you used to use perldl. At some point, the development will be complete and there will be only one PDL shell. +-----------------------------------------------------------+ | NOTES | +-----------------------------------------------------------+ Supported functionality from Devel::REPL and PDL: * DDS (pretty prints output using Data::Dump::Streamer) * History (redo commands with !-1 and ! syntax) * Interrupt (interrupt with Ctrl-C; not on MSWin32) * LexEnv (e.g., my $x = zeros(10) works) * MultiLine::PPI (handles multiline input like perldl) * NiceSlice (PDL::NiceSlice works too!) * Packages (keeps track of current user package) * PDLCommands (perldl shell v1 convenience routines) * ReadLineHistory * Save and restore command history to file * CompletionDrivers * Globals (completion for globals) * INC (completion for use module::name) * Keywords (completion for perl keywords) * LexEnv (completion for lexical vars) * Methods (completion of method names) Default PDL modules loaded: * PDL * PDL::Dbg * PDL::Doc::Perldl * PDL::IO::Dumper * PDL::IO::FlexRaw * PDL::IO::Pic * PDL::Image2D * PDL::AutoLoader ? and ?? are aliases for help and apropos Arguments to help|usage|apropos|sig|badinfo|demo are autoquoted Shell escapes start with $PERLDL::ESCAPE as the first character of a line ('#' by default). l prints the last lines of history, default 20. p prints the following args separated by space (i.e., $,=' ') demo as a command by itself lists the possible demos available. Otherwise it runs the specified demo. By default, leading patterns matching the pdl2 shell prompt ('pdl> ' with possible surrounding white space) are stripped from the input. That allows for easy cut-and-paste of pdl2 sessions from examples, demos, or docs. The Perldl2 shell, pdl2, loads/saves from the same history file as perldl. The Perldl2 shell, pdl2, loads your .perldlrc file from the same location as the perldl shell does. It also accepts .pdlrc as the name---looking forward to the new naming scheme for the interactive shell. A local.pdlrc or local.perldlrc are run if present as well. PDL-2.074/Perldl2/Makefile.PL0000644000175000017500000000327414146003631015355 0ustar osboxesosboxesuse strict; use warnings; use ExtUtils::MakeMaker; my @podpms = map { $_.".pod", '$(INST_LIBDIR)/' . $_ .".pod"} qw/pdl2/; # Make sure we have the PDL CONFIG hash loaded, and try to load it # from perldl.conf if not. use File::Spec; unless (%PDL::Config) { our %PDL_CONFIG; do File::Spec->catfile('..', 'perldl.conf') ; %PDL::Config = %PDL_CONFIG; } # Extra build target to build the doc database undef &MY::postamble; # suppress warning *MY::postamble = sub { my $text = ''; $text .= << "EOPS" ; pdl2.pod : pdl2 \t\$(PERLRUN) -MPod::Select -e "podselect('pdl2');" > pdl2.pod EOPS return $text; }; if (!defined $PDL::Config{WITH_DEVEL_REPL}) { if (eval 'require Devel::REPL;') { # Only generate Makefile if we have Devel::REPL WriteMakefile( 'NAME' => 'PDL::Perldl2', 'VERSION' => '2.000', 'EXE_FILES' => [ 'pdl2' ], 'DIR' => [ qw(Profile Plugin) ], 'PM' => { 'Script.pm' => '$(INST_LIBDIR)/Perldl2/Script.pm', @podpms }, NO_MYMETA => 1, ); } else { # Devel::REPL was not found $PDL::Config{WITH_DEVEL_REPL} = 0; my $msg = "Devel::REPL is not installed, will not build Perldl2 shell"; write_dummy_make($msg); } } elsif ($PDL::Config{WITH_DEVEL_REPL}) { # They want it, so make it WriteMakefile( 'NAME' => 'PDL::Perldl2', 'VERSION' => '2.000', 'EXE_FILES' => [ 'pdl2' ], 'DIR' => [ qw(Profile Plugin) ], 'PM' => { 'Script.pm' => '$(INST_LIBDIR)/Perldl2/Script.pm', @podpms }, clean => { FILES => 'pdl2.pod' }, NO_MYMETA => 1, ); } else { # they don't want it, so generate a dummy write_dummy_make('Not making or installing Perldl2 shell, per configuration'); } PDL-2.074/t/0000755000175000017500000000000014200406301012324 5ustar osboxesosboxesPDL-2.074/t/clump.t0000644000175000017500000000370214146003631013643 0ustar osboxesosboxes# Test ->clump(). This is not yet good enough: we need # nasty test cases use Test::More tests => 5; use PDL::LiteF; use strict; use warnings; $|=1; # PDL::Core::set_debugging(1); kill 'INT',$$ if $ENV{UNDER_DEBUGGER}; # Useful for debugging. #$pa = zeroes(4,4) * zeroes(4,4); # $pa = zeroes(4,4) ; #print $pa; # #print $pa->at(3,3); # #exit 4; my $eps = 0.01; # tolerance for tests if(0) { # TODO dead code my $a0 = zeroes(3,3); note $a0; my $b0 = 10 * $a0; note $b0; } { # TODO no test here my $pa0 = zeroes(3,3); #my $pa = $pa0->PDL::Core::new_or_inplace($a0); my $pa = $pa0->copy; my $pb = $pa->transpose; note $pa; # PDL::Primitive::axisvalues($pb); # note $pa; } { # TODO no test here my $pa0 = xvals(zeroes(3,3)); my $pa1 = yvals(zeroes(3,3)); my $pa2 = 10*$pa1; my $pa3 = $pa0 + $pa1; for my $p ( $pa0, $pa1, $pa2, $pa3 ) { note $p; } } { my $pa = xvals(zeroes(3,3)) + 10*yvals(zeroes(3,3)); note $pa; my $pb = $pa->clump(-1); # $pb->make_physical(); # $pa->jdump(); # $pb->jdump(); note $pb; ok(all(PDL::approx($pb,pdl([0,1,2,10,11,12,20,21,22]), $eps)),'clump(-1) entire ndarray'); my $pc = $pa->slice('0:2:2,:'); my $pd = $pc->clump(-1); my $pe = $pd->slice("2:4"); my $pf = ""; # Warning eater $pf= $pe->copy(); kill 'INT',$$ if $ENV{UNDER_DEBUGGER}; # Useful for debugging. # ok(2,$@ =~ /^clump: Increments do not match/); # Clump supports this now. ok(all(PDL::approx($pd,pdl([0,2,10,12,20,22]), $eps)),'clump(-1) slice with skip and whole dim'); ok(all(PDL::approx($pe,pdl([10,12,20]), $eps)),'clump(-1) slice'); # SF bug #406 clump(-N) failure ##-- test data my $a1 = sequence(2,13); my $b1 = sequence(3,2,13); ##-- bash to max 2 dimensions my $a2 = $a1->clump(-2); ##-- no-op my $b2 = $b1->clump(-2); ##-- merge 1st 2 dims ok($a1->ndims == 2, "no-op clump(-2)"); ok($b2->ndims == 2, "general clump(-2)"); } PDL-2.074/t/thread.t0000644000175000017500000001211714200150406013764 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::LiteF; { # 1. Test that changes do flow my $pa = pdl 2,3,4; $pa->doflow; my $pb = $pa + $pa; is($pb->at(0), 4); is($pb->at(1), 6); $pa->set(0,50); is($pb->at(0), 100); is($pb->at(1), 6); # exercise that set_datatype destroys trans # XXX if set datatype of $pa, $pb gets a corrupted value of 64.0000158399343 $pb->set_datatype(PDL::float()->enum); $pa->set(0,60); is($pb->at(0), 100); } { # 2. If we don't want flow, we mustn't have it. my $pa = pdl 2,3,4; my $pb = $pa + $pa; is($pb->at(0), 4); is($pb->at(1), 6); $pa->set(0,50); is($pb->at(0), 4); is($pb->at(1), 6); } { # 3. Test what happens when we assign to $pb. (no coredumps allowed) my $pa = pdl 2,3,4; $pa->doflow; my $pb = $pa + $pa; is($pb->at(0), 4); is($pb->at(1), 6); $pb->set(0,50); $pb->sever; # As of 2.064 you must break the dataflow manually is($pb->at(0), 50); is($pb->at(1), 6); is($pa->at(0), 2); is($pa->at(1), 3); $pa->set(0,33); is($pb->at(0), 50); is($pb->at(1), 6); is($pa->at(0), 33); is($pa->at(1), 3); } { # 4. Now a basic slice test. Once Incs etc. are back, need # to do this also with other kinds of slices. # This gets so hairy that we want to use strings for testing. my $pa = pdl [2,3,4],[5,6,7]; is("$pa", <slice('1:2,:'); is("$pb", <set(1,1,9); is("$pa", <slice('0:1,:'); is("$pc", <set(0,0,8); is("$pa", < b . . . > b' -> f # | | # V V # d - - - > d' # | | # V V # e . . . > e' -> g # # which, although it does not exercise *every* code path, still # does a lot. $pa = pdl [2,3,4],[5,6,7]; $pa->doflow; $pb = $pa + 1; is("$pb", <slice('1:2,:'); $pe = $pd->slice('1,:'); $pd += 0.5; $pf = $pb * 2; # This checks whether the system realizes to look for the new $pe. $pg = $pe - 15; $pa->set(0,0,8); $pa->set(1,0,9); $pa->set(2,0,10); @ps = ($pa,$pb,$pc,$pd,$pe,$pf,$pg); undef @ps; is("$pa", <doflow; my $a2 = pdl 2; $pb = $pa * $a2; is("$pb", "[4 6 8]"); $pc = pdl 1; $pb += $pc; is("$pb", "[5 7 9]"); $pa->set(1,5); is("$pb", "[5 11 9]"); } } # 7. What about axisvals: { my $pa = zeroes 5,3; is("$pa", <transpose; axisvalues($pc->inplace); is("$pc", <slice("1:3,1:3"); $pc = $pb->slice("(1),(1)"); is($pc->at(), 0); $pa .= 1; is($pc->at(), 1); $pa .= 2; is($pc->at(), 2); } { my $pa = pdl [2,3,4],[5,6,7]; $pa->doflow; my $a2 = pdl 1; my $pb = $pa + $a2; is("$pb", <thread(0,1); $pb->make_physical(); $pc->make_physical(); maximum($pa->thread(0,1),$pc); cmp_ok($pb->at(0,0), '==', 10, 'at(0,0)'); cmp_ok($pb->at(1,1), '==', 14, 'at(1,1)'); minimum($pa->thread(0,1),$pb->thread(0,1)); cmp_ok($pb->at(0,0), '==', 0, 'at(0,0)'); cmp_ok($pb->at(1,1), '==', 4, 'at(1,1)'); } { # Now, test 'unthread'. my $pa = zeroes(4,5,6); my $pb = $pa->thread(1); my $pc = $pb->unthread(2); is(join(',',$pc->dims), "4,6,5", 'unthread dims'); # $pb->jdump; $pc->jdump; } { #### Now, test whether the Perl-accessible thread works: my $pa = pdl [[0,1,2],[3,4,5],[6,7,8]],[[10,11,12],[13,14,15],[16,17,18]]; my $pb = pdl [2,3,4]; PDL::threadover_n($pa,$pb,sub {print "ROUND: @_\n"}); # As well as with virtuals... PDL::threadover_n($pa->slice("-1:0,-1:0"),$pb,sub {print "ROUND: @_\n"}); } done_testing; PDL-2.074/t/lvalue.t0000644000175000017500000000065414146003631014016 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use Test::Exception; use PDL::LiteF; use PDL::Lvalue; BEGIN { if ( PDL::Lvalue->subs and !$^P) { plan tests => 3; } else { plan skip_all => "no lvalue sub support"; } } $| = 1; ok (PDL::Lvalue->subs('slice'),"slice is an lvalue sub"); my $pa = sequence 10; lives_ok { $pa->slice("") .= 0; } "lvalue slice ran OK"; is($pa->max, 0, "lvalue slice modified values"); PDL-2.074/t/math.t0000644000175000017500000000467014160015533013461 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::LiteF; use PDL::Math; use Config; sub tapprox { my($pa,$pb) = @_; all approx $pa, $pb, 0.01; } ok( tapprox(bessj0(0.5),0.9384) && tapprox(bessj0(0),1) ,"bessj0"); ok( tapprox(bessj1(0.1),0.0499) && tapprox(bessj1(0),0) ,"bessj1"); ok( tapprox(bessjn(0.8,3),0.010) && tapprox(bessyn(0.2,2),-32.15714) ,"bessjn"); { # test inplace my $pa = pdl(0.5,0.0); $pa->inplace->bessj0; eval { $pa->inplace->bessj0(PDL->null) }; isnt $@, '', 'check providing explicit output arg to inplace throws exception'; ok( tapprox($pa,pdl(0.9384,1)), "bessj0 inplace" ); } { my $pa = pdl(0.2); $pa->inplace->bessyn(2); ok( tapprox( $pa, -32.15714 ), "bessyn inplace" ); } ok( tapprox( pow(2,3),8), "pow"); ok( tapprox(erf(0.),0.) && tapprox(erf(30.),1.),"erf(0), erf(30)"); ok( tapprox(erf(0.5),1.-erfc(0.5)), "erf and erfc"); ok( tapprox(erf(erfi(0.5)),0.5) && tapprox(erfi(erf(0.5)),0.5), "erfi (both ways)"); { my $pa = pdl(0.0,30.0); $pa->inplace->erf; ok( tapprox( $pa, pdl(0.0,1.0) ), "erf inplace" ); } { my $pa = pdl(0.5); $pa->inplace->erfc; ok( tapprox( 1.0-$pa, erf(0.5) ), "erfc inplace" ); } { my $pa = pdl( 0.01, 0.0 ); ok( all( approx( erfi($pa), pdl(0.00886,0.0) )), "erfi" ); $pa->inplace->erfi; ok( all( approx( $pa, pdl(0.00886,0.0) )), "erfi inplace" ); } ok( all approx( qsort( (polyroots( pdl( 1,-55,1320,-18150,157773,-902055, 3416930,-8409500,12753576,-10628640,3628800 ), zeroes(11) ))[0] ), 1+sequence(10) ) ); { my $pa = sequence(41) - 20; $pa /= 4; #do test on quarter-integers, to make sure we're not crazy. my $ans_rint = pdl(-5,-5,-4,-4,-4,-4,-4,-3,-3,-3,-2,-2,-2,-2,-2, -1,-1,-1,0,0,0,0,0,1,1,1,2,2,2,2,2,3,3,3,4,4,4,4,4,5,5); ok(all(rint($pa)==$ans_rint),"rint"); } ok( tapprox(sinh(0.3),0.3045) && tapprox(acosh(42.1),4.43305), "sinh, acosh"); ok( tapprox(acos(0.3),1.2661) && tapprox(tanh(0.4),0.3799), "acos, tanh"); ok( tapprox(cosh(2.0),3.7621) && tapprox(atan(0.6),0.54041), "cosh, atan"); { # inplace my $pa = pdl(0.3); $pa->inplace->sinh; ok( tapprox($pa, pdl(0.3045)), "sinh inplace" ); } if ($Config{cc} ne 'cl') { # lgamma not implemented for MS compilers my @x = lgamma(-0.1); is(approx($x[0], 2.36896133272879), 1); is($x[1], -1); @x = lgamma(1.1); is(approx($x[0], -0.0498724412598397), 1); is($x[1], 1); my $p = sequence (1); $p->badvalue (0); $p->badflag (1); @x = lgamma($p->index(0)); is($x[0]->badflag(), 1); is($x[1]->badflag(), 1); } done_testing; PDL-2.074/t/pthread.t0000644000175000017500000001310714160015533014152 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::LiteF; use Benchmark qw(timethese :hireswallclock); plan skip_all => 'No threads' if !PDL::Core::pthreads_enabled; approx( pdl(0), pdl(0), 0.01); # set eps set_autopthread_size(0); for ( [ 6, [6], 6, 0 ], [ 6, [5], 5, 0 ], [ 6, [4], 4, 0 ], [ 6, [7], 6, 0 ], [ 6, [7,12], 6, 1 ], [ 6, [5,12], 6, 1 ], [ 6, [12,7], 6, 0 ], [ 6, [12,5], 6, 0 ], [ 6, [7,5], 6, 0 ], [ 6, [4,5], 5, 1 ], [ 6, [5,4], 5, 0 ], [ 6, [4,5,12], 6, 2 ], [ 4, [9,6,2], 4, 1 ], [ 4, [6,9,2], 4, 0 ], ) { my ($thr_num, $size, $thr_want, $dim) = @$_; set_autopthread_targ($thr_num); (my $t = zeroes(@$size))++; is(get_autopthread_actual(), $thr_want, "right pthread no"); is(get_autopthread_dim(), $dim, "right pthread dim"); } set_autopthread_targ(0); my ($pa, $pb, $thr_want); my @T = ( [ sub { $_[0]->add_threading_magic(@_[1, 2]) }, sub { $_[0]->remove_threading_magic }, sub {}, {threaded => sub { $pa **= 1.3 }, unthreaded => sub { $pb **= 1.3 }}, 'explicit', ], [ sub { set_autopthread_targ($thr_want = $_[2]) }, sub { set_autopthread_targ(0); }, sub { is(get_autopthread_actual(), $thr_want, "right threadno auto") }, {threaded => sub { $pa **= 1.3 }}, 'auto', ], ); for (@T) { my ($thr_on, $thr_off, $thr_check, $bench_hash, $label) = @$_; { $pa = zeroes(2000000); $pb = zeroes(2000000); $thr_on->($pa, 0, 9); my $bench = timethese(20, $bench_hash); #diag explain $bench; $thr_check->(); ok all(approx $pa,$pb), "pa and pb match $label" or diag "diff at:", ($pa != $pb)->whichND.""; } { $pa = sequence(3,10); $pb = ones(3); $thr_on->($pa, 1, 2); my $pc = inner $pa, $pb; $thr_off->($pa); my $cc = $pa->sumover; ok all(approx($pc,$cc)), "inner $label" or diag "pc=$pc\ncc=$cc"; } { # Try multi-dim cases $pa = zeroes(200000,2,2); $pb = zeroes(200000,2,2); $thr_on->($pa, 0, 2); $pa+=1; $thr_off->($pb); $pb+=1; ok all(approx $pa, $pb), "+= $label"; } ### Multi-dimensional incrementing case ### ## This is performed multiple times to be sure that indexing isn't ## messed up for the multiple pthreads foreach (1..20){ $pa = zeroes(3, 200000,2,2); $thr_on->($pa, 1, 2); $pa += 1; ok( $pa->max < 1.1, "multi-run $label" ); # Should never be greater than 1 } { ### Pthread Indexing Test #### ### This checks for a problem seen in the dataflow back to the parent PDL (i.e. writeback xs code) ### seen when pthreading is present my $indexArg = pdl [[1]]; my $lutEx = pdl [[1,0],[0,1]]; # Do a pthreaded index operation $thr_on->($lutEx, 1, 2); my $in = $lutEx->index($indexArg); # Remove pthreading magic. This is a check to see if pthreading doesn't cause # errors in the lazy evaluation of the index operation that occurs in the following # inplace-assignment operation. $thr_off->($lutEx); # Do inplace assignment so that data is written back to the parent pdl: # The lazy evaluation of the index operation will occur here first $in .= 1; # Check for writeback to the parent PDL working (should have three ones in the array) my $lutExSum = $lutEx->sum; ok all(approx($lutExSum, pdl(3))), "writeback $label"; # Check for inplace assignment working. $in should be all ones my $inSum = $in->sum; ok all(approx($inSum, pdl(2) )), "inplace $label"; } { ### Pthread Indexing Test #### ### Similar test to above, but the pthreading magic is changed (not just ### deleted) after the index operation my $indexArg = pdl [[1]]; my $lutEx = pdl [[1,0,0,1],[0,1,0,1]]; # Do a pthreaded index operation $thr_on->($lutEx, 1, 2); my $in = $lutEx->index($indexArg); $in->make_physical; # make sure the initial indexing operation has taken place # otherwise gets defered due to lazy evaluation. # Remove pthreading magic, and then add it back on another dim with # 4 threads. This is a check to see if pthreading doesn't cause # errors in the writeback-code of the index operation that occurs in the following # inplace-assignment operation. $thr_off->($lutEx); $thr_on->($lutEx, 0, 4); # Do inplace assignment so that data is written back to the parent pdl: # The lazy evaluation of the index operation will occur here first $in .= 1; # Check for writeback to the parent PDL working (should have three ones in the array) my $lutExSum = $lutEx->sum; ok all(approx($lutExSum, pdl(5))), "writeback with different magic $label"; # Check for inplace assignment working. $in should be all ones my $inSum = $in->sum; ok all(approx($inSum, pdl(2))), "inplace with different magic $label"; } } # These tests check for proper deferred handling of barf and warn messages when pthreading. ## Check Handling of barf messages when pthreading ### # These statements will cause pthread to happen in two pthreads set_autopthread_targ(2); set_autopthread_size(0); # Because of the duplicate 8's interpolates barf (in the PPcode) will get # called. This should not cause a segfault my $x = float( [1, 2, 3, 4, 5, 8, 9, 10], [1, 2, 3, 4, 5, 8, 8, 8] ); my $y = ($x * 3) * ($x - 2); # Setup to silence warning messages local $SIG{__WARN__} = sub { }; # Catch barf messages by running in eval: eval{ my ( $ans, $err ) = interpolate(8.5, $x, $y ); }; like( $@, qr/identical abscissas/ , "interpolate barf" ); # warning message segfaults when pthreaded if messages not deferred properly my $mask = zeroes(5,5); local $SIG{__WARN__} = sub { die $_[0] }; $mask->badvalue(1); eval{ PDL::gt($mask, 2, 0) }; like( $@, qr/Badvalue is set to/, "safe barf" ); done_testing; PDL-2.074/t/thread_def.t0000644000175000017500000000246714160262364014625 0ustar osboxesosboxesuse Test::More tests => 5; use PDL::LiteF; use Test::Exception; use strict; use warnings; my $debug = 0; $PDL::debug = $debug; my $pa = sequence(3,4); my $pb = yvals(zeroes(4,3)) + sequence(4); my $pc = $pa->transpose->slice(':,-1:0'); # not very useful examples but simple and test the essentials thread_define 'tline(a(n);b(n))', over { $_[0] .= $_[1]; }; thread_define 'tassgn(a(n,m);[o] b())', over { # sumover($_[0],$_[1]); $_[1] .= $_[0]->sum; }; thread_define 'ttext(a(n=3)), NOtherPars => 1', over { ${$_[1]} .= sprintf("%.3f %.3f %.3f,\n",$_[0]->list); #join(' ',$_[0]->list) . ",\n"; }; thread_define 'tprint(a(n);b(n)), NOtherPars => 1', over { ${$_[2]} .= "$_[1]"; }; PDL::Core::set_debugging(1) if $debug; tline($pc,$pb); note $pa; note $pb; ok(all approx($pc,$pb)); $pc = ones(5); # produce an error throws_ok { tline($pa,$pc); } qr/conflicting/; $pa = ones(2,3,4)*sequence(4)->slice('*,*,:'); note $pa; tassgn($pa,($pb=null)); note "$pb\n"; $pb->dump; ok(all approx($pb,6*sequence(4))); # test if setting named dim with '=' raises error # correctly at runtime $pa = sequence(4,4); throws_ok { ttext($pa, \my $text); } qr/conflicting/; # test if dim=1 -> threaddim note "testing tprint\n"; $pa = sequence(3); $pb = pdl [1]; my $text = ""; tprint($pa, $pb, \$text); is $text, '[1 1 1]'; PDL-2.074/t/config.t0000644000175000017500000000044514146003631013771 0ustar osboxesosboxes# Verify that the Config.pm values were updated from the # actual build process. use strict; use warnings; use Test::More; use PDL::Config; # there should be no undef values ok( defined $PDL::Config{$_} , "check $_ in Config.pm" ) for grep { /^WITH_/ } keys %PDL::Config; done_testing(); PDL-2.074/t/bigmem.t0000644000175000017500000000302514167164337013777 0ustar osboxesosboxesuse strict; use warnings; use Test::More; BEGIN { if ($ENV{AUTOMATED_TESTING} or $ENV{CI}) { plan skip_all => 'bigmem tests skipped to avoid OOM fails'; } else { plan skip_all => 'bigmem tests skipped to avoid OOM fails'; # plan tests => 2; } } use PDL; # Tests for PDL::Core # # NOTE: pdl and PDL->new can't really be tested since the corresponding # perl data may be 10-100x bigger than the end pdl element sizes. # # A lot of these PDL::Core tests simply check that these routines don't # break for large pdls as a sanity check. Ideally, more thorough tests # could be done but code inspection/review might be more efficient. # # nelem # dims # shape my $bigbyte = ones( byte, 5*1024*1024*1024+17 ); ok( $bigbyte->shape->sclr == $bigbyte->nelem, "shape handles indx dims > 4GiB"); $bigbyte = ones(byte, 2**30, 4); my $aaa = $bigbyte->slice("3:-10"); my $bbb = $aaa->slice(":,3"); ok( $bbb->sum == $bbb->nelem, "slices of slices of giant PDLs seem to work right"); # ndims # getndims # dim # getdim # get_dataref # upd_data # doflow # flows # copy # unwind # make_physical # dummy # clump # thread_define # thread # diagonal # thread[123I] # sever # info # mslice # inplace, is_inplace, set_inplace, new_or_inplace # new_from_specification # zeros # ones # reshape # squeeze # flat # convert # byte|short|ushort|long|indx|longlong|float|double # set, at, sclr # cat, dog # set_autopthread_targ, get_autopthread_targ, get_autopthread_actual, set_autopthread_size, get_autopthread_size done_testing(); # tests done PDL-2.074/t/reduce.t0000644000175000017500000000070014020771662013774 0ustar osboxesosboxesuse Test::More tests => 5; use PDL::LiteF; use PDL::Reduce; use strict; use warnings; my $pa = sequence 5,5; my $pb = $pa->reduce('add',0); ok(all $pb == $pa->sumover); ok(all $pa->reduce('add',1) == $pa->mv(1,0)->sumover); ok(all $pa->reduce('mult',1) == $pa->mv(1,0)->prodover); # test the new reduce features ok($pa->reduce('+',0,1) == sum $pa); # reduce over list of dims ok(all $pa->reduce(\&PDL::sumover) == $pa->sumover); # use code refs PDL-2.074/t/constants.t0000644000175000017500000000056614146003631014544 0ustar osboxesosboxes# Simple tests for PDL::Constants use strict; use warnings; use Test::More; use PDL::Constants qw(PI E DEGRAD); # just checks values, assumes constant part is ok ok( abs( PI - 3.14159265358979 ) < 0.0001, 'PI is defined'); ok( abs( E - 2.71828182845905 ) < 0.0001, 'E is defined'); ok( abs( DEGRAD - 57.295779513082321 ) < 0.0001, 'DEGRAD is defined'); done_testing(); PDL-2.074/t/01-pptest.t0000644000175000017500000003170714176331723014277 0ustar osboxesosboxesuse strict; use warnings; use ExtUtils::MakeMaker::Config; # to pick up EUMM-targeted config overrides use Test::More $Config{usedl} ? () : (skip_all => 'No dynaload; double-blib static build too difficult'); use File::Spec; use IPC::Cmd qw(run); use Cwd; use File::Basename; use File::Path; my %PPTESTFILES = ( 'Makefile.PL' => <<'EOF', use strict; use warnings; use ExtUtils::MakeMaker; use PDL::Core::Dev; my @pack = (["tests.pd", qw(Tests PDL::Tests), '', 1]); sub MY::postamble { pdlpp_postamble(@pack); }; # Add genpp rule my %hash = pdlpp_stdargs(@pack); $hash{OBJECT} .= ' ppcp$(OBJ_EXT)'; WriteMakefile(%hash); EOF 'ppcp.c' => <<'EOF', #include "pdl.h" /* to test the $P vaffining */ void ppcp(PDL_Byte *dst, PDL_Byte *src, int len) { int i; for (i=0;i <<'EOF', # make sure the deprecation mechanism throws warnings pp_deprecate_module( infavor => "PDL::Test::Fancy" ); our $VERSION = '0.01'; # so the Makefile.PL's VERSION_FROM picks it up pp_setversion(qq{'0.01'}); # this doesn't use $VERSION only to check a bug is fixed pp_add_macros(SUCC => sub { "($_[0] + 1)" }); sub pp_deft { my ($name,%hash) = @_; ## $hash{Doc} = "=for ref\n\ninternal\n\nonly for internal testing purposes\n"; $hash{Doc} = undef; $name = "test_$name"; # prepend test_ to name pp_def($name,%hash); } pp_addhdr(' void ppcp(PDL_Byte *dst, PDL_Byte *src, int len); '); # test the $P vaffine behaviour # when 'phys' flag is in. pp_deft('foop', Pars => 'byte [phys]a1(n); byte [o,phys]b(n)', GenericTypes => [B], Code => 'ppcp($P(b),$P(a1),$SIZE(n));', ); # test single-used phys dim of 1 ok pp_deft('foop1', Pars => 'byte a1(z); byte [o,phys]b(n)', GenericTypes => [B], Code => 'ppcp($P(b),$P(a1),$SIZE(n));', ); # float qualifier # and also test if numerals in variable name work pp_deft( 'fsumover', Pars => 'a1(n); float [o]b();', Code => 'PDL_Float tmp = 0; loop(n) %{ tmp += $a1(); %} $b() = tmp;' ); # test GENERIC with type+ qualifier pp_deft( 'nsumover', Pars => 'a(n); int+ [o]b();', Code => '$GENERIC(b) tmp = 0; loop(n) %{ tmp += $a(); %} $b() = tmp;' ); # test to set named dim with 'OtherPar' pp_deft('setdim', Pars => '[o] a(n)', OtherPars => 'int ns => n', Code => 'loop(n) %{ $a() = n; %}', ); pp_deft('fooseg', Pars => 'a(n); [o]b(n);', Code => ' loop(n) %{ $b() = $a(); %} '); # adapted from PDL::NDBin: if in=null and b is a scalar, was SEGV-ing pp_deft( '_flatten_into', Pars => "in(m); indx b(m); [o] idx(m)", Code => ' loop(m) %{ $idx() = $in(); %} ', ); pp_addhdr << 'EOH'; void tinplace_c1(int n, PDL_Float* data); void tinplace_c2(int n, PDL_Float* data1, PDL_Float* data2); void tinplace_c3(int n, PDL_Float* data1, PDL_Float* data2, PDL_Float* data3); EOH pp_deft('fooflow1', Pars => '[o,nc]a(n)', GenericTypes => ['F'], Code => 'tinplace_c1($SIZE(n),$P(a));', ); pp_deft('fooflow2', Pars => '[o,nc]a(n);[o,nc]b(n)', GenericTypes => ['F'], Code => 'tinplace_c2($SIZE(n),$P(a),$P(b));', ); pp_deft('fooflow3', Pars => '[o,nc]a(n);[o,nc]b(n);[o,nc]c(n)', GenericTypes => ['F'], Code => 'tinplace_c3($SIZE(n),$P(a),$P(b),$P(c));', ); pp_deft( 'threadloop_continue', Pars => 'in(); [o] out()', Code => q[ int cnt = 0; threadloop %{ if ( ++cnt %2 ) continue; $out() = $in(); %} ], ); pp_deft('succ', Pars => 'a(); [o] b()', GenericTypes => ['F'], Code => '$b() = $SUCC($a());', ); # test whitespace problem with POD and pp_addxs pp_addxs( '', <<'EOXS' ); int just_one() CODE: RETVAL = 1; OUTPUT: RETVAL =pod =begin comment A comment. =end comment =cut EOXS # test whitespace problem with pp_line_numbers and pp_add_boot pp_add_boot pp_line_numbers(__LINE__, q{ /* nothing happening here */ }); # test fixed value for named dim, wrong Code for simplicity pp_deft('Cpow', Pars => 'a(m=2); b(m=2); [o]c(m=2)', Code => '$c(m => 0) = $a(m => 0) + $b(m => 0);', ); # test XS args with OtherPars pp_deft('gl_arrows', Pars => 'coords(tri=3,n); int indsa(); int indsb();', OtherPars => 'float headlen; float width;', Code => ';', # do nothing ); # test XS args with funky Pars ordering pp_deft('polyfill_pp', Pars => 'int [o,nc] im(m,n); float ps(two=2,np); int col()', Code => ';', # do nothing ); # test valid non-single-letter GenericTypes arg pp_def( "rice_compress", Pars => 'in(n); [o]out(m); int[o]len(); lbuf(n)', GenericTypes =>['B','S','US','L'], Code => ';', # do nothing ); pp_done; # this tests the bug with a trailing comment and *no* newline EOF 't/all.t' => <<'EOF', use strict; use warnings; use Test::More; use Test::Warn; BEGIN { $ENV{PDL_AUTOPTHREAD_TARG} = 1 } # for continue-in-threadloop test use PDL::LiteF; use PDL::Types; use PDL::Dbg; BEGIN { warning_like{ require PDL::Tests; PDL::Tests->import; } qr/deprecated.*PDL::Test::Fancy/, "PP deprecation should emit warnings"; } # Is there any good reason we don't use PDL's approx function? sub tapprox { my($x,$y) = @_; my $c = abs($x-$y); my $d = max($c); return $d < 0.01; } my $x = xvals(zeroes(byte, 2, 4)); my $y; # $P() affine tests test_foop($x,($y=null)); ok( tapprox($x,$y) ) or diag $y; test_foop($x->transpose,($y=null)); ok( tapprox($x->transpose,$y) ) or diag $y; my $vaff = $x->dummy(2,3)->xchg(1,2); test_foop($vaff,($y=null)); ok( tapprox($vaff,$y) ) or diag ($vaff, $vaff->dump); eval { test_foop($x,($y=pdl([1]))) }; isnt $@, '', '[phys] with multi-used mismatched dim of 1 throws exception'; eval { test_foop(pdl([1]),($y=pdl([1]))) }; is $@, '', '[phys] with multi-used matched dim of 1 no exception'; eval { test_foop1($x,($y=pdl([1]))) }; is $@, '', '[phys] with single-used dim of 1 no exception'; # float qualifier $x = ones(byte,3000); test_fsumover($x,($y=null)); is( $y->get_datatype, $PDL_F ); is( $y->at, 3000 ); # int+ qualifier for (byte,short,ushort,long,float,double) { $x = ones($_,3000); test_nsumover($x,($y=null)); is( $y->get_datatype, (($PDL_L > $_->[0]) ? $PDL_L : $_->[0]) ); is( $y->at, 3000 ); } test_setdim(($x=null),10); is( join(',',$x->dims), "10" ); ok( tapprox($x,sequence(10)) ); # this used to segv under solaris according to Karl { my $ny=7; $x = double xvals zeroes (20,$ny); test_fooseg $x, $y=null; ok( 1 ); # if we get here at all that is alright ok( tapprox($x,$y) ) or diag($x, "\n", $y); } eval { test__flatten_into(null, 2) }; ok 1; #was also segfaulting # test the bug alluded to in the comments in # pdl_changed (pdlapi.c) # used to segfault my $xx=ones(float,3,4); my $sl1 = $xx->slice('(0)'); my $sl11 = $sl1->slice(''); my $sl2 = $xx->slice('(1)'); my $sl22 = $sl2->slice(''); test_fooflow2($sl11, $sl22); ok(all $xx->slice('(0)') == 599); ok(all $xx->slice('(1)') == 699); # test that continues in a threadloop work { my $in = sequence(10); my $got = $in->zeroes; my $exp = $in->copy; my $tmp = $exp->where( ! ($in % 2) ); $tmp .= 0; test_threadloop_continue( $in, $got ); ok( tapprox( $got, $exp ), "continue works in threadloop" ) or do { diag "got : $got"; diag "expected: $exp" }; } test_Cpow(sequence(2), 1); test_polyfill_pp(zeroes(5,5), ones(2,3), 1); is test_succ(2)."", 3, 'test pp_add_macros works'; done_testing; EOF ); my %BADOTHERPARSFILES = ( 'Makefile.PL' => <<'EOF', use strict; use warnings; use ExtUtils::MakeMaker; use PDL::Core::Dev; my @pack = (["otherpars.pd", qw(Otherpars PDL::Otherpars)]); sub MY::postamble { pdlpp_postamble(@pack) } WriteMakefile(pdlpp_stdargs(@pack)); EOF 'otherpars.pd' => <<'EOF', pp_def( "myexternalfunc", Pars => " p(m); x(n); [o] y(); [t] work(wn); ", OtherPars => 'int flags;', RedoDimsCode => ' int im = $PDL(p)->dims[0]; int in = $PDL(x)->dims[0]; int min = in + im * im; int inw = $PDL(work)->dims[0]; $SIZE(wn) = inw >= min ? inw : min;', Code => 'int foo = 1; '); pp_def( "myexternalfunc2", Pars => "x(m);", OtherPars => 'int I;', Code => 'int foo = 1; ' ); pp_done(); EOF 't/all.t' => <<'EOF', use strict; use warnings; use Test::More tests => 1; use PDL::LiteF; use_ok 'PDL::Otherpars'; EOF ); my %BADPARSFILES = ( 'Makefile.PL' => <<'EOF', use strict; use warnings; use ExtUtils::MakeMaker; use PDL::Core::Dev; my @pack = (["otherpars.pd", qw(Otherpars PDL::Otherpars)]); sub MY::postamble { pdlpp_postamble(@pack) } WriteMakefile(pdlpp_stdargs(@pack)); EOF 'otherpars.pd' => <<'EOF', pp_def( "myexternalfunc3", Pars => "I(m);", Code => 'int foo = 1; ' ); pp_done(); EOF 't/all.t' => <<'EOF', use strict; use warnings; use Test::More tests => 1; use PDL::LiteF; use_ok 'PDL::Otherpars'; EOF ); my %THREADTESTFILES = ( 'Makefile.PL' => <<'EOF', use strict; use warnings; use ExtUtils::MakeMaker; use PDL::Core::Dev; my @pack = (["threadtest.pd", qw(ThreadTest PDL::ThreadTest)]); sub MY::postamble { pdlpp_postamble(@pack); }; # Add genpp rule WriteMakefile(pdlpp_stdargs(@pack)); EOF 'threadtest.pd' => <<'EOF', # previously in t/inline-comment-test.t pp_addpm(pp_line_numbers(__LINE__-1, q{ sub myfunc { } })); pp_def('testinc', Pars => 'a(); [o] b()', Code => q{ /* emulate user debugging */ /* Why doesn't this work???!!!! */ threadloop %{ /* printf(" %f, %f\r", $a(), $b()); printf(" Here\n"); */ /* Sanity check */ $b() = $a() + 1; %} }, ); # make sure that if the word "threadloop" appears, later automatic threadloops # will not be generated, even if the original threadloop was commented-out pp_def('testinc2', Pars => 'a(); [o] b()', Code => q{ /* emulate user debugging */ /* Why doesn't this work???!!!! */ /* threadloop %{ printf(" %f, %f\r", $a(), $b()); printf(" Here\n"); %} */ /* Sanity check */ $b() = $a() + 1; }, ); pp_done(); EOF 't/all.t' => <<'EOF', use strict; use warnings; use Test::More; use PDL::LiteF; use_ok 'PDL::ThreadTest'; my $x = sequence(3,3); my $y = $x->testinc; ok(all ($y == $x+1), 'Sanity check runs correctly'); # Test the inability to comment-out a threadloop. This is documented on the # 11th page of the PDL::PP chapter of the PDL book. If somebody ever fixes this # wart, this test will fail, in which case the book's text should be updated. $y = $x->testinc2; TODO: { # Note: This test appears to fail on Cygwin and some flavors of Linux. local $TODO = 'This test inexplicably passes on some machines'; ok(not (all $y == $x + 1), 'WART: commenting out a threadloop does not work') or diag("\$x is $x and \$y is $y"); } done_testing; EOF ); do_tests(\%THREADTESTFILES); do_tests(\%PPTESTFILES); do_tests(\%BADOTHERPARSFILES, qr/Invalid OtherPars name/); do_tests(\%BADPARSFILES, qr/Invalid Pars name/); sub do_tests { my ($hash, $error_re) = @_; in_dir( sub { hash2files(File::Spec->curdir, $hash); local $ENV{PERL5LIB} = join $Config{path_sep}, @INC; run_ok(qq{"$^X" Makefile.PL}); run_ok(qq{"$Config{make}" test}, $error_re); }, ); } sub run_ok { my ($cmd, $error_re) = @_; my $res = run(command => $cmd, buffer => \my $buffer); if ($error_re) { ok !$res, 'Fails to build if invalid'; like $buffer, $error_re, 'Fails with expected error'; return; } if (!$res) { ok 0, $cmd; diag $buffer; return; } ok 1, $cmd; } sub hash2files { my ($prefix, $hashref) = @_; while(my ($file, $text) = each %$hashref) { # Convert to a relative, native file path. $file = File::Spec->catfile(File::Spec->curdir, $prefix, split m{\/}, $file); my $dir = dirname($file); mkpath $dir; my $utf8 = ($] < 5.008 or !$Config{useperlio}) ? "" : ":utf8"; open(my $fh, ">$utf8", $file) || die "Can't create $file: $!"; print $fh $text; close $fh; } } sub in_dir { my $code = shift; require File::Temp; my $dir = shift || File::Temp::tempdir(TMPDIR => 1, CLEANUP => 1); # chdir to the new directory my $orig_dir = getcwd(); chdir $dir or die "Can't chdir to $dir: $!"; # Run the code, but trap the error so we can chdir back my $return; my $ok = eval { $return = $code->(); 1; }; my $err = $@; # chdir back chdir $orig_dir or die "Can't chdir to $orig_dir: $!"; # rethrow if necessary die $err unless $ok; return $return; } done_testing; PDL-2.074/t/ops-bitwise.t0000644000175000017500000000075114165665531015007 0ustar osboxesosboxesuse strict; use warnings; # Run ops.t with the experimental ‘bitwise’ feature enabled. BEGIN { if ("$]" < 5.022) { print "1..0 # skip Requires Perl 5.22\n"; exit; } } use feature 'bitwise'; use FindBin; open my $fh, "$FindBin::Bin/ops.t" or die "Cannot read $FindBin::Bin/ops.t: $!"; my $source = do { local $/; <$fh> }; close $fh; $source =~ s/use warnings;\K/no warnings 'experimental::bitwise';/; eval "#line 1 t/ops.t-run_by_ops-bitwise.t\n$source"; die $@ if $@; PDL-2.074/t/func.pdl0000644000175000017500000000015213265417442014000 0ustar osboxesosboxes # Test file for autoloader.t sub func { my $x = shift; return ($x**3 + 2); }; 1; # OK status PDL-2.074/t/bad.t0000644000175000017500000004776314176373422013303 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::LiteF; use PDL::Math; use PDL::Types qw(types); use Test::Warn; # although approx() caches the tolerance value, we # use it in every call just to document things # use constant ABSTOL => 1.0e-4; # check default behaviour (ie no bad data) # - probably overkill # my $x = pdl(1,2,3); is( $x->badflag(), 0, "no badflag" ); my $y = pdl(4,5,6); my $c = $x + $y; is( $c->badflag(), 0, "badflag not set in a copy" ); is( $c->sum(), 21, "sum() works on non bad-flag ndarrays" ); # is the flag propagated? $x->badflag(1); ok( $x->badflag(), "bad flag is now set" ); $c = $x + $y; ok( $c->badflag(), "bad flag is propagated" ); is( $c->sum(), 21, "sum is still 21 with badflag set" ); $x->badflag(0); $y->badflag(1); $c = $x + $y; ok( $c->badflag(), "badflag propagates on rhs of 'x+y'" ); # how about copies/vaffines/whatever $x = rvals( long, 7, 7, {Centre=>[2,2]} ); $y = $x; is( $y->badflag, 0, "badflag not set in a copy" ); $x->badflag(1); $y = $x; ok( $y->badflag, "badflag is now set in a copy" ); $x->badflag(0); $y = $x->slice('2:5,3:4'); $c = $y->slice('0:1,(0)'); is( $y->badflag, 0, "slice handling okay with no badflag" ); $x->badflag(1); # let's check that it gets through to a child of a child ok( $c->badflag, "badflag propagated through to a child" ); # can we change bad values is( byte->badvalue, byte->orig_badvalue, "byte bad value is set to the default value" ); byte->badvalue(23); is( byte->badvalue, 23, "changed bad value for byte" ); byte->badvalue( byte->orig_badvalue ); # check setbadat() $x = pdl(1,2,3,4,5); $x->setbadat(2); is( PDL::Core::string($x), "[1 2 BAD 4 5]", "setbadat worked" ); $y = $x->copy; is $y."", "[1 2 BAD 4 5]", "y correct bad before set_datatype"; $y->set_datatype(ushort->enum); is $y."", "[1 2 BAD 4 5]", "y correct bad after set_datatype"; $y = $x->copy; $y->badvalue('nan'); $y->setbadat(2); is $y."", "[1 2 BAD 4 5]", "y correct bad before set_datatype with badval=nan"; $y->set_datatype(ushort->enum); is $y."", "[1 2 BAD 4 5]", "y correct bad after set_datatype with badval=nan"; # now check that badvalue() changes the ndarray # (only for integer types) $x = convert($x,ushort); my $badval = $x->badvalue; $x->badvalue(44); is( PDL::Core::string($x), "[1 2 BAD 4 5]", "changed badvalue" ); $x->badflag(0); is( PDL::Core::string($x), "[1 2 44 4 5]", "can remove the badflag setting" ); # restore the bad value $x->badvalue($badval); $x = byte(1,2,3); $y = byte(1,byte->badvalue,3); $x->badflag(1); $y->badflag(1); # does string work? # (this has implicitly been tested just above) # is( PDL::Core::string($y), "[1 BAD 3]", "can convert bad values to a string" ); # does addition work $c = $x + $y; is( sum($c), 8, "addition propagates the bad value" ); # does conversion of bad types work $c = float($y); ok( $c->badflag, "type conversion retains bad flag" ); is( PDL::Core::string($c), "[1 BAD 3]", " and the value" ); is( sum($c), 4, " and the sum" ); $x = byte(1,2,byte->badvalue,byte->badvalue,5,6,byte->badvalue,8,9); $x->badflag(1); is( PDL::Core::string($x->isbad), "[0 0 1 1 0 0 1 0 0]", "isbad() works" ); is( PDL::Core::string($x->isgood), "[1 1 0 0 1 1 0 1 1]", "isgood() works" ); is( $x->nbad, 3, "nbad() works" ); is( $x->ngood, 6, "ngood() works" ); $x = byte( [255,255], [0,255], [0,0] ); $x->badflag(1); is( PDL::Core::string($x->nbadover), "[2 1 0]", "nbadover() works" ); is( PDL::Core::string($x->ngoodover), "[0 1 2]", "ngoodover() works" ); # check dataflow (or vaffine or whatever it's called) $x = byte( [1,2,byte->badvalue,4,5], [byte->badvalue,0,1,2,byte->badvalue] ); $x->badflag(1); $y = $x->slice(',(1)'); is( sum($y), 3, "sum of slice works" ); $y++; is( PDL::Core::string($x), "\n[\n [ 1 2 BAD 4 5]\n [BAD 1 2 3 BAD]\n]\n", "inplace addition of slice flows back to parent" ); $x = byte->badvalue * ones(byte,3,2); is( $x->get_datatype, byte->enum, "datatype remains a byte" ); $x->badflag(1); is( PDL::Core::string( PDL::zcover($x) ), "[BAD BAD]", "zcover() okay" ); $x->set(1,1,1); $x->set(2,1,1); is( PDL::Core::string( PDL::zcover($x) ), "[BAD 0]", " and still okay" ); # 255 is the default bad value for a byte array # $x = byte(1,2,255,4,5); is( $x->median, 4, "median() works on good ndarray" ); $x->badflag(1); is( $x->median, 3, "median() works on bad biddle" ); # as random() creates numbers between 0 and 1 it won't # accidentally create a bad value by chance (the default # bad value for a double is either a very negative # number or NaN). # $x = random(20); $x->badflag(1); is( $x->check_badflag, 0, "check_badflag did not find a bad value" ); # check out stats, since it uses several routines # and setbadif $x = pdl( qw(42 47 98 13 22 96 74 41 79 76 96 3 32 76 25 59 5 96 32 6) ); $y = $x->setbadif( $x < 20 ); my @s = $y->stats(); ok( approx( $s[0], 61.9375, ABSTOL ), "setbadif/stats test 1" ); ok( approx( $s[1], 27.6079, ABSTOL ), "setbadif/stats test 2" ); is( $s[2], 66.5, "setbadif/stats test 3" ); is( $s[3], 22, "setbadif/stats test 4" ); is( $s[4], 98, "setbadif/stats test 5" ); ok( approx( $s[6], 26.7312, ABSTOL ), "setbadif/stats test 6" ); # how about setbadtoval (was replacebad) $x = $y->setbadtoval(20) - pdl(qw(42 47 98 20 22 96 74 41 79 76 96 20 32 76 25 59 20 96 32 20)); ok( all($x == 0), "setbadtoval() worked" ); # and inplace? $x = pdl( qw(42 47 98 13 22 96 74 41 79 76 96 3 32 76 25 59 5 96 32 6) ); $y = $x->setbadif( $x < 20 ); $y->inplace->setbadtoval(20); $x = $y - pdl(qw(42 47 98 20 22 96 74 41 79 76 96 20 32 76 25 59 20 96 32 20)); ok( all($x == 0), " and inplace" ); # ditto for copybad $x = pdl( qw(42 47 98 13 22 96 74 41 79 76 96 3 32 76 25 59 5 96 32 6) ); $y = $x->setbadif( $x < 20 ); $c = copybad( $x, $y ); is( PDL::Core::string( $c->isbad ), "[0 0 0 1 0 0 0 0 0 0 0 1 0 0 0 0 1 0 0 1]", "isbad() worked" ); $x = pdl( qw(42 47 98 13 22 96 74 41 79 76 96 3 32 76 25 59 5 96 32 6) ); $y = $x->setbadif( $x < 20 ); $x->inplace->copybad( $y ); is( PDL::Core::string( $x->isbad ), "[0 0 0 1 0 0 0 0 0 0 0 1 0 0 0 0 1 0 0 1]", " and inplace" ); ## $x->inplace->setbadif( $x % 2 ) does NOT work because ## ($x % 2) is performed inplace - ie the flag is set for ## that function # ##$x = sequence(3,3); ##$x->inplace->setbadif( $x % 2 ); ###$x = $x->setbadif( $x % 2 ); # for when not bothered about inplace ##ok( PDL::Core::string( $x->clump(-1) ), ## "[0 BAD 2 BAD 4 BAD 6 BAD 8]" ); # ## look at propagation of bad flag using inplace routines... $x = sequence( byte, 2, 3 ); $x = $x->setbadif( $x == 3 ); $y = $x->slice("(1),:"); $x->inplace->setbadtoval(3); is( $y->badflag, 0, "badflag cleared using inplace setbadtoval()" ); $x = sequence( byte, 2, 3 ); $y = $x->slice("(1),:"); my $mask = sequence( byte, 2, 3 ); $mask = $mask->setbadif( ($mask % 3) == 2 ); $x->inplace->copybad( $mask ); is( $y->badflag, 1, "badflag propagated using inplace copybad()" ); # test some of the qsort functions $x = pdl( qw(42 47 98 13 22 96 74 41 79 76 96 3 32 76 25 59 5 96 32 6) ); $y = $x->setbadif( $x < 20 ); my $ix = qsorti( $y ); is( PDL::Core::string( $y->index($ix) ), "[22 25 32 32 41 42 47 59 74 76 76 79 96 96 96 98 BAD BAD BAD BAD]", "qsorti() okay" ); # # check comparison/bit operators in ops.pd $x = pdl( 2, 4, double->badvalue ); $x->badflag(1); $y = abs( $x - pdl(2.001,3.9999,234e23) ) > 0.01; is( PDL::Core::string( $y ), "[0 0 BAD]", "abs() and >" ); $y = byte(1,2,byte->badvalue,4); $y->badflag(1); is( PDL::Core::string( $y << 2 ), "[4 8 BAD 16]", "<<" ); $x = pdl([1,2,3]); $x->badflag(1); $y = $x->assgn; is( $y->badflag, 1, "assgn propagated badflag"); $x->badflag(0); is( $y->badflag, 1, "assgn is not a deep copy for the badflag"); $x = pdl q[BAD]; is( PDL::Core::string($x), 'BAD', 'can convert PDL to string' ); is( $x->at, 'BAD', 'at() returns BAD for a bad value' ); isnt( $x->sclr, 'BAD', 'sclr() ignores bad value' ); $x = pdl 4; $x->badflag(1); $x->badvalue(4); is( $x->at, 'BAD', 'at() returns BAD for a bad value with non-default badvalue' ); is( $x->sclr, 4, 'sclr() ignores bad value' ); $x = pdl(0.5,double->badvalue,0); $x->badflag(1); $y = bessj0($x); is( PDL::Core::string( isbad($y) ), "[0 1 0]", "bessj0()" ); $x = pdl(double->badvalue,0.8); $x->badflag(1); $y = bessjn($x,3); # thread over n() is( PDL::Core::string( isbad($y) ), "[1 0]", "thread over bessjn()" ); ok( abs($y->at(1)-0.010) < 0.001 ); $x = pdl( 0.01, 0.0 ); $x->badflag(1); ok( all( abs(erfi($x)-pdl(0.00886,0)) < 0.001 ), "erfi()" ); # I haven't changed rotate, but it should work anyway $x = byte( 0, 1, 2, 4, 5 ); $x->setbadat(2); is( PDL::Core::string( $x->rotate(2) ), "[4 5 0 1 BAD]", "rotate()" ); # check norm $x = float( 2, 0, 2, 2 )->setvaltobad(0.0); $y = $x->norm; $c = $x/sqrt(sum($x*$x)); ok( all( approx( $y, $c, ABSTOL ) ), "norm()" ) or diag "got=$y\nexpected=$c"; # propagation of badflag using inplace ops (ops.pd) # test biop fns $x = sequence(3,3); $c = $x->slice(',(1)'); $y = $x->setbadif( $x % 2 ); $x->inplace->plus($y,0); is( PDL::Core::string($c), "[BAD 8 BAD]", "inplace biop - plus()" ); # test bifunc fns $x = sequence(3,3); $c = $x->slice(',(1)'); $y = $x->setbadif( $x % 3 != 0 ); $x->inplace->power($y,0); is( PDL::Core::string($c), "[27 BAD BAD]", "inplace bifunc - power()" ); # test histogram (using hist) $x = pdl( qw/1 2 3 4 5 4 3 2 2 1/ ); $x->setbadat(1); $y = hist $x, 0, 6, 1; is( PDL::Core::string($y), "[0 2 2 2 2 1]", "hist()" ); $x->inplace->isfinite; is( PDL::Core::string($x), "[1 0 1 1 1 1 1 1 1 1]", "isfinite()" ); # histogram2d $x = long(1,1,1,2,2); $y = long(2,1,1,1,1); $y->setbadat(0); my @c = ( 1,0,3 ); $c = histogram2d($x,$y,@c,@c); is( PDL::Core::string($c->clump(-1)), "[0 0 0 0 2 2 0 0 0]", "histogram2d()" ); # weird propagation of bad values # - or is it? # #$x = sequence( byte, 2, 3 ); #$x = $x->setbadif( $x == 3 ); #$y = $x->slice("(1),:"); #$x .= $x->setbadtoval(3); #ok( $x->badflag, 0 ); # this fails #ok( $y->badflag, 0 ); # as does this # badmask: inplace $x = sequence(5); $x->setbadat(2); $x->inplace->badmask(0); is( PDL::Core::string($x), "[0 1 0 3 4]", "inplace badmask()" ); # setvaltobad $x = sequence(10) % 4; $x->inplace->setvaltobad( 1 ); like( PDL::Core::string( $x->clump(-1) ), qr{^\[-?0 BAD 2 3 -?0 BAD 2 3 -?0 BAD]$}, "inplace setvaltobad()" ); $x->inplace->setbadtonan; like( PDL::Core::string( $x->clump(-1) ), qr/^\[-?0 nan 2 3 -?0 nan 2 3 -?0 nan]$/i, "inplace setbadtonan()" ); # check setvaltobad for non-double ndarrays my $fa = pdl( float, 1..4) / 3; my $da = pdl( double, 1..4) / 3; ok( all($fa->setvaltobad(2/3)->isbad == $da->setvaltobad(2/3)->isbad), "setvaltobad for float ndarray"); my $inf2b = sequence(3); $inf2b->set(1, 'Inf'); $inf2b->set(2, 'NaN'); $inf2b->inplace->setinftobad; like( PDL::Core::string( $inf2b->clump(-1) ), qr{^\[-?0 BAD nan]$}i, "inplace setinftobad()" ); my $x_copy = $x->copy; $x_copy->set(1, 'Inf'); $x_copy->inplace->setnonfinitetobad; like( PDL::Core::string( $x_copy->clump(-1) ), qr{^\[-?0 BAD 2 3 -?0 BAD 2 3 -?0 BAD]$}, "inplace setnonfinitetobad()" ); # simple test for setnantobad # - could have a 1D FITS image containing # NaN's and then a simple version of rfits # (can't use rfits as does conversion!) $x->inplace->setnantobad; like( PDL::Core::string( $x->clump(-1) ), qr{^\[-?0 BAD 2 3 -?0 BAD 2 3 -?0 BAD]$}, "inplace setnantobad()" ); # check that we can change the value used to represent # missing elements for floating points (earlier tests only did integer types) # is( float->badvalue, float->orig_badvalue, "default bad value for floats matches" ); is( float->badvalue(23), 23, "changed floating-point bad value" ); float->badvalue( float->orig_badvalue ); $x = sequence(4); $x->badvalue(3); $x->badflag(1); $y = $x->slice('2:3'); is( $y->badvalue, 3, "can propagate per-ndarray bad value"); is( $y->sum, 2, "and the propagated value is recognised as bad"); $x = sequence(4); is ($x->badvalue, double->orig_badvalue, "no long-term effects of per-ndarray changes [1]"); for my $t (map +([$_, undef], [$_, 'nan']), grep !$_->integer, types()) { my $p = sequence $t->[0], 2; $p->badvalue($t->[1]) if defined $t->[1]; $p->setbadat(1); my $msg = "badvalue works right $t->[0], bv=".join '', grep $_, explain($t->[1]); eval {is $p.'', '[0 BAD]', $msg}; is $@, '', $msg; } ## Name: "isn't numeric in null operation" warning could be more helpful ## ## # The following code calls the PDL::Ops::eq() function via the operator # overload for the eq operator. Because the Perl eq operator is usually used # for strings, the default warning of "isn't numeric in null operation" is # confusing. Comparing a PDL against a string should give a more useful # warning. my $numeric_warning = qr/not numeric nor a PDL/; my $no_warning = undef; sub check_eq_warnings { my ($string, $warning) = @_; $warning ||= qr/^\s*$/; my @w; local $SIG{__WARN__} = sub { push @w, @_ }; my $dummy = pdl() eq $string; like "@w", $warning; @w = (); $dummy = $string eq pdl(); like "@w", $warning; @w = (); } subtest "String 'x' is not numeric and should warn" => sub { check_eq_warnings('x', $numeric_warning); }; subtest "String 'nancy' is not numeric and should warn" => sub { check_eq_warnings('nancy', $numeric_warning); }; subtest "String 'inf' is numeric" => sub { check_eq_warnings('inf', $no_warning); }; subtest "String 'nan' is numeric" => sub { check_eq_warnings('nan', $no_warning); }; TODO: { # implementing this might require checking for strings that can be made into PDLs local $TODO = "Using the eq operator with the string 'bad' might be a good feature"; subtest "String 'bad' is numeric (in PDL)" => sub { check_eq_warnings('bad', $no_warning); }; } ## Issue information ## ## Name: scalar PDL with badvalue always compares BAD with perl scalars ## ## ## subtest "Issue example code" => sub { my $x = pdl(1, 2, 3, 0); $x->badflag(1); $x->badvalue(0); # bad value for $x is now set to 0 is( "$x", "[1 2 3 BAD]", "PDL with bad-value stringifies correctly" ); my ($m, $s) = stats($x); is( "$m", 2, "Mean of [1 2 3] is 2" ); is( "$s", 1, "And std. dev is 1" ); $s->badflag(1); $s->badvalue(0); my @warnings; local $SIG{__WARN__} = sub { push @warnings, @_ }; is( "".($s > 0), "1", "is 1 > 0? -> true" ); is( "".($s < 0), "0", "is 1 < 0? -> false"); is( "".($s == 0), "0", "is 1 == 0? -> false"); ok scalar(@warnings), 'bad gave warnings'; }; subtest "Badvalue set on 0-dim PDL + comparision operators" => sub { my $val = 2; my $badval_sclr = 5; my $p_val = pdl($val); # set the bad flag to 0 $p_val->badflag(1); $p_val->badvalue($badval_sclr); note "\$p_val = $p_val"; is( "$p_val", "$val", "Sanity test" ); my @values_to_compare = ( $badval_sclr, $badval_sclr + 1, $badval_sclr - 1 ); subtest "Comparing a 0-dim PDL w/ a scalar should be the same as comparing a scalar w/ a scalar" => sub { for my $cmpval_sclr (@values_to_compare) { subtest "Bad value for PDL $p_val is $badval_sclr and we are comparing with a scalar of value $cmpval_sclr" => sub { is "".($p_val < $cmpval_sclr), (0+( $val < $cmpval_sclr)), "$val < $cmpval_sclr"; is "".($p_val == $cmpval_sclr), (0+( $val == $cmpval_sclr)), "$val == $cmpval_sclr"; is "".($p_val > $cmpval_sclr), (0+( $val > $cmpval_sclr)), "$val > $cmpval_sclr"; }; } }; subtest "Comparing a 0-dim PDL w/ bad value with a 0-dim PDL without bad value set should not set BAD" => sub { for my $not_bad_sclr (@values_to_compare) { subtest "Bad value for PDL $p_val is $badval_sclr and we are comparing with a PDL of value $not_bad_sclr, but with no badflag" => sub { my $p_not_bad = pdl($not_bad_sclr); $p_not_bad->badflag(0); # should not have bad flag my $lt_p = $p_val < $p_not_bad; is "". $lt_p, 0+( $val < $not_bad_sclr), "$val < $not_bad_sclr"; ok $lt_p->badflag, "cmp for < does set badflag"; my $eq_p = $p_val == $p_not_bad; is "". $eq_p, 0+( $val == $not_bad_sclr), "$val == $not_bad_sclr"; ok $eq_p->badflag, "cmp for == does set badflag"; my $gt_p = $p_val > $p_not_bad; is "". $gt_p, 0+( $val > $not_bad_sclr), "$val > $not_bad_sclr"; ok $gt_p->badflag, "cmp for > does set badflag"; }; } }; }; subtest "stats() badvalue behavior" => sub { my $stats_data = [ { name => "stats() should not set the badflag for output with only one badvalue", func => \&stats, input => do { pdl [1, 2, 3] }, badvalue => 2, string => "[1 BAD 3]", mean => "2", badflag => 0 }, { name => "stats() should set the badflag for output with all badvalues and mean should be BAD" , func => \&stats, input => do { pdl [1, 1, 1] }, badvalue => 1, string => "[BAD BAD BAD]", mean => "BAD", badflag => 1, }, { name => "and statsover() on a row of BAD values", func => \&statsover, input => do { zeroes(3,3)->yvals+1 }, badvalue => 1, string => do { my $p_str = <<'EOF'; [ [BAD BAD BAD] [ 2 2 2] [ 3 3 3] ] EOF }, mean => "[BAD 2 3]", badflag => 1, }, { name => "and statsover() on a diagonal of BAD values", func => \&statsover, input => do { my $p = ones(3,3)*2; $p->diagonal(0,1) .= 1; $p }, string => do { my $p_str = <<'EOF'; [ [BAD 2 2] [ 2 BAD 2] [ 2 2 BAD] ] EOF }, badvalue => 1, mean => "[2 2 2]", badflag => 0, } ]; for my $case (@$stats_data) { subtest $case->{name} => sub { my $p = $case->{input}; $p->badflag(1); $p->badvalue($case->{badvalue}); note "\$p = $p"; is( "$p", $case->{string}, "stringifies properly"); my $m = $case->{func}->($p); note "\$m = $m"; is( "$m", $case->{mean}, "Mean of \$p" ); is( $m->badflag, $case->{badflag}, "Mean does @{[ (' not ')x!!( ! $case->{badflag} ) ]} have badflag set"); }; } }; subtest "Comparison between a vector and scalar" => sub { my $p = pdl [1, 2, 3, 4]; $p->badflag(1); $p->badvalue(2); note "\$p = $p"; is( "$p", "[1 BAD 3 4]", "PDL vector (with bv = 2)"); is( "" . ( $p > 1 ), '[0 BAD 1 1]', "compare PDL against (scalar = 1)"); is( "" . ( $p > 2 ), '[0 BAD 1 1]', "compare PDL against (scalar = 2)" ); is( "" . ( $p > 3 ), '[0 BAD 0 1]', "compare PDL against (scalar = 3)"); is( "" . ( $p > 4 ), '[0 BAD 0 0]', "compare PDL against (scalar = 4)"); }; subtest "Throw a warning when badvalue is set to 0 or 1 and a comparison operator is used" => sub { my $warn_msg_re = qr/Badvalue is set to 0 or 1/; # We do not need to change the contents of this PDL. # Only the value of badvalue changes. my $p = pdl([0, 1, 2]); $p->badflag(1); subtest "Badvalue set to 0" => sub { $p->badvalue(0); warning_like { $p == 1 } $warn_msg_re, "A warning thrown for badval == 0 and == operator"; }; subtest "Badvalue set to 1" => sub { $p->badvalue(1); warning_like { $p == 1 } $warn_msg_re, "A warning thrown for badval == 1 and == operator"; }; subtest "Badvalue set to 2" => sub { $p->badvalue(2); warning_like { $p == 1 } undef, "No warning thrown for badval == 2 and == operator"; }; subtest "Badvalue set to 0 and other operators" => sub { $p->badvalue(0); warning_like { $p > 1 } $warn_msg_re, "A warning thrown for badval == 0 and > operator"; warning_like { $p >= 1 } $warn_msg_re, "A warning thrown for badval == 0 and >= operator"; warning_like { $p < 1 } $warn_msg_re, "A warning thrown for badval == 0 and < operator"; warning_like { $p <= 1 } $warn_msg_re, "A warning thrown for badval == 0 and <= operator"; warning_like { $p == 1 } $warn_msg_re, "A warning thrown for badval == 0 and == operator"; warning_like { $p != 1 } $warn_msg_re, "A warning thrown for badval == 0 and != operator"; warning_like { $p + 1 } undef, "No warning thrown for badval == 0 and + operator"; }; }; subtest "locf" => sub { my $withbad = pdl '[BAD 1 BAD 3 BAD 5]'; my $locf = $withbad->locf; is $locf."", '[0 1 1 3 3 5]', 'locf worked'; }; done_testing; PDL-2.074/t/pp_line_numbers.t0000644000175000017500000000326014165321333015706 0ustar osboxesosboxes# DO NOT MODIFY - IT IS VERY FINICKY; see notes below. use strict; use warnings; # Five tests for each of two types: use Test::More tests => 10; use PDL::PP qw(foo::bar foo::bar foobar); # Add some tests for pp_line_numbers: pp_def(test1 => Pars => 'a(n)', Code => pp_line_numbers (__LINE__, q{/* line 13, First line */ threadloop %{ /* line 15, Line after threadloop */ loop (n) %{ /* line 17, Line after loop */ %} /* line 19, Line after close of loop */ %} /* line 21, Line after close of threadloop */ }), GenericTypes => [qw(F D)], ); pp_done; unlink 'foobar.pm'; # Analyze the output of pp_line_numbers by checking the line numbering in # foobar.xs. Note that the line *after* the #line directive is assigned the # number of the #line directive. See http://gcc.gnu.org/onlinedocs/cpp/Line-Control.html my ($line, $file) = (1, 'foobar.xs'); open my $fh, '<', 'foobar.xs'; LINE: while(<$fh>) { # Take note of explicit line directives if (/#line (\d+) ".*"/) { ($line, $file) = ($1, $2); next LINE; } # look for items to check: if (m|/\* line (\d+), (.*?) \*/|) { my ($actual_line, $description) = ($1, $2); is($line, $actual_line, $description); } $line++; } close $fh; unlink 'foobar.xs'; __END__ This test is very finicky because it uses __LINE__, but it also explicitly indicates the line numbers in the /* comments */. As such, if you add a line of text (comment or code) before or within the pp_def, all of the line numbers in the /* comments */ will be off. It's a minor headache to adjust them, so please just don't mess with this test, unless of course you wish to fix it. :-) --DCM, December 13, 2011 PDL-2.074/t/matrix.t0000644000175000017500000000053214146003631014025 0ustar osboxesosboxesuse strict; use warnings; use PDL::LiteF; use Test::More tests => 2; use PDL::Matrix; my $m = mpdl([[1,2,1],[2,0,3],[1,1,1]]); # matrix with determinant 1 my $tol = $^O =~ /win32/i ? 1e-6 : 1e-15; note "determinant: ",$m->det; ok approx($m->det, 1, $tol), "det" or diag 'got: ', $m->det; ok approx($m->determinant, 1, 1e-15), "determinant"; PDL-2.074/t/inlinepdlpp.t0000644000175000017500000000243214176226246015054 0ustar osboxesosboxesuse strict; use warnings; use Test::More; BEGIN { my $inline_test_dir = './.inlinepdlpp'; mkdir $inline_test_dir unless -d $inline_test_dir; eval { require Inline; require Inline::C; Inline->import(Config => DIRECTORY => $inline_test_dir, FORCE_BUILD => 1); 1; } || plan skip_all => "Skipped: Inline or Inline::C not installed"; note "Inline Version: $Inline::VERSION\n"; eval { Inline->VERSION(0.43) }; plan skip_all => "Skipped: not got Inline >= 0.43" if $@; } use PDL::LiteF; # use Inline 'INFO'; # use to generate lots of info eval { Inline->bind(Pdlpp => <<'EOF') }; # simple PP definition pp_def('testinc', Pars => 'a(); [o] b()', Code => '$b() = $a() + 1;' # wow, that's complicated ); # this tests the bug with a trailing comment and *no* newline EOF is $@, '', 'bind no error'; my $x = sequence(3,3); my $y = $x->testinc; is myshape($x), myshape($y), 'myshape eq'; ok(all $y == $x+1, '=='); sub myshape { join ',', $_[0]->dims } eval { Inline->bind(Pdlpp => <<'EOF', PACKAGE => 'Other::Pkg') }; pp_addxs(<<'EOXS'); int add1 (parm) int parm CODE: RETVAL = parm + 1; OUTPUT: RETVAL EOXS EOF is $@, '', 'bind no error'; my $r = eval { Other::Pkg::add1(4) }; is $@, '', 'call no error'; is $r, 5, 'correct result'; done_testing; PDL-2.074/t/croak.t0000644000175000017500000000353414146003631013625 0ustar osboxesosboxesuse strict; use warnings; use PDL::LiteF; use Test::More; use Test::Exception; # PDL::Core::set_debugging(1); my $pb = pdl [[1,1,1],[2,2,2]]; { # we are using more dims than are available throws_ok { my $pc = $pb->slice(':,:,:,(1)'); $pc->make_physical(); } qr/too many dims/i; } { # now see if we survive the destruction of this invalid trans my $pb = zeroes(5,3,3); lives_ok { my $pc = $pb->slice(":,:,1") }; } { my $pb = pdl [[1,1,1],[2,2,2]]; lives_ok { my $pc = $pb->dummy(5,1); $pc->make_physical(); }; } { my $pb = zeroes(5,3,3); lives_ok { my $pc = $pb->slice(":,:,1"); }; } # This test case points out a problem in the freeing # of used memory in 1.90_01 lives_ok { my $pa = pdl (1,2); my $pb = pdl [[1,2],[1,2],[1,2]]; my $pc = $pa->slice(',*3'); $pc->make_physical; $pc = $pb->clump(2); $pb->make_physical; $pc->make_physical; }; lives_ok { my $pa = zeroes 4,5; my $pb = $pa->slice('1:3:2,2:4:2'); $pb .= ones(2,2); note $pa; }; # tests for error checking of input args to PP compiled function { my $pb=pdl([1,2,3])->long; my $pa=[1,2,3]; lives_ok { PDL::Ufunc::sumover($pa,$pb) } 'sumover with ndarrays of compatible dimensions does not die'; } { my $paa=3; my $pa=\$paa; throws_ok { PDL::Ufunc::sumover($pa,$paa) } qr/Error - tried to use an unknown/; } { throws_ok { PDL::Ufunc::sumover({}) } qr/Hash given as a pdl \(HASH\) - but not \{PDL} key/; throws_ok { PDL::Ufunc::sumover(bless {}, 'Foo') } qr/Hash given as a pdl \(Foo\) - but not \{PDL} key/; } { my $pc = 0; throws_ok { PDL::Ufunc::sumover(\$pc) } qr/Error - tried to use an unknown/; } # This is something that would cause an exception on 1.91_00: # when the original was undef'd, xchghashes would barf. lives_ok { my $pa = xvals zeroes(5,5); my $pb = $pa->slice(':,2:3'); $pa = 1; # Undefine orig. a $pb += 1; } "no barf when parent of slice undefined"; done_testing; PDL-2.074/t/inline-with.t0000644000175000017500000000411414176226262014762 0ustar osboxesosboxes# This test checks this works: use Inline with => 'PDL'; # Also that the XS code in PDL::API works. use strict; use warnings; use Test::More; use PDL::LiteF; my $inline_test_dir; # First some Inline administrivia. BEGIN { # Test for Inline and set options $inline_test_dir = './.inlinewith'; mkdir $inline_test_dir unless -d $inline_test_dir; # See if Inline loads without trouble, or bail out eval { require Inline; require Inline::C; Inline->import (Config => DIRECTORY => $inline_test_dir , FORCE_BUILD => 1); # Inline->import ('NOCLEAN'); 1; } or do { plan skip_all => "Skipped: Inline or Inline::C not installed"; }; if( $Inline::VERSION < 0.83 ) { plan skip_all => "Skipped: Inline has ILSM-finding bug"; } } use File::Path; END { if ($^O =~ /MSWin32/i) { for (my $i = 0; $i < @DynaLoader::dl_modules; $i++) { if ($DynaLoader::dl_modules[$i] =~ /inline_with_t/) { DynaLoader::dl_unload_file($DynaLoader::dl_librefs[$i]); } } } } SKIP: { #use Inline 'INFO'; # use to generate lots of info use_ok 'Inline', with => 'PDL' or skip 'with PDL failed', 3; eval { Inline->bind(C => <<'EOF') }; static pdl* new_pdl(int datatype, PDL_Indx dims[], int ndims) { pdl *p = PDL->pdlnew(); if (!p) return p; pdl_error err = PDL->setdims(p, dims, ndims); /* set dims */ if (err.error) { PDL->destroy(p); return NULL; } p->datatype = datatype; /* and data type */ err = PDL->allocdata(p); /* allocate the data chunk */ if (err.error) { PDL->destroy(p); return NULL; } return p; } pdl* myfloatseq() { PDL_Indx dims[] = {5,5,5}; pdl *p = new_pdl(PDL_F,dims,3); if (!p) return p; PDL_Float *dataf = (PDL_Float *) p->data; PDL_Indx i; /* dimensions might be 64bits */ for (i=0;i<5*5*5;i++) dataf[i] = i; /* the data must be initialized ! */ return p; } EOF is $@, '', 'bind no error' or skip 'Inline C failed', 2; note "Inline Version: $Inline::VERSION\n"; ok 1, 'compiled'; my $pdl = myfloatseq(); note $pdl->info,"\n"; is $pdl->dims, 3, 'dims correct'; } done_testing; PDL-2.074/t/scope.t0000644000175000017500000000274114146003631013636 0ustar osboxesosboxes# Test if we can still do scopes ok - multiple uses etc.. # Also see that PDL loaders get the correct symbols. use strict; use warnings; use Test::More; { package A; our $pa; # note "A: ",%A::,"\n"; use PDL; $pa = zeroes 5,5; # note "A: %A::\n"; # note "AC: ",(bless {},A)->can("zeroes"),"\n"; } ok((bless {},'A')->can("zeroes")); { package B; use PDL; } #note "B: ",%B::,"\n"; #note "B: ",%B::,"\n"; # $pb = zeroes 5,5; # note "BC: ",(bless {},B)->can("zeroes"),"\n"; ok((bless {},'B')->can("zeroes")); { package C; use PDL::Lite; } ok(!((bless {},'C')->can("zeroes"))); { package D; use PDL::Lite; } ok(!((bless {},'D')->can("zeroes"))); { package E; use PDL::LiteF; } ok((bless {},'E')->can("zeroes")); { package F; use PDL::LiteF; } ok((bless {},'F')->can("zeroes")); ok(!((bless {},'C')->can("imag"))); ok(!((bless {},'D')->can("imag"))); ok(!((bless {},'E')->can("imag"))); ok(!((bless {},'F')->can("imag"))); # Can PDL::Lite be loaded twice? # The first import was interfering with the second. { package mk1; use PDL::Lite; sub x { return PDL->pdl (1..10); } } { package mk2; use PDL::Lite; sub x { return PDL->pdl (11..20); } } foreach my $name (qw /x barf pdl piddle null/) { ok (mk1->can($name), "Sub loaded: mk1::" . $name); ok (mk2->can($name), "Sub loaded: mk2::" . $name); } # now try calling one of those functions eval { my $x = mk1::pdl(0, 1) }; is $@, '', 'the imported pdl function ACTUALLY WORKS'; done_testing; PDL-2.074/t/ufunc.t0000644000175000017500000001613414200150406013640 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::LiteF; sub tapprox ($$) { my ( $x, $y ) = @_; my $d = abs( $x - $y ); my $check = ($d <= 0.0001); diag "diff = [$d]\n" unless my $res = all $check; return $res; } my $p = pdl([]); $p->setdims([1,0]); $p->qsortvec; # shouldn't segfault! my $p2d = pdl([[1,2],[3,4],[1,3],[1,2],[3,3]]); is $p2d->dice_axis(1,$p2d->qsortveci).'', $p2d->qsortvec.'', "qsortveci"; # set up test arrays # my $x = pdl(0,0,6,3,5,0,7,14,94,5,5,8,7,7,1,6,7,13,10,2,101,19,7,7,5); # sf.net bug #2019651 my $a_sort = $x->qsort; my $y = pdl(55); my $b_sort = $y->qsort; my $c = cat($x,$x); my $c_sort = $c->qsort; my $d = sequence(10)->rotate(1); my $d_sort = $d->qsort; my $e = pdl([[1,2],[0,500],[2,3],[4,2],[3,4],[3,5]]); my $e_sort = $e->qsortvec; eval { sequence(3, 3)->medover(my $o = null, my $t = null); }; isnt $@, '', 'a [t] Par cannot be passed'; my $med_dim = 1000; ok tapprox(sequence(10,$med_dim,$med_dim)->medover, sequence($med_dim,$med_dim)*10+4.5), 'medover'; # Test a range of values ok( tapprox($x->pctover(-0.5), $a_sort->at(0)), "pct below 0 for 25-elem pdl" ); ok( tapprox($x->pctover( 0.0), $a_sort->at(0)), "pct equal 0 for 25-elem pdl" ); ok( tapprox($x->pctover( 0.9), 17), "pct equal 0.9 for 25-elem pdl [SF bug 2019651]" ); ok( tapprox($x->pctover( 1.0), $a_sort->at($x->dim(0)-1)), "pct equal 1 for 25-elem pdl" ); ok( tapprox($x->pctover( 2.0), $a_sort->at($x->dim(0)-1)), "pct above 1 for 25-elem pdl" ); # test for sf.net bug report 2753869 # $x = sequence(10); ok( tapprox($x->pctover(0.2 ), 1.8 ), "20th percentile of 10-elem ndarray [SF bug 2753869]"); ok( tapprox($x->pctover(0.23), 2.07), "23rd percentile of 10-elem ndarray [SF bug 2753869]"); # test for sf.net bug report 2110074 # ok( ( eval { pdl([])->qsorti }, $@ eq '' ), "qsorti coredump,[SF bug 2110074]"); $d->inplace->qsort; ok(all($d == $d_sort), "inplace sorting"); $d->setbadat(3); $d_sort = $d->qsort; $d->inplace->qsort; ok(all($d == $d_sort), "inplace sorting with bad values"); $e->inplace->qsortvec; ok(all($e == $e_sort), "inplace lexicographical sorting"); my $ei = $e->copy; $ei->setbadat(1,3); my $ei_sort = $ei->qsortveci; is $ei_sort."", '[0 1 2 4 5 3]', "qsortveci with bad values" or diag "got:$ei_sort"; $e->setbadat(1,3); $e_sort = $e->qsortvec; $e->inplace->qsortvec; ok(all($e == $e_sort), "inplace lexicographical sorting with bad values") or diag "inplace=$e\nnormal=$e_sort"; # Test sf.net bug 379 "Passing qsort an extra argument causes a segfault" # (also qsorti, qsortvec, qsortveci) eval { random(15)->qsort(5); }; isnt($@, '', "qsort extra argument"); eval { random(15)->qsorti(5); }; isnt($@, '', "qsorti extra argument"); eval {random(10,4)->qsortvec(5); }; isnt($@, '', "qsortvec extra argument"); eval {random(10,4)->qsortveci(2); }; isnt($@, '', "qsortveci extra argument"); #but the dimension size checks for those cases shouldn't derail trivial qsorts: is(pdl(5)->qsort,pdl(5),'trivial qsort'); is(pdl(8)->qsorti,pdl(0),'trivial qsorti'); ok(all(pdl(42,41)->qsortvec == pdl(42,41)->dummy(1)),'trivial qsortvec'); is(pdl(53,35)->qsortveci,pdl(0),'trivial qsortveci'); # test qsort moves vectors with BAD components to end is pdl("0 -100 BAD 100")->qsort."", '[-100 0 100 BAD]', 'qsort moves BAD elts to end'; # test qsortvec moves vectors with BAD components to end - GH#252 is pdl("[0 0] [-100 0] [BAD 0] [100 0]")->qsortvec."", <<'EOF', 'qsortvec moves vectors with BAD components to end'; [ [-100 0] [ 0 0] [ 100 0] [ BAD 0] ] EOF # test for sf.net bug report 3234141 "max() fails on nan" # NaN values are handled inconsistently by min, minimum, max, maximum... # { my $inf = inf(); my $nan = nan(); my $x = pdl($nan, 0, 1, 2); my $y = pdl(0, 1, 2, $nan); ok($x->min == $y->min, "min with NaNs"); ok($x->max == $y->max, "max with NaNs"); } my $empty = which(ones(5)>5); $x = $empty->double->maximum; ok( $x->nelem==1, "maximum over an empty dim yields 1 value"); ok(!($x*0==0), "max of empty nonbad float gives NaN"); $x = $empty->byte->maximum; ok($x==0, "max of empty nonbad int type gives 0"); # test bad value handling with pctover and max # $empty->badflag(1); $x = $empty->maximum; ok( $x->isbad, "bad flag gets set on max over an empty dim"); my $xbad = $x; $xbad->badflag(1); $xbad->inplace->setvaltobad(7); my $xgood = $xbad->where($xbad->isgood); my $allbad = $xbad->where($xbad->isbad); ok( $xbad->pctover(0.1) == $xgood->pctover(0.1), "pctover(0.1) badvals" ); ok( $xbad->pctover(0.9) == $xgood->pctover(0.9), "pctover(0.9) badvals" ); ok( $allbad->pctover(0.1)->isbad, "pctover(0.1) all badvals" ); ok( $allbad->pctover(0.9)->isbad, "pctover(0.9) all badvals" ); #Test subroutines directly. #set up ndarrays my $f=pdl(1,2,3,4,5); my $g=pdl (0,1); my $h=pdl(1, 0,-1); my $i=pdl (1,0); my $j=pdl(-3, 3, -5, 10); #Test percentile routines #Test PDL::pct ok (tapprox(PDL::pct($f, .5), 3), 'PDL::pct 50th percentile'); ok (tapprox(PDL::pct($g, .76), 0.76), 'PDL::pct interpolation test'); ok (tapprox(PDL::pct($i, .76), 0.76), 'PDL::pct interpolation not in order test'); #Test PDL::oddpct ok (tapprox(PDL::oddpct($f, .5), 3), 'PDL::oddpct 50th percentile'); ok (tapprox(PDL::oddpct($f, .79), 4), 'PDL::oddpct intermediate value test'); ok (tapprox(PDL::oddpct($h, .5), 0), 'PDL::oddpct 3-member 50th percentile with negative value'); ok (tapprox(PDL::oddpct($j, .1), -5), 'PDL::oddpct negative values in-between test'); #Test oddmedian ok (PDL::oddmedian($g) == 0, 'Oddmedian 2-value ndarray test'); ok (PDL::oddmedian($h) == 0, 'Oddmedian 3-value not in order test'); ok (PDL::oddmedian($j) == -3, 'Oddmedian negative values even cardinality test'); #Test mode and modeover $x = pdl([1,2,3,3,4,3,2],1); ok( $x->mode == 0, "mode test" ); ok( all($x->modeover == pdl(3,0)), "modeover test"); #the next 4 tests address GitHub issue #248. # .... 0000 1010 # .... 1111 1100 #OR:.... 1111 1110 = -2 is( pdl([10,0,-4])->borover(), -2, "borover with no BAD values"); # .... 1111 1111 # .... 1111 1010 # .... 1111 1100 #AND: .... 1111 1000 = -8 is( pdl([-6,~0,-4])->bandover(), -8, "bandover with no BAD values"); # 0000 1010 # 1111 1100 #OR:1111 1110 = 254 if the accumulator in BadCode is an unsigned char is( pdl([10,0,-4])->setvaltobad(0)->borover(), -2, "borover with BAD values"); # 1111 1010 # 1111 1100 #AND: 1111 1000 = 248 if the accumulator in BadCode is an unsigned char is( pdl([-6,~0,-4])->setvaltobad(~0)->bandover(), -8, "bandover with BAD values"); { # all calls to functions that handle finding minimum and maximum should return # the same values (i.e., BAD). NOTE: The problem is that perl scalar values # have no 'BAD' values while pdls do. We need to sort out and document the # differences between routines that return perl scalars and those that return # pdls. my $bad_0dim = pdl(q|BAD|); is( "". $bad_0dim->min, 'BAD', "does min returns 'BAD'" ); isnt( "". ($bad_0dim->minmax)[0], "". $bad_0dim->min, "does minmax return same as min" ); is( "". ($bad_0dim->minmaximum)[0], "". $bad_0dim->min, "does minmaximum return same as min" ); } is ushort(65535)->max, 65535, 'max(highest ushort value) should not be BAD'; done_testing; PDL-2.074/t/basic.t0000644000175000017500000000755514170075275013630 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::LiteF; sub tapprox { my($x,$y) = @_; my $d = max( abs($x-$y) ); $d < 1.0e-6; } my $x0 = pdl( [ 2, 1, 2 ], [ 1, 0, 1 ], [ 2, 1, 2 ] ); my $a1 = rvals(3,3); ok( tapprox( $x0->sqrt, $a1 ), "centered rvals" ) or diag $a1; my $a2 = rvals(3,3,{squared=>1}); ok( tapprox( $x0, $a2 ), "centered rvals squared" ) or diag $a2; my $x1 = pdl( [ 8, 5, 4 ], [ 5, 2, 1 ], [ 4, 1, 0 ] ); my $a3 = rvals(3,3,{centre=>[2,2]}); ok( tapprox( $x1->sqrt, $a3 ), "non-centered rvals" ) or diag $a3; my $a4 = rvals(3,3,{center=>[2,2]}); ok( tapprox( $x1->sqrt, $a4 ), "centre/center synonyms" ) or diag $a4; my $a5 = rvals(3,3,{ceNteR=>[2,2]}); ok( tapprox( $x1->sqrt, $a5 ), "ceNteR option capitalization" ) or diag $a5; my $a6 = rvals(3,3,{center=>[2,2],squared=>1}); ok( tapprox( $x1, $a6 ), "both center and squared options" ) or diag $a6; # test (x|y|z)(lin|log)vals: shape and values { my $a1=zeroes(101,51,26); my $x = $a1->xlinvals(0.5,1.5); my $y = $a1->ylinvals(-2,-1); my $z = $a1->zlinvals(-3,2); ok(all($a1->shape==$x->shape), "xlinvals shape"); #7 ok(all($a1->shape==$y->shape), "ylinvals shape"); #8 ok(all($x->shape==$z->shape), "zlinvals shape"); #9 ok(tapprox($x->uniqvec->flat,pdl(50..150)/100),"xlinvals values"); #10 ok(tapprox($y->mv(1,0)->uniqvec->flat,pdl(-100..-50)/50),"ylinvals values"); #11 ok(tapprox($z->mv(2,0)->uniqvec->flat,pdl(0..25)/5-3),"zlinvals values"); #12 } { my $x = zeroes(11,6,8); my $xl = $x->xlogvals(1e2,1e12); my $yl = $x->ylogvals(1e-3,1e2); my $zl = $x->zlogvals(1e-10,1e-3); ok(all($x->shape==$xl->shape),"xlogvals shape"); #13 ok(all($x->shape==$yl->shape),"ylogvals shape"); #14 ok(all($x->shape==$zl->shape),"zlogvals shape"); #15 ok(tapprox($xl->uniqvec->flat->log10,pdl(2..12)),"xlogvals values"); #16 ok(tapprox($yl->mv(1,0)->uniqvec->flat->log10,pdl(-3..2)),"ylogvals values"); #17 ok(tapprox($zl->mv(2,0)->uniqvec->flat->log10,pdl(-10..-3)),"zlogvals values");#18 } #test axisvals my $z = axisvals(zeroes(3,4,5,6),3); ok(all($z==pdl(0..5)->dummy(0,5)->dummy(0,4)->dummy(0,3)),"4-dimensional axisvals");#19 { my $x = pdl [15.4,15.8,16.01,16.9,16.1,15.2,15.4,16.2,15.4,16.2,16.4]; my ($hx,$h) = hist ($x,15,17,0.1); ok( tapprox($hx, pdl(qw/15.05 15.15 15.25 15.35 15.45 15.55 15.65 15.75 15.85 15.95 16.05 16.15 16.25 16.35 16.45 16.55 16.65 16.75 16.85 16.95/)), "bin centers"); ok( tapprox($h, pdl(qw/0 1 0 0 3 0 0 0 1 0 1 3 0 1 0 0 0 0 1 0/)), "hist vals"); } { my $x = pdl( qw{ 13 10 13 10 9 13 9 12 11 10 10 13 7 6 8 10 11 7 12 9 11 11 12 6 12 7} ); my $wt = pdl( qw{ -7.4733817 -3.0945993 -1.7320649 -0.92823577 -0.34618392 -1.3326057 -1.3267382 -0.032047153 0.067103333 -0.11446796 -0.72841944 0.95928255 1.4888114 0.17143622 0.14107419 -1.6368404 0.72917 -2.0766962 -0.66708236 -0.52959271 1.1551274 0.079184 1.4068289 0.038689811 0.87947996 -0.88373274 } ); my ( $hx, $h ) = whist ($x, $wt, 0, 20, 1 ); ok( tapprox($hx, pdl(qw{ 0.5 1.5 2.5 3.5 4.5 5.5 6.5 7.5 8.5 9.5 10.5 11.5 12.5 13.5 14.5 15.5 16.5 17.5 18.5 19.5 }) ), "weighted bin centers"); ok( tapprox($h, pdl(qw{ 0 0 0 0 0 0 0.21012603 -1.4716175 0.14107419 -2.2025149 -6.5025629 2.0305847 1.5871794 -9.5787698 0 0 0 0 0 0 }) ), "weighted hist vals"); } my $a0 = zeroes(3,2); $a1 = xvals $a0; is($a1->at(0,0), 0, "xvals 0,0 == 0"); is($a1->at(1,0), 1, "xvals 1,0 == 1"); is($a1->at(2,0), 2, "xvals 2,0 == 2"); is($a1->at(1,1), 1, "xvals 1,1 == 1"); # sequence as instance method my $seq_src = pdl(indx, [9,8,7]); my $seq_dst = $seq_src->sequence; is $seq_dst->type, $seq_src->type, 'sequence as instance-method should maintain type'; is_deeply [$seq_dst->dims], [$seq_src->dims], "sequence as instance-method should maintain dims"; is_deeply [$seq_dst->list], [0..($seq_src->nelem-1)], "sequence as instance-method should enumerate all elements"; done_testing; PDL-2.074/t/pdl_from_string.t0000644000175000017500000003641714146003631015724 0ustar osboxesosboxes# This tests the new PDL constructor with a string argument. # There are three goals from the new functionality: (1) to allow # MATLAB to use familiar syntax to create arrays, (2) to allow # cut-n-paste of PDL print output as input for scripts and programs, # and (3) to allow easy ways to construct nan and inf values in ndarrays. # (4) to allow complex numbers to be round-tripped in native # complex (i.e. Math::Complex) format use strict; use warnings; use Test::More; use Config; use PDL::LiteF; isa_ok( pdl("[1,2]"), "PDL", qq{pdl("[1,2]") returns an ndarray} ); # Basic Tests # ok( all(pdl([1,2])==pdl("[1,2]")), qq{pdl(ARRAY REF) equals pdl("ARRAY REF")}); my $compare = pdl([ [1, 0, 8], [6, 3, 5], [3, 0, 5], [2, 4, 2] ]); my $test_string = <ndims == 1, "Implicit bracketing gets proper number of dimensions - no brackets, no commas"); ok($t14->ndims == 1, "Implicit bracketing gets proper number of dimensions - no brackets, commas"); ok($t15->ndims == 1, "Implicit bracketing gets proper number of dimensions - brackets, no commas"); ok($t16->ndims == 1, "Implicit bracketing gets proper number of dimensions - brackets and commas"); $expected = pdl []; $got = pdl q[]; ok(all($got == $expected), 'Blank strings are interpreted as empty arrays'); # This generates an annoying warning, and the ndarray should be Empty anyway #$expected = pdl []; $got = pdl q[[]]; ok(all($got == $expected), 'Empty bracket is correctly interpreted'); # Bad, inf, nan checks # my $bad_values = pdl q[nan inf -inf bad]; # Bad value testing depends on whether nan and inf are represented as bad # values TODO: { # conditional TODO local $TODO = 'ActivePerl and/or perls built using MS compilers might fail this test' if($ActivePerl::VERSION || $Config{cc} eq 'cl'); SKIP: { skip "broken for PDL_Index", 1; ok($bad_values->at(0) != $bad_values->at(0), 'properly handles nan') or diag("Zeroeth bad value should be nan but it describes itself as " . $bad_values->at(0)); } } # inf test: inf == inf but inf * 0 != 0 ok(( $bad_values->at(1) == $bad_values->at(1) and $bad_values->at(1) * 0.0 != 0.0), 'properly handles inf') or diag("First bad value should be inf but it describes itself as " . $bad_values->at(1)); # inf test: -inf == -1 * inf ok(( $bad_values->at(2) == $bad_values->at(2) and $bad_values->at(2) * 0.0 != 0.0), 'properly handles -inf') or diag("Second bad value should be -inf but it describes itself as " . $bad_values->at(2)); ok($bad_values->at(2) == -$bad_values->at(1), "negative inf is numerically equal to -inf"); ok($bad_values->isbad->at(3), 'properly handles bad values') or diag("Third bad value should be BAD but it describes itself as " . $bad_values->slice(3)); my $infty = inf(); my $min_inf = -inf(); my $nan = nan(); my $nan2 = $^O =~ /MSWin32/i && !$ActivePerl::VERSION && $Config{cc} ne 'cl' ? pdl (-((-1) ** 0.5)) : pdl '-nan'; my $bad = pdl 'bad'; TODO: { # conditional TODO local $TODO = 'ActivePerl and/or perls built using MS compilers might fail this test' if($ActivePerl::VERSION || $Config{cc} eq 'cl'); ok(( $infty == $infty and $infty * 0.0 != 0.0), "pdl 'inf' works by itself") or diag("pdl 'inf' gave me $infty"); ok(( $min_inf == $min_inf and $min_inf * 0.0 != 0.0), "pdl '-inf' works by itself") or diag("pdl '-inf' gave me $min_inf"); } ok($min_inf == -$infty, "pdl '-inf' == -pdl 'inf'"); TODO: { local $TODO = 'Sign of Nan depends on platform, still some loose ends'; # conditional TODO for a different reason local $TODO = 'Cygwin perl and/or ActivePerl might fail these tests' if($ActivePerl::VERSION || $^O =~ /cygwin/i); ok(( $nan != $nan), "pdl 'nan' works by itself") or diag("pdl 'nan' gave me $nan"); ok(( $nan2 != $nan2), "pdl '-nan' works by itself") or diag("pdl '-nan' gave me $nan2"); # On MS Windows, nan is -1.#IND and -nan is 1.#QNAN. IOW, nan has # a leading minus sign, and -nan is not signed. if($^O =~ /MSWin32/i) { ok(( $nan =~ /-/), "pdl 'nan' has a negative sign (MS Windows only)") or diag("pdl 'nan' gave me $nan"); ok(( $nan2 !~ /-/), "pdl '-nan' doesn't have a negative sign (MS Windows only)") or diag("pdl -'nan' gave me $nan2"); } else { ok(( $nan !~ /-/), "pdl 'nan' has a positive sign") or diag("pdl 'nan' gave me $nan"); ok(( $nan2 =~ /-/), "pdl '-nan' has a negative sign") or diag("pdl '-nan' gave me $nan2"); } } ok($bad->isbad, "pdl 'bad' works by itself") or diag("pdl 'bad' gave me $bad"); # Checks for windows strings: $infty = pdl q[1.#INF]; $nan = pdl q[-1.#IND]; TODO: { # conditional TODO local $TODO = 'ActivePerl and/or perls built using MS compilers might fail this test' if($ActivePerl::VERSION || $Config{cc} eq 'cl'); ok(( $infty == $infty and $infty * 0 != 0), "pdl '1.#INF' works") or diag("pdl '1.#INF' gave me $infty"); ok(( $nan != $nan), "pdl '-1.#IND' works") or diag("pdl '-1.#IND' gave me $nan"); } # Pi and e checks # $expected = pdl(1)->exp; # using approx() here since PDL only has support for double data # so there will be differences in the least significant places for # perls compiled with uselongdouble # $got = pdl q[e]; ok(approx($got, $expected, 1e-12), 'q[e] returns exp(1)') or diag("Got $got"); # using approx() here since PDL only has support for double data # so there will be differences in the least significant places for # perls compiled with uselongdouble # $got = pdl q[E]; ok(approx($got, $expected, 1e-12), 'q[E] returns exp(1)') or diag("Got $got"); $expected = pdl(1, exp(1)); $got = pdl q[1 e]; ok(all($got == $expected), 'q[1 e] returns [1 exp(1)]') or diag("Got $got"); $got = pdl q[1 E]; ok(all($got == $expected), 'q[1 E] returns [1 exp(1)]') or diag("Got $got"); $expected = pdl(exp(1), 1); $got = pdl q[e 1]; ok(all($got == $expected), 'q[e 1] returns [exp(1) 1]') or diag("Got $got"); $got = pdl q[E 1]; ok(all($got == $expected), 'q[E 1] returns [exp(1) 1]') or diag("Got $got"); $expected = pdl(1, exp(1), 2); $got = pdl q[1 e 2]; ok(all($got == $expected), 'q[1 e 2] returns [1 exp(1) 2]') or diag("Got $got"); $got = pdl q[1 E 2]; ok(all($got == $expected), 'q[1 E 2] returns [1 exp(1) 2]') or diag("Got $got"); # Already checked all the permutations of e, so just make sure that it # properly substitutes pi $expected = pdl(1, 4 * atan2(1,1)); $got = pdl q[1 pi]; ok(all($got == $expected), 'q[1 pi] returns [1 4*atan2(1,1)]') or diag("Got $got"); $got = pdl q[1 PI]; ok(all($got == $expected), 'q[1 PI] returns [1 4*atan2(1,1)]') or diag("Got $got"); $expected = pdl(4 * atan2(1,1), 1); $got = pdl q[pi 1]; ok(all($got == $expected), 'q[pi 1] returns [4*atan2(1,1) 1]') or diag("Got $got"); # Security checks # # Check croaking on arbitrary bare-words: eval {pdl q[1 foobar 2]}; isnt($@, '', 'croaks on arbitrary string input'); eval {pdl q[$a $b $c]}; isnt($@, '', 'croaks with non-interpolated strings'); # Install a function that knows if it's been executed. { my $e_was_run = 0; sub PDL::Core::e { $e_was_run++ } sub PDL::Core::e123 { $e_was_run++ } my $to_check = q[1 e 2]; eval {pdl $to_check}; is($e_was_run, 0, "Does not execute local function e in [$to_check]"); $e_was_run = 0; $to_check = q[1 +e 2]; eval {pdl $to_check}; is($e_was_run, 0, "Does not execute local function e in [$to_check]"); $e_was_run = 0; $to_check = q[1 e+ 2]; eval {pdl $to_check}; is($e_was_run, 0, "Does not execute local function e in [$to_check]"); $e_was_run = 0; $to_check = q[1e 2]; eval {pdl $to_check}; is($e_was_run, 0, "Does not execute local function e in [$to_check]"); $e_was_run = 0; $to_check = q[1e+ 2]; eval {pdl $to_check}; is($e_was_run, 0, "Does not execute local function e in [$to_check]"); $e_was_run = 0; $to_check = q[1+e 2]; eval {pdl $to_check}; is($e_was_run, 0, "Does not execute local function e in [$to_check]"); $e_was_run = 0; $to_check = q[1+e+ 2]; eval {pdl $to_check}; is($e_was_run, 0, "Does not execute local function e in [$to_check]"); $e_was_run = 0; $to_check = q[1 e123 2]; eval {pdl $to_check}; is($e_was_run, 0, "Does not execute local function e123 in [$to_check]"); $e_was_run = 0; } ############################### # Useful croaking output - 36 # ############################### eval{ pdl q[1 l 3] }; isnt($@, '', 'Croaks when invalid character is specified'); like($@, qr/found disallowed character\(s\) 'l'/, 'Gives meaningful explanation of problem'); eval{ pdl q[1 po 3] }; isnt($@, '', 'Croaks when invalid characters are specified'); like($@, qr/found disallowed character\(s\) 'po'/, 'Gives meaningful explanation of problem'); # checks for croaking behavior for consecutive signs like +-2: eval{ pdl q[1 +-2 3] }; isnt($@, '', 'Croaks when it finds consecutive signs'); like($@, qr/found a \w+ sign/, 'Gives meaningful explanation of problem'); eval{ pdl q[1 -+2 3] }; isnt($@, '', 'Croaks when it finds consecutive signs'); like($@, qr/found a \w+ sign/, 'Gives meaningful explanation of problem'); # 'larger word' croak checks (36) foreach my $special (qw(bad inf pi)) { foreach my $append (qw(2 e l)) { eval "pdl q[1 $special$append 2]"; isnt($@, '', "Croaks when it finds $special$append"); like($@, qr/larger word/, 'Gives meaningful explanation of problem'); eval "pdl q[1 $append$special 2]"; isnt($@, '', "Croaks when it finds $append$special"); like($@, qr/larger word/, 'Gives meaningful explanation of problem'); } } # e croaks (6) my $special = 'e'; foreach my $append (qw(2 e l)) { eval "pdl q[1 $special$append 2]"; isnt($@, '', "Croaks when it finds $special$append"); eval "pdl q[1 $append$special 2]"; isnt($@, '', "Croaks when it finds $append$special"); } ## Issue information ## ## Name: BAD value parsing breakage ## ## Parsing of BAD values fails to set the correct BAD value when parsing from ## the string "[BAD]". ## ## ## # input string -> expected string my $cases = { q|BAD| => q|BAD|, q|BAD BAD| => q|[BAD BAD]|, q|BAD BAD BAD| => q|[BAD BAD BAD]|, q|[BAD]| => q|[BAD]|, q|[ BAD ]| => q|[BAD]|, q|[BAD BAD]| => q|[BAD BAD]|, q|[ BAD BAD ]| => q|[BAD BAD]|, }; while( my ($case_string, $expected_string) = each %$cases ) { my $bad_pdl = pdl( $case_string ); subtest "Testing case: $case_string" => sub { ok( $bad_pdl->badflag, 'has badflag enabled'); ok( $bad_pdl->isbad->all, 'all values in PDL are BAD'); is($bad_pdl->string, $expected_string, "PDL stringifies back to input string: @{[ $bad_pdl->string ]}"); }; } done_testing; # Basic 2D array # pdl> p $x = pdl q[ [ 1, 2, 3 ], [ 4, 5, 6 ] ]; # pdl> p $x = pdl q[ 1 2 3 ; 4 5 6 ] # pdl> p $x = pdl '[ [ 1, 2, 3 ], [ 4, 5, 6 ] ]'; # # [ # [1 2 3] # [4 5 6] # ] # Basic 1D array # pdl> p $y = pdl [ 1, 2, 3, 4, 5, 6 ] # pdl> p $y = pdl q[ 1 2 3 4 5 6 ] # pdl> p $y = pdl q[1,2,3,4,5,6] # [1 2 3 4 5 6] # 1D array with signs # pdl> p $c = pdl [ 7, -2, +5 ] # pdl> p $c = pdl q[ 7 -2 +5 ] # pdl> p $c = pdl q[ 7, -2, +5 ] # [7 -2 5] # 1D array with mixed ops and signs # pdl> p $d = pdl [ 7 - 2, +5 ] # pdl> p $d = pdl q[ 7 - 2 +5 ] # [5 5] # ...another # pdl> p $d = pdl [ 7, -2 + 5 ] # pdl> p $d = pdl q[ 7 -2 + 5 ] # [7 3] # 1D array with ops, not signs # pdl> p $d = pdl [ 7 - 2 + 5 ] # pdl> p $d = pdl q[ 7 - 2 + 5 ] # 10 # A [2,3,4] shape ndarray # pdl> p $d = pdl [ [ [0, 1], [4, 0], [0, 3] ], # [ [2, 0], [4, 0], [4, 1] ], # [ [0, 1], [3, 2], [1, 4] ], # [ [1, 2], [2, 2], [2, 1] ] ]; # # [ # [ # [0 1] # [4 0] # [0 3] # ] # [ # [2 0] # [4 0] # [4 1] # ] # [ # [0 1] # [3 2] # [1 4] # ] # [ # [1 2] # [2 2] # [2 1] # ] # ] # # ...the same, just different formatting... # # [ # [ [0 1] [4 0] [0 3] ] # [ [2 0] [4 0] [4 1] ] # [ [0 1] [3 2] [1 4] ] # [ [1 2] [2 2] [2 1] ] # ] # A 3x3 2D array # pdl> p pdl [ [1, 2, 3], [2, 1, 0], [2, 2, 1] ]; # pdl> p $e = pdl q[ [ 1 2 3 ] ; [ 2 1 0 ] ; [ 2 2 1 ] ]; # pdl> p pdl q[ 1 2 3 ; 2 1 0 ; 2 2 1 ] # this should be the same # # [ # [1 2 3] # [2 1 0] # [2 2 1] # ] PDL-2.074/t/slice.t0000644000175000017500000003150414172737500013633 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::LiteF; use PDL::Dbg; # PDL::Core::set_debugging(1); # Useful for debugging. Removed by DJB whilst cleaning up the # tests # #sub kill_if_debug () { # kill INT,$$ if $ENV{UNDER_DEBUGGER}; #} sub tapprox ($$) { my $x = shift; my $y = shift; my $maxdiff = abs($x-$y)->max; return $maxdiff < 0.01; } my ($x, $y, $c, $d, $e, $f); $x = (1+(xvals zeroes 4,5) + 10*(yvals zeroes 4,5)); is($x->at(2,2), 23, "x location (2,2) is 23"); $y = $x->slice('1:3:2,2:4:2'); is($y->at(0,0), 22, "(1,2)->(0,0)"); is($y->at(1,0), 24, "(3,2)->(1,0)"); is($y->at(0,1), 42, "(1,4)->(0,1)"); is($y->at(1,1), 44, "(3,4)->(1,1)"); $y .= 0.5 * ones(2,2); is($y->at(1,0), 0.5); is($y->at(0,1), 0.5); is($x->at(1,2), 0.5); # Check that nothing happened to other elems is($x->at(2,2), 23); $x = pdl (1,2); $y = pdl [[1,2],[1,2],[1,2]]; $c = $x->slice(',*3'); # check dimensions, sum of elements and correct order of els (using tapprox) my $sum; # $c = $x->dummy(1,3); sumover($c->clump(-1),($sum=null)); ok(tapprox($y,$c)); is($sum->at, 9); is(join(',',$c->dims), "2,3"); $y = pdl [[1,1,1],[2,2,2]]; $c = $x->slice('*3,'); sumover($c->clump(-1),($sum=null)); ok(tapprox($y,$c)); is($sum->at, 9, 'sum of dummy=3 slice gives right value'); is(join(',',$c->dims), "3,2", 'right dims with dummy slice'); # test stringify $x = zeroes(3,3); my $line = $x->slice(':,(0)'); $x++; # $line += 0; # that's how to force an update before interpolation my $linepr = "$line"; is($linepr, '[1 1 1]', 'right value after collapsing slice (0)'); # Test whether error is properly returned: $y = zeroes(5,3,3); $c = $y->slice(":,:,1"); is(join(',',$c->dims), "5,3,1", 'single-coord slice dims right'); eval { my $d = $c->slice(":,:,2"); $d->string }; like($@, qr/out of bounds/, 'check slice bounds error handling') or diag "ERROR WAS: '$@'\n" if $@; $x = zeroes 3,3; $y = $x->slice("1,1:2"); $y .= 1; $x = xvals zeroes 20,20; $y = $x->slice("1:18:2,:"); $c = $y->slice(":,1:18:2"); $d = $c->slice("3:5,:"); $e = $d->slice(":,(0)"); $f = $d->slice(":,(1)"); $y->string; $c->string; $d->string; $e->string; $f->string; is("$e", "[7 9 11]"); is("$f", "[7 9 11]"); # Make sure that vaffining is properly working: $x = zeroes 5,6,2; $y = (xvals $x) + 0.1 * (yvals $x) + 0.01 * (zvals $x); $y = $y->copy; $c = $y->slice("2:3"); $d = $c->copy; # $c->dump; # $d->dump; $e = $c-$d; is(max(abs($e)), 0); my ($im, $im1, $im2, $lut, $in); $im = byte [[0,1,255],[0,0,0],[1,1,1]]; ($im1 = null) .= $im->dummy(0,3); $im2 = $im1->clump(2)->slice(':,0:2')->px; ok(!tapprox(ones(byte,9,3),$im2)); # here we encounter the problem $im2 = $im1->clump(2)->slice(':,-1:0')->px; ok(!tapprox(ones(byte,9,3),$im2)); $x = xvals( zeroes 10,10) + 0.1*yvals(zeroes 10,10); ok(tapprox($x->mslice('X',[6,7]), pdl([ [0.6, 1.6, 2.6, 3.6, 4.6, 5.6, 6.6, 7.6, 8.6, 9.6], [0.7, 1.7, 2.7, 3.7, 4.7, 5.7, 6.7, 7.7, 8.7, 9.7] ]))); $lut = pdl [[1,0],[0,1]]; $im = pdl [1]; $in = $lut->transpose->index($im->dummy(0)); is("$in", " [ [0 1] ] "); $in .= pdl 1; is("$in", " [ [1 1] ] "); ok(tapprox($lut,pdl([[1,0],[1,1]]))); # can we catch indices which are too negative? $x = PDL->sequence(10); $y = $x->slice('0:-10'); is("$y", "[0]", "slice 0:-n picks first element"); $y = $x->slice('0:-14'); eval { $y->string }; like($@, qr/slice ends out of bounds/); # Test of dice and dice_axis $x = sequence(10,4); is($x->dice([1,2],[0,3])->sum, 66, "dice"); is($x->dice([0,1],'X')->sum, 124, "dice 'X'"); # Test of dice clump compatability my $xxx = PDL->new([[[0,0]],[[1,1]],[[2,2]]]); is_deeply($xxx->where($xxx == 0)->unpdl,[0,0],"dice clump base zero"); my $dice = $xxx->dice("X","X",[1,0]); is_deeply($dice->clump(-1)->unpdl,[1,1,0,0],"dice clump correct"); is_deeply($dice->where($dice == 0)->unpdl,[0,0],"dice clump where zero"); # Test of Reorder: $x = sequence(5,3,2); my @newDimOrder = (2,1,0); $y = $x->reorder(@newDimOrder); # since doing floating-point arithmetic here, should probably # use a better test than "eq" here # my $got = [$y->dims]; is_deeply($got, [2,3,5], "Test of reorder") or diag explain $got; $x = zeroes(3,4); $y = $x->dummy(-1,2); is(join(',',$y->dims), '3,4,2'); $x = pdl(2); $y = $x->slice(''); ok(tapprox($x, $y), "Empty slice"); $x = pdl [1,1,1,3,3,4,4,1,1,2]; $y = null; $c = null; rle($x,$y,$c); ok(tapprox($x, rld($y,$c)),"rle with null input"); undef $y; undef $c; ($y,$c) = rle($x); ok(tapprox($x, rld($y,$c)),"rle with return vals"); my $x2d = $x->cat($x->rotate(1),$x->rotate(2),$x->rotate(3),$x->rotate(4)); rle($x2d,$y=null,$c=null); ok(tapprox($x2d,rld($y,$c)),"rle 2d with null input"); undef $y; undef $c; ($y,$c) = rle($x2d); ok(tapprox($x2d, rld($y,$c)),"rle 2d with return vals"); $y = $x->mslice(0.5); ok(tapprox($y, 1), "mslice 1"); $y = $x->mslice([0.5,2.11]); is("$y", "[1 1 1]", "mslice 2"); $x = zeroes(3,3); $y = $x->splitdim(3,3); eval { $y->make_physdims }; like($@, qr/splitdim:nthdim/, "make_physdim: Splitdim"); $x = sequence 5,5; $y = $x->diagonal(0,1); is("$y", "[0 6 12 18 24]", "diagonal"); $x = sequence 10; eval { $y = $x->lags(1,1,1)->make_physdims }; like($@, qr/lags:\s*dim out of range/, "make_physdim: out of range"); eval { $y = $x->lags(0,-1,1)->make_physdims }; like($@, qr/lags:\s*step must be positive/, "make_physdim: negative step"); eval { $y = $x->lags(0,1,11)->make_physdims }; like($@, qr/too large/, "make_physdim: too large"); ############################## # Tests of some edge cases $x = sequence(10); eval { $y = $x->slice("5") }; is $@, '', "simple slice works"; ok(($y->nelem==1 and $y==5), "simple slice works right"); eval { $y = $x->slice("5:") }; is $@, '', "empty second specifier works"; ok(($y->nelem == 5 and all($y == pdl(5,6,7,8,9))), "empty second specifier works right"); eval { $y = $x->slice(":5") }; is $@, '', "empty first specifier works"; ok(($y->nelem == 6 and all($y == pdl(0,1,2,3,4,5))), "empty first specifier works right"); ############################## # White space in slice specifier eval { $y = $x->slice(" 4:") }; is $@, '',"slice with whitespace worked - 1"; ok(($y->nelem==6 and all($y==pdl(4,5,6,7,8,9))),"slice with whitespace works right - 1"); eval { $y = $x->slice(" :4") }; is $@, '',"slice with whitespace worked - 2"; ok(($y->nelem==5 and all($y==pdl(0,1,2,3,4))),"slice with whitespace works right - 2"); eval { $y = $x->slice(" 3: 4 ") }; is $@, '',"slice with whitespace worked - 3"; ok(($y->nelem==2 and all($y==pdl(3,4))),"slice with whitespace works right - 3"); ############################## # Tests of permissive slicing and dummying $x = xvals(5,5)+10*yvals(5,5); eval { $y = $x->slice("1,2,(0)")->make_physical }; is $@, ''; is($y->ndims, 2, "slice->make_physical: ndims"); is(pdl($y->dims)->sumover, 2, "slice->make_physical: dims"); eval { $c = $x->slice("1,2,(1)")->make_physical }; like($@, qr/too many dims/i, "slice->make_physical: too many dims"); # Hmmm, think these could be split up but not sure exactly what is being # tested so leave as is (ish) # eval { $d = $x->slice("0:1,2:3,0")->make_physical }; is $@, ''; is $d->ndims, 3; is +(pdl($d->dims) == pdl(2,2,1))->sumover, 3; is $d->ndims, 3; is +(pdl($d->dims) == pdl(2,2,1))->sumover, 3; eval { $d = $x->slice("0:1,2:3,0")->xchg(0,2) }; is $@, '', "slice->xchg"; is $d->ndims, 3; is +(pdl($d->dims) == pdl(1,2,2))->sumover, 3; eval { $e = $x->dummy(6,2) }; is $@, '', "dummy"; is $e->ndims, 7; is +(pdl($e->dims) == pdl(5,5,1,1,1,1,2))->sumover, 7; ############################## # Tests of indexND (Nowadays this is just another call to range) my ($source, $index, $dest, $z); # Basic indexND operation $source = 10*xvals(10,10) + yvals(10,10); $index = pdl([[2,3],[4,5]],[[6,7],[8,9]]); eval { $x = $source->indexND( $index ) }; is $@, ''; ok(eval { zcheck($x != pdl([23,45],[67,89])) }, "eval of zcheck 1"); # Threaded indexND operation $source = 100*xvals(10,10,2)+10*yvals(10,10,2)+zvals(10,10,2); $index = pdl([[2,3],[4,5]],[[6,7],[8,9]]); eval { $x = $source->indexND($index) }; is $@, ''; ok(eval { zcheck($x != pdl([[230,450],[670,890]],[[231,451],[671,891]])) }, "eval of zcheck 2"); ############################## # Tests of range operator # Basic range operation $source = 10*xvals(10,10) + yvals(10,10); $index = pdl([[2,3],[4,5]],[[6,7],[8,9]]); eval { $dest = $source->range($index); }; is $@, ''; ok(eval { zcheck($dest != pdl([23,45],[67,89])); }, "eval of zcheck 3"); # Make a 3x3 range at each index eval { $dest = $source->range($index,3); }; is $@, ''; # Check that the range has the correct size is($dest->ndims, 4, "ndims after range"); ok(zcheck(pdl($dest->dims) != pdl(2,2,3,3)), "zcheck after range"); #### Check boundary conditions eval { $z = $dest->copy; }; # Should throw range-out-of-bounds error ok($@); # should check actual error message here ## Truncation eval { $z = $source->range($index,3,"t")->copy; }; is $@, ''; # Should NOT throw range-out-of-bounds error. ok(zcheck($z->slice("(1),(1)") != pdl([[89,99,0],[0,0,0],[0,0,0]]))); ## Truncation on one axis, periodic on another; string syntax eval { $z = $source->range($index,3,"tp") }; ok(zcheck($z->slice("(1),(1)") != pdl([[89,99,0],[80,90,0],[81,91,0]]))); ## Periodic on first axis, extension on another; list syntax eval { $z = $source->range($index,3,["e","p"]); }; ok(zcheck($z->slice("(1),(1)") != pdl([[89,99,99],[80,90,90],[81,91,91]]))); our $mt; eval { $mt = which(pdl(0)) }; ok("$mt" =~ m/^Empty/); our $dex = pdl(5,4,3); $z = $dex->range(zeroes(0)); # scalar Empties are autopromoted like scalar nonempties ok("$z" eq 'Empty[0]', "scalar Empty[0] indices handled correctly by range"); $z = $dex->range(zeroes(1,0)); # 1-vector Empties are handled right. ok("$z" eq 'Empty[0]', "1-vector Empty[1,0] indices handled correctly by range"); $z = $mt->range($dex,undef,'e'); ok(all($z==0),"empty source arrays handled correctly by range"); $z = $mt->range($mt); ok("$z" eq 'Empty[0]', "ranging an empty array with an empty index gives Empty[0]"); $x = pdl(5,5,5,5); $z = $x->range($mt); ok("$z" eq 'Empty[0]'); $z .= 2; # should *not* segfault! ok all($x==5), 'empty range .= no mutate'; # should *not* change $x! ### Check slicing of a null PDL $x = PDL->null; eval { $y = $x->slice("")->nelem }; is $@, '', 'null->slice no error'; is $y, 0; eval { $y = $x->slice(0)->nelem }; like $@, qr/out of bounds/; for my $start (0, 4, -4, 20, -20) { for my $stop (0, 4, -4, 20, -20) { # Generate a simple data ndarray and a bad slice of that ndarray my $data = sequence(10); my $slice = $data->slice("$start:$stop"); pass('Slice operation for properly formed slice does not croak'); # Calculate the expected dimension size: my $expected_dim_size; my $real_start = $start; $real_start += 10 if $start < 0; my $real_stop = $stop; $real_stop += 10 if $stop < 0; $expected_dim_size = abs($real_stop - $real_start) + 1 if 0 <= $real_stop and $real_stop < 10 and 0 <= $real_start and $real_start < 10; my $expected_outcome_description = defined $expected_dim_size ? 'is fine' : 'croaks'; my $dim1; # Should croak when we ask about the dimension: eval { $dim1 = $slice->dim(0) }; is($dim1, $expected_dim_size, "Requesting dim(0) on slice($start:$stop) $expected_outcome_description"); # Should *STILL* croak when we ask about the dimension: eval { $dim1 = $slice->dim(0) }; is($dim1, $expected_dim_size, "Requesting dim(0) a second time on slice($start:$stop) $expected_outcome_description"); # Calculate the expected value my $expected_value; $expected_value = $data->at($real_start) if defined $expected_dim_size; # Should croak when we ask about data my $value; eval { $value = $slice->at(0) }; is($value, $expected_value, "Requesting first element on slice($start:$stop) $expected_outcome_description"); } } { # Test vaffine optimisation my $x = zeroes(100,100); my $y = $x->slice('10:90,10:90'); $y++; ok( (not $y->allocated) ) ; } my $indices = pdl([]); $got = eval { my $s = pdl([1,2])->slice(pdl(1)); $s->string; $s->nelem }; is $@, '', 'slice 2-elt ndarray with one-length ndarray'; is $got, 1, 'right dim from 2-elt with one index'; $got = eval { my $s = pdl([1,2])->slice($indices); $s->string; $s->nelem }; is $@, '', 'slice 2-elt ndarray with zero-length ndarray'; is $got, 0, 'zero dim from 2-elt'; $got = eval { my $s = pdl([1])->slice($indices); $s->string; $s->nelem }; is $@, '', 'slice 1-elt ndarray with zero-length ndarray'; is $got, 0, 'zero dim from 1-elt'; my $pa = sequence 10; $c = PDL->pdl(7,6); $got = $pa->slice([$c->slice(1),0,0]); is "".$got, 6, 'slice did "at" automatically' or diag "got:$got"; my $cmp = pdl(2,4,6); my $rg = pdl(2,7,2); $got = $pa->slice([$rg->slice(0),$rg->slice(1),$rg->slice(2)]); ok all($got == $cmp), 'slice did "at"' or diag "got:$got"; $pa = zeroes(7, 7); $pa->set(3, 4, 1); $indices = $pa->flat->which->dummy(0,$pa->getndims)->make_physical; my $s = $indices->index(0); $s %= 7; is $indices.'', <new ([[['abc', 'def', 'ghi'],['jkl', 'mno', 'qrs']], [['tuv', 'wxy', 'zzz'],['aaa', 'bbb', 'ccc']]]); my $stringized = $pa->string; my $comp = qq{[ [ [ 'abc' 'def' 'ghi' ] [ 'jkl' 'mno' 'qrs' ] ] [ [ 'tuv' 'wxy' 'zzz' ] [ 'aaa' 'bbb' 'ccc' ] ] ] }; is( $stringized, $comp); $pa->setstr(0,0,1, 'foo'); is( $pa->atstr(0,0,1), 'foo'); $pa->setstr(2,0,0, 'barfoo'); is( $pa->atstr(2,0,0), 'bar'); $pa->setstr(0,0,1, 'f'); is( $pa->atstr(0,0,1), "f"); my $pb = sequence (byte, 4, 5) + 99; $pb = PDL::Char->new($pb); $stringized = $pb->string; $comp = "[ 'cdef' 'ghij' 'klmn' 'opqr' 'stuv' ] \n"; is($stringized, $comp); } { # Variable-length string test my $varstr = PDL::Char->new( [ ["longstring", "def", "ghi"],["jkl", "mno", 'pqr'] ] ); # Variable Length Strings: Expected Results my $comp2 = "[ [ 'longstring' 'def' 'ghi' ] [ 'jkl' 'mno' 'pqr' ] ] "; is("$varstr", $comp2); } is +PDL::Char->new( "" ).'', q{'' }; done_testing; PDL-2.074/t/matrixops.t0000644000175000017500000002423014154310742014553 0ustar osboxesosboxesuse strict; use warnings; use PDL::LiteF; use Test::More; use Test::Exception; use Config; use PDL::MatrixOps; sub tapprox { my($pa,$pb,$tol) = @_; $tol //= 1e-14; all approx $pa, $pb, $tol; } my $tol = 1e-6; sub check_inplace { my ($in, $cb, $expected, $label) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; my @expected_dims = $expected->dims; for my $inplace (0, 1) { my $in_copy = $in->copy; my $got; $inplace ? lives_ok { $cb->($in_copy->inplace); $got = $in_copy->copy } "$label inplace=$inplace runs" : lives_ok { $got = $cb->($in_copy) } "$label inplace=$inplace runs"; fail("got non-PDL ".explain($got)." back"), next if !UNIVERSAL::isa($got, 'PDL'); my @got_dims = $got->dims; is_deeply \@got_dims, \@expected_dims, "got and expected same shape inplace=$inplace" or diag 'got: ', explain \@got_dims, 'expected: ', explain \@expected_dims; ok tapprox($got, $expected, $tol), "$label inplace=$inplace" or diag "got:$got\nexpected:$expected"; } } { ### Check LU decomposition of a simple matrix my $pa = pdl([1,2,3],[4,5,6],[7,1,1]); my ($lu, $perm, $par); lives_ok { ($lu,$perm,$par) = lu_decomp($pa); } "lu_decomp 3x3 ran OK"; is($par, -1, "lu_decomp 3x3 correct parity"); ok(all($perm == pdl(2,1,0)), "lu_decomp 3x3 correct permutation"); my $l = $lu->copy; my $ldiag; ($ldiag = $l->diagonal(0,1)) .= 1; my $tmp; ($tmp = $l->slice("2,1")) .= 0; ($tmp = $l->slice("1:2,0")) .= 0; my $u = $lu->copy; ($tmp = $u->slice("1,2")) .= 0; ($tmp = $u->slice("0,1:2")) .= 0; ok(tapprox($pa,matmult($l,$u)->slice(":,-1:0"),$tol), "LU = A (after depermutation)"); } { ### Check LU decomposition of an OK singular matrix my $pb = pdl([1,2,3],[4,5,6],[7,8,9]); my ($lu,$perm,$par) = lu_decomp($pb); ok(defined $lu, "lu_decomp singular matrix defined"); ok($lu->flat->abs->at(-1) < $tol, "lu_decomp singular matrix small value"); } { ### Check inversion -- this also checks lu_backsub my $pa = pdl([1,2,3],[4,5,6],[7,1,1]); my $opt ={s=>1,lu=>\my @a}; my $inv_expected = pdl <<'EOF'; [ [ 0.055555556 -0.055555556 0.16666667] [ -2.1111111 1.1111111 -0.33333333] [ 1.7222222 -0.72222222 0.16666667] ] EOF check_inplace($pa, sub { inv($_[0], $opt) }, $inv_expected, "inv 3x3"); ok(ref ($opt->{lu}->[0]) eq 'PDL',"inverse: lu_decomp first entry is an ndarray"); ok(tapprox(matmult($inv_expected,$pa),identity(3),$tol),"matrix mult by its inverse gives identity matrix"); } { ### Check inv() with added thread dims (simple check) my $C22 = pdl([5,5],[5,7.5]); my $inv_expected = pdl([0.6, -0.4], [-0.4, 0.4]); check_inplace($C22, sub { $_[0]->inv }, $inv_expected, "inv 2x2"); check_inplace($C22->dummy(2,2), sub { $_[0]->inv }, $inv_expected->dummy(2,2), "inv 2x2 extra dim"); } { ### Check inv() for matrices with added thread dims (bug #3172882 on sf.net) my $a334 = pdl <<'EOF'; [ [ [ 1 0 4] [-1 -1 -3] [ 0 1 0] ] [ [ 4 -4 -5] [ 1 -5 -3] [-1 -2 0] ] [ [-2 2 -5] [-1 1 -3] [-4 3 -4] ] [ [-1 4 -4] [ 2 1 3] [-3 -4 -3] ] ] EOF my $a334inv; lives_ok { $a334inv = $a334->inv } "3x3x4 inv ran OK"; ok(tapprox(matmult($a334,$a334inv),identity(3)->dummy(2,4)), "3x3x4 inv gave correct answer"); } { ### Check LU backsubstitution (bug #2023711 on sf.net) my $pa = pdl([[1,2],[1,1]]); # asymmetric to see if need transpose my ($lu,$perm,$par); lives_ok { ($lu,$perm,$par) = lu_decomp($pa) } "lu_decomp 2x2 ran OK"; ok($par==1, "lu_decomp 2x2 correct parity"); ok(all($perm == pdl(0,1)), "lu_decomp 2x2 correct permutation"); my $bb = pdl([1,0], [3, 4]); my $xx_expected = pdl <<'EOF'; [ [-1 1] [ 5 -1] ] EOF check_inplace($bb, sub { lu_backsub($lu,$perm,$_[0]) }, $xx_expected, "lu_backsub"); my $got = $pa x $xx_expected->transpose; ok(tapprox($got,$bb->transpose,$tol), "A x actually == B") or diag "got: $got"; } { ### Check attempted inversion of a singular matrix my $pb = pdl([1,2,3],[4,5,6],[7,8,9]); my $b2; lives_ok { $b2 = inv($pb,{s=>1}) } "inv of singular matrix should not barf if s=>1"; ok(!defined $b2, "inv of singular matrix undefined if s=>1"); } { ### Check that det will save lu_decomp and reuse it my $m1 = pdl [[1,2],[3,4]]; # det -2 my $opt1 = {lu=>undef}; ok($m1->det($opt1) == -2, "det([[1,2],[3,4]]"); ok($opt1->{lu}[0]->index2d(0,0) == 3, "set lu"); my $m2 = pdl [[2,1],[4,3]]; # det 2 ok($m2->det == 2, "det([[2,1],[3,4]]"); ok($m2->det($opt1) == -2, "correctly used wrong lu"); } { ### Check threaded determinant -- simultaneous recursive det of four 4x4's my $pa = pdl([3,4,5,6],[6,7,8,9],[9,0,7,6],[4,3,2,0]); # det=48 my $pb = pdl([1,0,0,0],[0,1,0,0],[0,0,1,0],[0,0,0,1]); # det=1 my $c = pdl([0,1,0,0],[1,0,0,0],[0,0,1,0],[0,0,0,1]); # det=-1 my $d = pdl([1,2,3,4],[5,4,3,2],[0,0,3,0],[3,0,1,6]); # det=-216 my $e = ($pa->cat($pb)) -> cat( $c->cat($d) ); my $det = $e->determinant; ok(all($det == pdl([48,1],[-1,-216])), "threaded determinant"); } { ### Check identity and stretcher matrices... ok((identity(2)->flat == pdl(1,0,0,1))->all, "identity matrix"); ok((identity(pdl 2)->flat == pdl(1,0,0,1))->all, "identity matrix with scalar ndarray"); ok((identity(zeroes 2, 3)->flat == pdl(1,0,0,1))->all, "identity matrix with dimensioned ndarray"); my @deep_identity_dims = identity(zeroes 2, 3, 4)->dims; is_deeply \@deep_identity_dims, [2, 2, 4], "identity matrix with multi-dimensioned ndarray" or diag 'got: ', explain \@deep_identity_dims; ok((stretcher(pdl(2,3))->flat == pdl(2,0,0,3))->all, "stretcher 2x2"); ok((stretcher(pdl([2,3],[3,4]))->flat == pdl(2,0,0,3,3,0,0,4))->all, "stretcher 2x2x2"); } { ### Check eigens my $pa = pdl([3,4],[4,-3]); ### Check that eigens runs OK my ($vec,$val); lives_ok { ($vec,$val) = eigens $pa } "eigens runs OK"; ### Check that it really returns eigenvectors my $c = float(($pa x $vec) / $vec); #print "c is $c\n"; ok(all($c->slice(":,0") == $c->slice(":,1")),"eigens really returns eigenvectors"); ### Check that the eigenvalues are correct for this matrix ok((float($val->slice("0")) == - float($val->slice("1")) and float($val->slice("0") * $val->slice("1")) == float(-25)),"eigenvalues are correct"); } { ### Check computations on larger matrix with known eigenvalue sum. my $m = pdl( [ 1.638, 2.153, 1.482, 1.695, -0.557, -2.443, -0.71, 1.983], [ 2.153, 3.596, 2.461, 2.436, -0.591, -3.711, -0.493, 2.434], [ 1.482, 2.461, 2.5, 2.834, -0.665, -2.621, 0.248, 1.738], [ 1.695, 2.436, 2.834, 4.704, -0.629, -2.913, 0.576, 2.471], [-0.557, -0.591, -0.665, -0.629, 19, 0.896, 8.622, -0.254], [-2.443, -3.711, -2.621, -2.913, 0.896, 5.856, 1.357, -2.915], [ -0.71, -0.493, 0.248, 0.576, 8.622, 1.357, 20.8, -0.622], [ 1.983, 2.434, 1.738, 2.471, -0.254, -2.915, -0.622, 3.214]); { my $esum=0; my ($vec,$val); eval { ($vec,$val) = eigens($m); $esum=sprintf "%.3f", sum($val); #signature of eigenvalues }; #print STDERR "eigensum for the 8x8: $esum\n"; ok($esum == 61.308,"eigens sum for 8x8 correct answer"); } { my $esum=0; lives_ok { $esum = sprintf "%.3f", sum scalar eigens_sym($m); } "eigens_sym for 8x8 ran OK"; is($esum, 61.308, 'eigens_sym sum for 8x8 correct answer'); } { if(0){ #fails because of bad eigenvectors #Check an assymmetric matrix: my $pa = pdl ([4,-1], [2,1]); my $esum; my ($vec,$val); lives_ok { ($vec,$val) = eigens $pa; $esum=sprintf "%.3f", sum($val); }; ok($esum == 5); } } } { if(0){ #eigens for asymmetric matrices disbled #The below matrix has complex eigenvalues my $should_be_nan = eval { sum(scalar eigens(pdl([1,1],[-1,1]))) }; ok( ! ($should_be_nan == $should_be_nan)); #only NaN is not equal to itself } #check singular value decomposition for MxN matrices (M=#rows, N=#columns): my $svd_in = pdl([3,1,2,-1],[-1,3,0,2],[-2,3,0,0],[1,3,-1,2]); { #2x2; my $this_svd_in = $svd_in->slice("0:1","0:1"); my ($u,$s,$v) = svd($this_svd_in); my $ess = zeroes($this_svd_in->dim(0),$this_svd_in->dim(0)); $ess->diagonal(0,1).=$s; ok(all($this_svd_in==($u x $ess x $v->transpose)), "svd 2x2"); } { #3x3; my $this_svd_in = $svd_in->slice("0:2","0:2"); my ($u,$s,$v) = svd($this_svd_in); my $ess = zeroes($this_svd_in->dim(0),$this_svd_in->dim(0)); $ess->diagonal(0,1).=$s; ok(all(approx($this_svd_in,$u x $ess x $v->transpose, 1e-8)), "svd 3x3"); } { #4x4; my $this_svd_in = $svd_in; my ($u,$s,$v) = svd($this_svd_in); my $ess =zeroes($this_svd_in->dim(0),$this_svd_in->dim(0)); $ess->diagonal(0,1).=$s; ok(all(approx($this_svd_in,($u x $ess x $v->transpose),1e-8)),"svd 4x4"); } { #3x2 my $this_svd_in = $svd_in->slice("0:1","0:2"); my ($u,$s,$v) = svd($this_svd_in); my $ess = zeroes($this_svd_in->dim(0),$this_svd_in->dim(0)); $ess->slice("$_","$_").=$s->slice("$_") foreach (0,1); #generic diagonal ok(all(approx($this_svd_in, $u x $ess x $v->transpose,1e-8)), "svd 3x2"); } { #2x3 my $this_svd_in = $svd_in->slice("0:2","0:1"); my ($u,$s,$v) = svd($this_svd_in->transpose); my $ess = zeroes($this_svd_in->dim(1),$this_svd_in->dim(1)); $ess->slice("$_","$_").=$s->slice("$_") foreach (0..$this_svd_in->dim(1)-1); #generic diagonal ok(all(approx($this_svd_in, $v x $ess x $u->transpose,1e-8)), "svd 2x3"); } } { my $pa = pdl [[ 1, 2, 3, 0], [ 1, -1, 2, 7], [ 1, 0, 0, 1]]; my $pb = pdl [[1, 1], [0, 2], [0, 2], [1, 1]]; my $pc = pdl [[ 1, 11], [ 8, 10], [ 2, 2]]; my $res = $pa x $pb; ok(all approx($pc,$res)); my $eq = float [[1,1,1,1]]; # a 4,1-matrix ( 1 1 1 1 ) # Check collapse: output should be a 1x2... ok(all approx($eq x $pb , pdl([[2,6]]) )); # ([4x1] x [2x4] -> [1x2]) # Check dimensional exception: mismatched dims should throw an error dies_ok { my $pz = $pb x $eq; # [2x4] x [4x1] --> error (2 != 1) }; { # Check automatic scalar multiplication my $pz; lives_ok { $pz = $pb x 2; }; ok( all approx($pz,$pb * 2)); } { my $pz; lives_ok { $pz = pdl(3) x $pb; }; ok( all approx($pz,$pb * 3)); } } { # test inspired by Luis Mochan my $A = sequence(2, 2) + 1; my $A1 = $A->slice(',1:0'); # interchange two rows my $B = pdl(1,1); my $x_expected = pdl([[-1, 1]]); check_inplace($B, sub { lu_backsub($A->lu_decomp, $_[0]) }, $x_expected, "lu_backsub dims"); check_inplace($B, sub { lu_backsub($A1->lu_decomp, $_[0]) }, $x_expected, "lu_backsub dims 2"); my $got = $A x $x_expected->transpose; ok(tapprox($got,$B->transpose,$tol), "A x actually == B") or diag "got: $got"; } done_testing; PDL-2.074/t/nat_complex.t0000644000175000017500000001337614163314516015052 0ustar osboxesosboxesuse strict; use warnings; use PDL::LiteF; use PDL::Config; use PDL::Core::Dev; use PDL::Types qw(ppdefs ppdefs_complex ppdefs_all); use Test::More; sub tapprox { my($x,$y) = @_; my $c = abs($x-$y); my $d = max($c); $d < 0.0001; } is_deeply [ ppdefs() ], [qw(A B S U L K N P Q F D E)]; is_deeply [ ppdefs_complex() ], [qw(G C H)]; is_deeply [ ppdefs_all() ], [qw(A B S U L K N P Q F D E G C H)]; my $ref = pdl([[-2,1],[-3,1]]); my $ref2 = squeeze(czip($ref->slice("0,"), $ref->slice("1,"))); my $x = i() -pdl (-2, -3); is($x->type, 'cdouble', 'type promotion i - ndarray'); ok(tapprox($x->im,$ref->slice("1,:")), 'value from i - ndarray'); ok !$x->type->real, 'complex type not real'; ok double->real, 'real type is real'; ok !$x->sumover->type->real, 'sumover type=complex'; $x = cdouble(2,3); $x-=i2C(3); is type($x), 'cdouble', 'type promotion ndarray - i'; is $x->re->type, 'double', 'real real part'; my $y=cfloat($x); is type($y), 'cfloat', 'type conversion to cfloat'; is $y->re->type, 'float', 'real real part'; ok(tapprox($x->im,$ref->slice("0,1")), 'value from ndarray - i') or diag 'got: ', $x->im; is zeroes($_->[0], 2)->r2C->type, $_->[1], "r2C $_->[0] -> $_->[1]" for [byte, 'cdouble'], [long, 'cdouble'], [float, 'cfloat'], [cfloat, 'cfloat'], [double, 'cdouble'], [cdouble, 'cdouble']; my $got_double = double(-1, 2); my $got_r2C = $got_double->r2C; is ''.$got_r2C->re, ''.$got_double, 're(r2C) identical to orig'; my $got = r2C(1); is $got, 1, 'can give Perl numbers to r2C'; ok !$got->type->real, 'complex type'; $got = i2C(1); is $got, i(), 'can give Perl numbers to i2C'; ok !$got->type->real, 'complex type'; ok !i(2, 3)->type->real, 'i(2, 3) returns complex type'; for (float, double, ldouble, cfloat, cdouble, cldouble) { my $got = pdl $_, '[0 BAD]'; my $bv = $got->badvalue; my $obv = $got->orig_badvalue; is $got.'', '[0 BAD]', "$_ bad" or diag "bv=$bv, obv=$obv: ", explain [$bv, $obv]; is $got->isbad.'', '[0 1]', "$_ isbad"; # this captures a failure in IO/Flexraw/t/iotypes.t eval { ok $bv == $obv, 'can equality-check badvalue and orig_badvalue' }; is $@, '', 'no error from ==' or diag explain [$bv, $obv]; } { # dataflow from complex to real my $ar = $x->re; $ar++; ok(tapprox($x->re, -$ref->slice("0,")->squeeze + 1), 'complex to real dataflow') or diag "got=".$x->re; my $ai = $x->im; $x+=i; my $expected = pdl(-2, -2); ok(tapprox($x->im, $expected), 'dataflow after conversion') or diag "got=".$x->im, "\nexpected=$expected"; $ai++; $expected++; ok(tapprox($x->im, $expected), 'dataflow after change ->im') or diag "got=".$x->im, "\nexpected=$expected"; } # Check that converting from re/im to mag/ang and # back we get the same thing $x = $ref2->copy; my $a=abs($x); my $p=carg($x)->double; # force to double to avoid glibc bug 18594 $y = czip($a*cos($p), $a*sin($p)); ok(tapprox($x-$y, 0.), 'check re/im and mag/ang equivalence') or diag "For ($x), got: ($y) from a=($a) p=($p) cos(p)=(", cos($p), ") sin(p)=(", sin($p), ")"; # Catan, Csinh, Ccosh, Catanh, Croots my $cabs = sqrt($x->re**2+$x->im**2); ok(abs($x)->type->real, 'Cabs type real'); ok(tapprox(abs $x, $cabs), 'Cabs value') or diag "got: (@{[abs $x]}), expected ($cabs)"; ok(tapprox(abs2 $x, $cabs**2), 'Cabs2 value') or diag "got: (@{[abs2 $x]}), expected (", $cabs**2, ")"; ok(carg($x)->type->real, 'Carg type real'); ok(tapprox(carg($x), atan2($x->im, $x->re)), 'Carg value'); { # Check cat'ing $y = $x->re->copy + 1; my $bigArray = $x->cat($y); my $sum = $bigArray->sum; my $cz = czip(8, -2); my $abs = abs($sum + $cz); ok(all($abs < .0001), 'check cat for complex') or diag "got:$abs"; } if (PDL::Core::Dev::got_complex_version('pow', 2)) { ok(tapprox($x**2, $x * $x), '** op complex') or diag "For ($x), got: ", $x**2, ", expected: ", $x * $x; ok(tapprox($x->pow(2), $x * $x), 'complex pow') or diag "Got: ", $x->pow(2), ", expected: ", $x * $x; ok(tapprox($x->power(2, 0), $x * $x), 'complex power') or diag "Got: ", $x->power(2, 0), ", expected: ", $x * $x; my $z = pdl(0) + i()*pdl(0); $z **= 2; ok(tapprox($z, i2C(0)), 'check that 0 +0i exponentiates correctly'); # Wasn't always so. my $r = r2C(-10); $r **= 2; ok(tapprox($r, r2C(100)), 'check that imaginary part is exactly zero') # Wasn't always so or diag "got: ", $r; } my $asin_2 = PDL::asin(2).""; like $asin_2, qr/nan/i, 'perl scalar 2 treated as real'; $asin_2 = PDL::asin(2.0).""; like $asin_2, qr/nan/i, 'perl scalar 2.0 treated as real'; $asin_2 = PDL::asin(byte 2).""; like $asin_2, qr/nan/i, 'real byte treated as real'; $asin_2 = PDL::asin(double 2).""; like $asin_2, qr/nan/i, 'real double treated as real'; $asin_2 = PDL::asin(pdl 2).""; like $asin_2, qr/nan/i, 'pdl(2) treated as real'; if (PDL::Core::Dev::got_complex_version('asin', 1)) { my $c_asin_2 = PDL::asin(cdouble(2)).""; unlike $c_asin_2, qr/nan/i, 'asin of complex gives complex result'; } { # Check stringification of complex ndarray my $c = 9.1234 + 4.1234*i(); like($c->dummy(2,1).'', qr/9.123.*4.123/, 'stringify native complex'); } #test overloaded operators { my $less = czip(3, -4); my $equal = -1*(-3+4*i); my $more = czip(3, 2); my $zero_imag = r2C(4); eval { my $bool = $less<$more }; ok $@, 'exception on invalid operator'; eval { my $bool = $less<=$equal }; ok $@, 'exception on invalid operator'; ok($less==$equal,'equal to'); ok(!($less!=$equal),'not equal to'); eval { my $bool = $more>$equal }; ok $@, 'exception on invalid operator'; eval { my $bool = $more>=$equal }; ok $@, 'exception on invalid operator'; ok($zero_imag==4,'equal to real'); ok($zero_imag!=5,'neq real'); } is pdl(i)->type, 'cdouble', 'pdl(complex ndarray) -> complex-typed ndarray'; is pdl([i])->type, 'cdouble', 'pdl([complex ndarray]) -> complex-typed ndarray'; done_testing; PDL-2.074/t/pp_croaking.t0000644000175000017500000000165714166713036015037 0ustar osboxesosboxes# Test the error reporting for malformed PDL::PP code. use strict; use warnings; use Test::More; # Load up PDL::PP use PDL::PP qw(foo::bar foo::bar foobar); # Prevent file generation (does not prevent calling of functions) $PDL::PP::done = 1; # Check the loop malformed call: eval { pp_def(test1 => Pars => 'a(n)', Code => q{ loop %{ $a()++; %} } ); }; my $err_msg = $@; isnt($@, undef, 'loop without dim name should throw an error'); like($@, qr/Expected.*loop.*%\{/, 'loop without dim name should explain the error') or diag("Got this error: $@"); TODO: { local $TODO = 'Have not figured out why @CARP_NOT is not working'; unlike($@, qr/PP\.pm/, 'Should not report error as coming from PDL::PP'); }; eval { pp_def(test1 => Pars => 'a(n)', OtherPars => 'int b; int c', OtherParsDefaults => { b => 0 }, Code => q{;}, ); }; isnt $@, '', 'error to give default for non-last params'; done_testing; PDL-2.074/t/subclass.t0000644000175000017500000002651614166713036014363 0ustar osboxesosboxesuse strict; use warnings; use PDL::LiteF; use Test::More; # Test PDL Subclassing via hashes ########### First test normal subclassing ########### { package PDL::Derived; our @ISA = qw/PDL/; sub new { my $class = shift; my $x = bless {}, $class; my $value = shift; $$x{PDL} = $value; $$x{SomethingElse} = 42; return $x; } } # Create a PDL::Derived instance my $z = PDL::Derived->new( ones(5,5) ) ; # PDL::Derived should have PDL properties $z++; ok(sum($z)==50, "derived object does PDL stuff"); # And should also have extra bits ok($$z{SomethingElse}==42, "derived has extra bits" ); # And survive destruction undef $z; ########### Now test magic subclassing i.e. PDL=code ref ########### { package PDL::Derived2; # This is a array of ones of dim 'Coeff' # All that is stored initially is "Coeff", the # PDL array is only realised when a boring PDL # function is called on it. One can imagine methods # in PDL::Derived2 doing manipulation on the Coeffs # rather than actualizing the data. our @ISA = qw/PDL/; sub new { my $class = shift; my $x = bless {}, $class; my $value = shift; $$x{Coeff} = $value; $$x{PDL} = sub { return $x->cache }; $$x{SomethingElse} = 42; return $x; } # Actualize the value (demonstrating cacheing) # One can imagine expiring the cache if say, Coeffs change sub cache { my $self = shift; my $v = $self->{Coeff}; $self->{Cache} = PDL->ones($v,$v)+2 unless exists $self->{Cache}; return $self->{Cache}; } } # Create a PDL::Derived2 instance $z = PDL::Derived2->new(5); # PDL::Derived2 should have PDL properties $z++; ok(sum($z)==100, "derived2 has PDL properties"); # And should also have extra bits ok($$z{SomethingElse}==42, "derived2 has extra bits" ); # And survive destruction undef $z; ### tests for proper output value typing of the major ### categories of PDL primitive operations. ### For example: ### If $pdlderived is a PDL::derived object (subclassed from PDL), ### then $pdlderived->sumover should return a PDL::derived object. ### # Test PDL Subclassing via hashes ########### Subclass typing Test ########### ## First define a PDL-derived object: { package PDL::Derived3; our @ISA = qw/PDL/; sub new { my $class = shift; my $data = $_[0]; my $self; if(ref($data) eq 'PDL' ){ # if $data is an object (a pdl) $self = $class->initialize; $self->{PDL} = $data; } else{ # if $data not an object call inherited constructor $self = $class->SUPER::new($data); } return $self; } ####### Initialize function. This over-ridden function is called by the PDL constructors sub initialize { my $class = shift; my $self = { PDL => PDL->null, # used to store PDL object someThingElse => 42, }; $class = (ref $class ? ref $class : $class ); bless $self, $class; } ###### Derived3 Object Needs to supply its own copy ##### sub copy { my $self = shift; # setup the object my $new = $self->initialize; # copy the PDL $new->{PDL} = $self->{PDL}->SUPER::copy; # copy the other stuff: $new->{someThingElse} = $self->{someThingElse}; return $new; } } ## Now check to see if the different categories of primitive operations ## return the PDL::Derived3 type. # Create a PDL::Derived3 instance $z = PDL::Derived3->new( ones(5,5) ) ; ok(ref($z)eq"PDL::Derived3", "create derived instance"); #### Check the type after incrementing: $z++; ok(ref($z) eq "PDL::Derived3", "check type after incrementing"); #### Check the type after performing sumover: my $y = $z->sumover; ok(ref($y) eq "PDL::Derived3", "check type after sumover"); #### Check the type after adding two PDL::Derived3 objects: my $x = PDL::Derived3->new( ones(5,5) ) ; my $w = $x + $z; ok(ref($w) eq "PDL::Derived3", "check type after adding"); #### Check the type after calling null: my $a1 = PDL::Derived3->null(); ok(ref($a1) eq "PDL::Derived3", "check type after calling null"); ##### Check the type for a biops2 operation: $w = ($x == $z); ok(ref($w) eq "PDL::Derived3", "check type for biops2 operation"); ##### Check the type for a biops3 operation: $w = ($x | $z); ok(ref($w) eq "PDL::Derived3", "check type for biops3 operation"); ##### Check the type for a ufuncs1 operation: $w = sqrt($z); ok(ref($w) eq "PDL::Derived3", "check type for ufuncs1 operation"); ##### Check the type for a ufuncs1f operation: $w = sin($z); ok(ref($w) eq "PDL::Derived3", "check type for ufuncs1f operation"); ##### Check the type for a ufuncs2 operation: $w = ! $z; ok(ref($w) eq "PDL::Derived3", "check type for ufuncs2 operation"); ##### Check the type for a ufuncs2f operation: $w = log $z; ok(ref($w) eq "PDL::Derived3", "check type for ufuncs2f operation"); ##### Check the type for a bifuncs operation: $w = $z**2; ok(ref($w) eq "PDL::Derived3", "check type for bifuncs operation"); ##### Check the type for a slicing operation: $a1 = PDL::Derived3->new(1+(xvals zeroes 4,5) + 10*(yvals zeroes 4,5)); $w = $a1->slice('1:3:2,2:4:2'); ok(ref($w) eq "PDL::Derived3", "check type for slicing operation"); ##### Check that slicing with a subclass index works (sf.net bug #369) $a1 = sequence(10,3,2); my $idx = PDL::Derived3->new(2,5,8); ok(defined(eval 'my $r = $a1->slice($idx,"x","x");'), "slice works with subclass index"); ########### Test of method over-riding in subclassed objects ########### ### Global Variable used to tell if method over-riding worked ### $main::OVERRIDEWORKED = 0; ## First define a PDL-derived object: { package PDL::Derived4; our @ISA = qw/PDL/; sub new { my $class = shift; my $data = $_[0]; my $self; if(ref($data) eq 'PDL' ){ # if $data is an object (a pdl) $self = $class->initialize; $self->{PDL} = $data; } else{ # if $data not an object call inherited constructor $self = $class->SUPER::new($data); } return $self; } ####### Initialize function. This over-ridden function is called by the PDL constructors sub initialize { my $class = shift; my $self = { PDL => PDL->null, # used to store PDL object someThingElse => 42, }; $class = (ref $class ? ref $class : $class ); bless $self, $class; } ###### Derived4 Object Needs to supply its own copy ##### sub copy { my $self = shift; # setup the object my $new = $self->initialize; # copy the PDL $new->{PDL} = $self->{PDL}->SUPER::copy; # copy the other stuff: $new->{someThingElse} = $self->{someThingElse}; return $new; } ### Check of over-riding sumover ### This sumover should be called from PDL->sum. ### If the result is different from the normal sumover by $self->{SomethingElse} (42) then ### we will know that it has been called. sub sumover{ my $self = shift; my ($arg) = @_; if( ! defined $arg){ # no-argument form of calling $arg = $self->SUPER::sumover; return $self->{someThingElse} + $arg; } else{ # one-argument form of calling $self->SUPER::sumover($arg); $arg += $self->{someThingElse}; } } #### test of overriding minmaximum. Calls inherited minmaximum and #### Sets the Global variable main::OVERRIDEWORKED if called #### sub minmaximum{ my $self = shift; my ($arg) = @_; $main::OVERRIDEWORKED = 1; # set the global variable so we know over-ride worked. # print "In over-ridden minmaximum\n"; $self->SUPER::minmaximum(@_); } #### test of overriding inner. Calls inherited inner and #### Sets the Global variable main::OVERRIDEWORKED if called #### sub inner{ my $self = shift; my ($arg) = @_; $main::OVERRIDEWORKED = 1; # set the global variable so we know over-ride worked. # print "In over-ridden inner\n"; $self->SUPER::inner(@_); } #### test of overriding which. Calls inherited which and #### Sets the Global variable main::OVERRIDEWORKED if called #### sub which{ my $self = shift; my ($arg) = @_; $main::OVERRIDEWORKED++; # set the global variable so we know over-ride worked. # print "In over-ridden which\n"; $self->SUPER::which(@_); } #### test of overriding one2nd. Calls inherited one2nd and #### increments the Global variable main::OVERRIDEWORKED if called #### sub one2nd{ my $self = shift; my ($arg) = @_; $main::OVERRIDEWORKED++; # set the global variable so we know over-ride worked. # print "In over-ridden one2nd\n"; $self->SUPER::one2nd(@_); } } ###### Testing Begins ######### my $im = PDL::Derived4->new([ [ 1, 2, 3, 3 , 5], [ 2, 3, 4, 5, 6], [13, 13, 13, 13, 13], [ 1, 3, 1, 3, 1], [10, 10, 2, 2, 2,] ]); # Check for PDL::sumover being called by sum ok($im->sum == 176, "PDL::sumover is called by sum" ); # result will be = 134 if derived sumover # is not called, 176 if it is called. ### Test over-ride of minmaximum: $main::OVERRIDEWORKED = 0; my @minMax = $im->minmax; ok($main::OVERRIDEWORKED == 1, "over-ride of minmaximum"); ### Test over-ride of inner: ## Update to use inner, not matrix mult - CED 8-May-2010 $main::OVERRIDEWORKED = 0; my $matMultRes = $im->inner($im); ok($main::OVERRIDEWORKED == 1, "over-ride of inner"); ### Test over-ride of which, one2nd $main::OVERRIDEWORKED = 0; # which ND test $a1= PDL::Derived4->sequence(10,10,3,4); # $PDL::whichND_no_warning = 1; # my ($x, $y, $z, $w)=whichND($a1 == 203); # ok($main::OVERRIDEWORKED == 2, "whichND test"); ($x, $y, $z, $w) = whichND($a1 == 203)->mv(0,-1)->dog; # quiet deprecation warning ok($main::OVERRIDEWORKED == 1, "whichND worked"); # whitebox test condition, uugh! # Check to see if the clip functions return a derived object: ok(ref( $im->clip(5,7) ) eq "PDL::Derived4", "clip returns derived object"); ok(ref( $im->hclip(5) ) eq "PDL::Derived4", "hclip returns derived object"); ok(ref( $im->lclip(5) ) eq "PDL::Derived4", "lclip returns derived object"); ########### Test of Subclassed-object copying for simple function cases ########### ## First define a PDL-derived object: { package PDL::Derived5; our @ISA = qw/PDL/; sub new { my $class = shift; my $data = $_[0]; my $self; if(ref($data) eq 'PDL' ){ # if $data is an object (a pdl) $self = $class->initialize; $self->{PDL} = $data; } else{ # if $data not an object call inherited constructor $self = $class->SUPER::new($data); } return $self; } ####### Initialize function. This over-ridden function is called by the PDL constructors sub initialize { my $class = shift; my $self = { PDL => PDL->null, # used to store PDL object someThingElse => 42, }; $class = (ref $class ? ref $class : $class ); bless $self, $class; } ###### Derived5 Object Needs to supply its own copy ##### sub copy { my $self = shift; # setup the object my $new = $self->initialize; # copy the PDL $new->{PDL} = $self->{PDL}->SUPER::copy; # copy the other stuff: $new->{someThingElse} = $self->{someThingElse}; return $new; } } ####################################################### ###### Testing Begins ######### # Create New PDL::Derived5 Object # (Initialize sets 'someThingElse' data member # to 42) $im = PDL::Derived5->new([ [ 1, 2, 3, 3 , 5], [ 2, 3, 4, 5, 6], [13, 13, 13, 13, 13], [ 1, 3, 1, 3, 1], [10, 10, 2, 2, 2,] ]); # Set 'someThingElse' Data Member to 24. (from 42) $im->{someThingElse} = 24; # Test to see if simple functions (a functions # with signature sqrt a(), [o]b() ) copies subclassed object correctly. my @simpleFuncs = (qw/bitnot sqrt abs sin cos not exp log10/); foreach my $op( @simpleFuncs){ $w = $im->$op(); ok($w->{someThingElse} == 24, "$op subclassed object correctly"); } done_testing; PDL-2.074/t/autoload.t0000644000175000017500000000162014172737500014340 0ustar osboxesosboxes# Test PDL::AutoLoader use strict; use warnings; use Test::More; use PDL::LiteF; plan skip_all => 'This test must be run from t/..' if !-f 't/func.pdl'; use_ok('PDL::AutoLoader'); #$PDL::debug = 1; our @PDLLIB = ("./t"); # this means you have to run the test from t/.. my $x = long(2 + ones(2,2)); my $y = func($x); ok approx(sum($y), 4*29), 'Check autoload of func.pdl' or diag "got=$y"; #check that tilde expansion works (not applicable on MS Windows) SKIP: { skip "Inapplicable to MS Windows", 1 if $^O =~ /MSWin/i; my $tilde = (PDL::AutoLoader::expand_path('~'))[0]; my $get = $ENV{'HOME'} || (getpwnam( getlogin || getpwuid($<) ))[7]; my $glob = glob q(~); if ($glob !~ /^~/) { is($tilde, $glob, "Check tilde expansion (Got '$get' from (getpwnam(getpwuid(\$<)))[7] )"); } else { is($tilde, $get, "Check tilde expansion (Got '$glob' from glob ~"); } } done_testing; PDL-2.074/t/primitive.t0000644000175000017500000006071314176423165014553 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::LiteF; use PDL::Types; sub tapprox { my($x,$y) = @_; $_ = pdl($_) for $x, $y; if(join(',',$x->dims) ne join(',',$y->dims)) { diag "APPROX: $x $y\n"; diag "UNEQDIM\n"; return 0; } my $d = max( abs($x-$y) ); if($d >= 0.01) { use Carp; confess "SHIT"; diag "APPROX: $x $y\n"; } $d < 0.01; } my $x = PDL->pdl([[5,4,3],[2,3,1.5]]); ok(tapprox($x->average(), PDL->pdl([4, 2.16666])), "average"); ok(tapprox($x->sumover(), PDL->pdl([12, 6.5])), "sumover"); ok(tapprox($x->prodover(), PDL->pdl([60, 9])), "prodover"); my $y = PDL->pdl(4,3,1,0,0,0,0,5,2,0,3,6); my $c = ($y->xvals) + 10; ok(tapprox($y->where($y>4), PDL->pdl(5,6)), "where with >"); ok(tapprox($y->which, PDL->pdl(0,1,2,7,8,10,11)), "which"); ok(tapprox($c->where($y), PDL->pdl(10,11,12,17,18,20,21)), "where with mask"); { my $orig = ones(byte, 300); my $xvals = $orig->xvals; is $xvals->at(280), 280, 'non-wrapped xvals from byte ndarray'; } ############################## # originally in pptest $x = ones(byte,3000); dsumover($x,($y=null)); is($y->get_datatype, $PDL_D, "get_datatype" ); is($y->at, 3000, "at" ); my $p = pdl [ 1, 2, 3, 4, 7, 9, 1, 1, 6, 2, 5]; my $q = zeroes 5; minimum_n_ind $p, $q; ok(tapprox($q, pdl(0, 6, 7, 1, 9)), "minimum_n_ind"); ############################## # check that our random functions work with Perl's srand TODO: { local $TODO = 'Some CPAN Testers fails for OpenBSD'; srand 5; my $r1 = random 10; srand 5; my $r2 = random 10; ok(tapprox($r1, $r2), "random and srand"); srand 10; $r1 = grandom 10; srand 10; $r2 = grandom 10; ok(tapprox($r1, $r2), "grandom and srand"); } ############################## # Test that whichND works OK my $r = xvals(10,10)+10*yvals(10,10); $x = whichND( $r % 12 == 0 ); # Nontrivial case gives correct coordinates ok(eval { sum($x != pdl([0,0],[2,1],[4,2],[6,3],[8,4],[0,6],[2,7],[4,8],[6,9]))==0 }, "whichND"); is $x->type, 'indx', "whichND returns indx-type ndarray for non-trivial case"; # Empty case gives matching Empty $x = whichND( $r*0 ); is $x->nelem, 0, "whichND( 0*\$r ) gives an Empty PDL"; is_deeply [$x->dims], [2,0], "whichND( 0*\$r ) is 2x0"; is $x->type, 'indx', "whichND( 0*\$r) type is indx"; # Scalar PDLs are treated as 1-PDLs $x = whichND(pdl(5)); is $x->nelem, 1, "whichND scalar PDL"; is $x, 0, "whichND scalar PDL"; is $x->type, 'indx', "whichND returns indx ndarray for scalar ndarray mask"; # Scalar empty case returns a 1-D vector of size 0 $x = whichND(pdl(0)); is $x->nelem, 0, "whichND of 0 scalar is empty"; is_deeply [$x->dims], [0], "whichND of 0 scalar: return 0 dim size is 0"; is $x->type, 'indx', "whichND returns indx-type ndarray for scalar empty case"; # Empty case returns Empty $y = whichND( which(pdl(0)) ); is $y->nelem, 0, "whichND of Empty mask"; is $y->type, 'indx', "whichND returns indx-type ndarray for empty case"; # Nontrivial empty mask case returns matching Empty -- whichND(Empty[2x0x2]) should return Empty[3x0] $y = whichND(zeroes(2,0,2)); is_deeply [$y->dims], [3,0], "whichND(Empty[2x0x2]) returns Empty[3x0]"; $r = zeroes(7, 7); $r->set(3, 4, 1); is $r->whichND.'', <norm, pdl(<<'EOF')), 'native complex norm works' or diag $x->norm; [ [0.267261i 0.534522+0.801783i] [0.356348+0.445435i 0.534522+0.623609i] ] EOF ############################## # Simple test case for interpND $x = xvals(10,10)+yvals(10,10)*10; my $index = cat(3+xvals(5,5)*0.25,7+yvals(5,5)*0.25)->reorder(2,0,1); my $z = 73+xvals(5,5)*0.25+2.5*yvals(5,5); eval { $y = $x->interpND($index) }; is $@, ''; is sum($y != $z), 0, "interpND"; ############################## # Test glue $x = xvals(2,2,2); $y = yvals(2,2,2); $c = zvals(2,2,2); our $d; eval { $d = $x->glue(1,$y,$c) }; is $@, ''; ok(zcheck($d - pdl([[0,1],[0,1],[0,0],[1,1],[0,0],[0,0]], [[0,1],[0,1],[0,0],[1,1],[1,1],[1,1]])), "glue"); ############################## # test new empty ndarray handling $x = which ones(4) > 2; $y = $x->long; $c = $x->double; ok(isempty $x, "isempty"); ok($y->avg == 0, "avg of Empty"); ok(! any isfinite $c->average, "isfinite of Empty"); ############################## # Test uniqvec $x = pdl([[0,1],[2,2],[0,1]]); $y = $x->uniqvec; eval { $c = all($y==pdl([[0,1],[2,2]])) }; is $@, ''; ok $c, "uniqvec"; is $y->ndims, 2, "uniqvec"; $x = pdl([[0,1]])->uniqvec; eval { $c = all($x==pdl([[0,1]])) }; is $@, ''; ok $c, "uniqvec"; is $x->ndims, 2, "uniqvec"; $x = pdl([[0,1,2]]); $x = $x->glue(1,$x,$x); $y = $x->uniqvec; eval { $c = all($y==pdl([0,1,2])) }; is $@, ''; ok $c, "uniqvec"; is $y->ndims, 2, "uniqvec"; ############################## # Test bad handling in selector $y = xvals(3); ok(tapprox($y->which,PDL->pdl(1,2)), "which"); setbadat $y, 1; ok(tapprox($y->which,PDL->pdl([2])), "which w BAD"); setbadat $y, 0; setbadat $y, 2; is($y->which->nelem,0, "which nelem w BAD"); ############################ # Test intersect & setops my $temp = sequence(10); $x = which(($temp % 2) == 0); $y = which(($temp % 3) == 0); $c = setops($x, 'AND', $y); ok(tapprox($c, pdl([0, 6])), "setops AND"); ok(tapprox(intersect($x,$y),pdl([0,6])), "intersect same as setops AND"); $c = setops($x,'OR',$y); ok(tapprox($c, pdl([0,2,3,4,6,8,9])), "setops OR"); $c = setops($x,'XOR',$y); ok(tapprox($c, pdl([2,3,4,8,9])), "setops XOR"); #Test intersect again my $intersect_test=intersect(pdl(1,-5,4,0), pdl(0,3,-5,2)); ok (all($intersect_test==pdl(-5,0)), 'Intersect test values'); ############################## # Test uniqind $x = pdl([0,1,2,2,0,1]); $y = $x->uniqind; eval { $c = all($y==pdl([0,1,3])) }; is $@, ''; ok $c, "uniqind"; is $y->ndims, 1, "uniqind"; $y = pdl(1,1,1,1,1)->uniqind; # SF bug 3076570 ok(! $y->isempty); eval { $c = all($y==pdl([0])) }; is $@, ''; ok $c, "uniqind"; is $y->ndims, 1, "uniqind, SF bug 3076570"; ############################## # Test whereND $x = sequence(4,3,2); $y = pdl(0,1,1,0); $c = whereND($x,$y); ok(all(pdl($c->dims)==pdl(2,3,2))) and ok(all($c==pdl q[ [ [ 1 2] [ 5 6] [ 9 10] ] [ [13 14] [17 18] [21 22] ] ]), "whereND [4]"); $y = pdl q[ 0 0 1 1 ; 0 1 0 0 ; 1 0 0 0 ]; $c = whereND($x,$y); ok(all(pdl($c->dims)==pdl(4,2))) and ok(all($c==pdl q[ 2 3 5 8 ; 14 15 17 20 ]), "whereND [4,3]"); $y = (random($x)<0.3); $c = whereND($x,$y); ok(all($c==where($x,$y)), "whereND vs where"); # sf.net bug #3415115, whereND fails to handle all zero mask case $y = zeros(4); $c = whereND($x,$y); ok($c->isempty, 'whereND of all-zeros mask'); # Make sure whereND functions as an lvalue: $x = sequence(4,3); $y = pdl(0, 1, 1, 1); eval { $x->whereND($y) *= -1 }; is($@, '', 'using whereND in lvalue context does not croak'); ok(all($x->slice("1:-1") < 0), 'whereND in lvalue context works'); #Test fibonacci. my $fib=fibonacci(15); my $fib_ans = pdl(1,1,2,3,5,8,13,21,34,55,89,144,233,377,610); ok(all($fib == $fib_ans), 'Fibonacci sequence'); #Test which_both. my $which_both_test=pdl(1,4,-2,0,5,0,1); my ($nonzero,$zero)=which_both($which_both_test); ok(all($nonzero==pdl(0,1,2,4,6)), 'Which_both nonzero indices'); ok(all($zero==pdl(3,5)), 'Which_both zero indices'); ###### Testing Begins ######### my $im = new PDL [ [ 1, 2, 3, 3 , 5], [ 2, 3, 4, 5, 6], [13, 13, 13, 13, 13], [ 1, 3, 1, 3, 1], [10, 10, 2, 2, 2,] ]; my @minMax = $im->minmax; ok($minMax[0] == 1, "minmax min" ); ok($minMax[1] == 13, "minmax max" ); ok(($im x $im)->sum == 3429, "matrix multiplication" ); my @statsRes = $im->stats; ok(tapprox($statsRes[0],5.36), "stats: mean" ); ok(tapprox($statsRes[1],4.554), "stats: prms"); ok(tapprox($statsRes[2],3), "stats: median"); ok(tapprox($statsRes[3],1), "stats: min"); ok(tapprox($statsRes[4],13), "stats: max"); ok(tapprox($statsRes[6],4.462), "stats: rms"); @statsRes = $im->short->stats; # Make sure that stats are promoted to floating-point ok(tapprox($statsRes[0],5.36), "stats: float mean"); ok(tapprox($statsRes[1],4.554), "stats: float prms"); ok(tapprox($statsRes[2],3), "stats: float median"); ok(tapprox($statsRes[3],1), "stats: float min"); ok(tapprox($statsRes[4],13), "stats: float max"); ok(tapprox($statsRes[6],4.462), "stats: float rms"); my $ones = ones(5,5); @statsRes = $im->stats($ones); ok(tapprox($statsRes[0],5.36), "stats: trivial weights mean" ); ok(tapprox($statsRes[1],4.554), "stats: trivial weights prms" ); ok(tapprox($statsRes[2],3), "stats: trivial weights median" ); ok(tapprox($statsRes[3],1), "stats: trivial weights min" ); ok(tapprox($statsRes[4],13), "stats: trivial weights max" ); ok(tapprox($statsRes[6],4.462), "stats: trivial weights rms"); # complex matmult my $cm1 = cdouble(1, czip(1, 1), 1); my $cm2 = cdouble(2, 3, i()); my $got = $cm1 x $cm2->dummy(0); ok all(approx $got, czip(5, 4)), 'complex matmult' or diag $got; # which ND test my $a1 = PDL->sequence(10,10,3,4); # $PDL::whichND_no_warning = 1; # ($x, $y, $z, $w)=whichND($a1 == 203); ($x, $y, $z, my $w) = whichND($a1 == 203)->mv(0,-1)->dog; # quiet deprecation warning ok($a1->at($x->list,$y->list,$z->list,$w->list) == 203, "whichND" ); $a1 = pdl(1,2,3,4); my $b1 = append($a1,2); ok(int(sum($b1))==12, "append"); $b1 = append(null, null); ok !$b1->isnull, 'append(null, null) returns non-null'; ok $b1->isempty, 'append(null, null) returns an empty'; append(null, null, $b1); ok !$b1->isnull, 'append(null, null, b1) sets non-null'; ok $b1->isempty, 'append(null, null, b1) sets an empty'; # clip tests ok(tapprox($im->hclip(5)->sum,83), "hclip" ); ok(tapprox($im->lclip(5)->sum,176), "lclip" ); ok(tapprox($im->clip(5,7)->sum,140), "clip" ); # with NaN badvalue $im = sequence(3); $im->badvalue(nan()); $im->badflag(1); $im->set(1, nan()); my $clipped = $im->lclip(0); is $clipped.'', '[0 BAD 2]', 'ISBAD() works when badvalue is NaN'; # indadd Test: $a1 = pdl( 1,2,3); my $ind = pdl( 1,4,6); my $sum = zeroes(10); indadd($a1,$ind, $sum); ok(tapprox($sum->sum,6), "indadd" ); #one2nd test $a1 = zeroes(3,4,5); my $indicies = pdl(0,1,4,6,23,58,59); ($x,$y,$z)=$a1->one2nd($indicies); ok(all( $x==pdl(0,1,1,0,2,1,2) ), "one2nd x"); ok(all( $y==pdl(0,0,1,2,3,3,3) ), "one2nd y"); ok(all( $z==pdl(0,0,0,0,1,4,4) ), "one2nd z"); { my $yvalues = (new PDL( 0..5)) - 20; my $xvalues = -(new PDL (0..5))*.5; my $x = new PDL(-2); is( $x->interpol($xvalues,$yvalues), -16 ); } # Some of these tests are based upon those in Chapter 5 of Programming # Pearls, by J. Bentley { # choose a non-factor of two odd number for the length my $N = 723; my $ones = ones( $N ); my $idx = sequence( $N ); my $x = $idx * 10; # create ordered duplicates so can test insertion points. This creates # 7 sequential duplicates of the values 0-99 my $ndup = 7; my $xdup = double long sequence( $ndup * 100 ) / $ndup; # get insertion points and values my ( $xdup_idx_insert_left, $xdup_idx_insert_right, $xdup_values ) = do { my ( $counts, $values ) = do { my @q = $xdup->rle; where( @q, $q[0] > 0 ) }; ( $counts->cumusumover - $counts->at( 0 ), $counts->cumusumover, $values ); }; # The tests are table driven, with appropriate inputs and outputs for # forward and reverse sorted arrays. The tests sort the input array # against itself, so we have a very good idea of which indices should # be returned. Most of the tests use that. There are also specific # tests for the endpoints as specified in the documentation, which # may be easier for humans to parse and validate. my %search = ( sample => { all_the_same_element => $N - 1, # finds right-most element forward => { idx => $idx, x => $x, equal => $idx, nequal_m => $idx, nequal_p => do { my $t = $idx + 1; $t->set( -1, $t->at( -1 ) - 1 ); $t }, xdup => { set => $xdup, idx => $xdup_idx_insert_left, values => $xdup_values, }, docs => [ ' V <= xs[0] : i = 0 ' => [ ( 0, -1, 0 ), ( 0, 0, 0 ), ], 'xs[0] < V <= xs[-1] : i s.t. xs[i-1] < V <= xs[i]' => [ ( 0, 1, 1 ), ( 1, 0, 1 ), ( -1, 0, $N-1 ), ], 'xs[-1] < V : i = $xs->nelem -1 ' => [ ( -1, 0, $N-1 ), ( -1, 1, $N-1 ), ], ], }, reverse => { idx => $idx, x => $x->mslice( [ -1, 0 ] ), equal => $idx, nequal_m => $idx, nequal_p => do { my $t = $idx - 1; $t->set( 0, 0 ); $t }, xdup => { set => $xdup->slice( [ -1, 0 ] ), idx => $xdup->nelem - 1 - $xdup_idx_insert_left, values => $xdup_values, }, docs => [ ' V > xs[0] : i = 0 ' => [(0, 1, 0) ], 'xs[0] >= V > xs[-1] : i s.t. xs[i] >= V > xs[i+1]' => [(0, 0, 0), (0, -1, 0), (1, 0, 1), ], 'xs[-1] >= V : i = $xs->nelem - 1 ' => [(-1, 0, $N-1), (-1, -1, $N-1), ], ], } }, insert_leftmost => { all_the_same_element => 0, forward => { idx => $idx, x => $x, equal => $idx, nequal_m => $idx, nequal_p => $idx + 1, xdup => { set => $xdup, idx => $xdup_idx_insert_left, values => $xdup_values, }, docs => [ ' V <= xs[0] : i = 0 ' => [ ( 0, -1, 0 ), ( 0, 0, 0) ], 'xs[0] < V <= xs[-1] : i s.t. xs[i-1] < V <= xs[i]' => [ ( 0, 1, 1 ), ( 1, 0, 1 ), ( -1, 0, $N-1 ), ], 'xs[-1] < V : i = $xs->nelem ' => [ ( -1, 1, $N ), ], ], }, reverse => { idx => $idx, x => $x->mslice( [ -1, 0 ] ), equal => $idx, nequal_m => $idx, nequal_p => $idx - 1, xdup => { set => $xdup->mslice( [ -1, 0 ] ), idx => $xdup->nelem - 1 - $xdup_idx_insert_left, values => $xdup_values, }, docs => [ ' V > xs[0] : i = -1 ' => [ ( 0, 1, -1 ), ], 'xs[0] >= V >= xs[-1] : i s.t. xs[i] >= V > xs[i+1]' => [ ( 0, 0, 0 ), ( 0, -1, 0 ), ], 'xs[-1] >= V : i = $xs->nelem -1 ' => [ ( -1, 0, $N-1 ), ( -1, -1, $N-1 ), ], ], }, }, insert_rightmost => { all_the_same_element => $N, forward => { idx => $idx, x => $x, equal => $idx + 1, nequal_m => $idx, nequal_p => $idx + 1, xdup => { set => $xdup, idx => $xdup_idx_insert_right, values => $xdup_values, idx_offset => -1, # returns index of element *after* the value }, docs => [ ' V < xs[0] : i = 0 ' => [ ( 0, -1, 0 ) ], 'xs[0] <= V < xs[-1] : i s.t. xs[i-1] <= V < xs[i]' => [ ( 0, 0, 1 ), ( 0, 1, 1 ), ( 1, 0, 2 ), ], 'xs[-1] <= V : i = $xs->nelem ' => [ ( -1, 0, $N ), ( -1, 1, $N ), ], ], }, reverse => { idx => $idx, x => $x->mslice( [ -1, 0 ] ), equal => $idx - 1, nequal_m => $idx, nequal_p => $idx - 1, xdup => { set => $xdup->mslice( [ -1, 0 ] ), idx => $xdup->nelem - 1 - $xdup_idx_insert_right, values => $xdup_values, idx_offset => +1, # returns index of element *after* the value }, docs => [ ' V >= xs[0] : i = -1 ' => [ ( 0, 1, -1 ), ( 0, 0, -1 ), ], 'xs[0] > V >= xs[-1] : i s.t. xs[i] >= V > xs[i+1]' => [ ( 0, -1, 0 ), ( -1, 1, $N-2 ), ( -1, 0, $N-2 ), ], 'xs[-1] > V : i = $xs->nelem -1 ' => [ ( -1, -1, $N-1 ) ] ], }, }, match => { all_the_same_element => ( $N ) >> 1, forward => { idx => $idx, x => $x, equal => $idx, nequal_m => -( $idx + 1 ), nequal_p => -( $idx + 1 + 1 ), xdup => { set => $xdup, values => $xdup_values, }, docs => [ 'V < xs[0] : i = -1' => [ ( 0, -1, -1 ), ], 'V == xs[n] : i = n' => [ ( 0, 0, 0 ), ( -1, 0, $N-1 ) ], 'xs[0] > V > xs[-1], V != xs[n] : -(i+1) s.t. xs[i] > V > xs[i+1]' => [ ( 0, 1, -( 1 + 1) ), ( 1, -1, -( 1 + 1 ) ), ( 1, 1, -( 2 + 1 ) ), ( -1, -1, -( $N - 1 + 1 ) ), ], ' V > xs[-1] : -($xs->nelem - 1 + 1)' => [ ( -1, 1, -( $N + 1) ), ] ], }, reverse => { idx => $idx, x => $x->mslice( [ -1, 0 ] ), equal => $idx, nequal_m => -( $idx + 1 ), nequal_p => -( $idx + 1 - 1 ), xdup => { set => $xdup->mslice( [ -1, 0 ] ), values => $xdup_values, }, docs => [ 'V > xs[0] : i = 0' => [ ( 0, 1, 0 ), ], 'V == xs[n] : i = n' => [ ( 0, 0, 0 ), ( -1, 0, $N-1 ) ], 'xs[0] < V < xs[-1], V != xs[n] : -(i+1) s.t. xs[i-1] > V > xs[i]' => [ ( 0, -1, -( 0 + 1) ), ( 1, 1, -( 0 + 1 ) ), ( 1, -1, -( 1 + 1 ) ), ( -1, -1, -( $N - 1 + 1 ) ), ], ' xs[-1] > V: -($xs->nelem - 1 + 1)' => [ ( -1, -1, -( $N - 1 + 1) ), ] ], }, }, bin_inclusive => { all_the_same_element => $N - 1, forward => { idx => $idx, x => $x, equal => $idx, nequal_m => $idx - 1, nequal_p => $idx, xdup => { set => $xdup, idx => $xdup_idx_insert_left + $ndup - 1, values => $xdup_values, }, docs => [ ' V < xs[0] : i = -1 ' => [ ( 0, -1, -1 ), ], 'xs[0] <= V < xs[-1] : i s.t. xs[i] <= V < xs[i+1]' => [ ( 0, 0, 0 ), ( 0, 1, 0 ), ( 1, -1, 0 ), ( 1, 0, 1 ), ( -1, -1, $N-2 ), ], 'xs[-1] <= V : i = $xs->nelem - 1 ' => [ ( -1, 0, $N-1 ), ( -1, 1, $N-1 ), ] ], }, reverse => { idx => $idx, x => $x->mslice( [ -1, 0 ] ), equal => $idx, nequal_m => $idx + 1, nequal_p => $idx, xdup => { set => $xdup->mslice( [ -1, 0 ] ), idx => $xdup->nelem - ( 1 + $xdup_idx_insert_left + $ndup - 1 ), values => $xdup_values, }, docs => [ ' V >= xs[0] : i = 0 ' => [ (0, 1, 0 ), (0, 0, 0 ) ], 'xs[0] > V >= xs[-1] : i s.t. xs[i+1] > V >= xs[i]' => [ ( 0, -1, 1 ), ( 1, 1, 1 ), ( 1, 0, 1 ), ( 1, -1, 2 ), ( -1, 0, $N-1 ), ], 'xs[-1] > V : i = $xs->nelem -1 ' => [ ( -1, -1, $N ) ], ], }, }, bin_exclusive => { all_the_same_element => -1, forward => { idx => $idx, x => $x, equal => $idx - 1, nequal_m => $idx - 1, nequal_p => $idx, xdup => { set => $xdup, idx => $xdup_idx_insert_left - 1, values => $xdup_values, idx_offset => 1, }, docs => [ ' V <= xs[0] : i = -1 ' => [ ( 0, -1, -1 ), ( 0, 0, -1 ), ], 'xs[0] < V <= xs[-1] : i s.t. xs[i] < V <= xs[i+1]' => [ ( 0, 1, 0 ), ( 1, -1, 0 ), ( 1, 0, 0 ), ( 1, 1, 1 ), ( -1, -1, $N-2 ), ( -1, 0, $N-2 ), ], 'xs[-1] < V : i = $xs->nelem - 1 ' => [ ( -1, 1, $N-1 ), ], ], }, reverse => { idx => $idx, x => $x->mslice( [ -1, 0 ] ), equal => $idx + 1, nequal_m => $idx + 1, nequal_p => $idx, xdup => { set => $xdup->mslice( [ -1, 0 ] ), idx => $xdup->nelem - ( 1 + $xdup_idx_insert_left - 1 ), values => $xdup_values, idx_offset => -1, }, docs => [ ' V > xs[0] : i = 0 ' => [ ( 0, 1, 0 ), ], 'xs[0] > V > xs[-1] : i s.t. xs[i-1] >= V > xs[i]' => [ ( 0, 0, 1 ), ( 0, -1, 1 ), ( -1, 1, $N-1 ), ], 'xs[-1] >= V : i = $xs->nelem -1 ' => [ ( -1, 0, $N ), ( -1, -1, $N ), ], ], }, }, ); for my $mode ( sort keys %search ) { my $data = $search{$mode}; subtest $mode => sub { my ( $got, $exp ); for my $sort_direction ( qw[ forward reverse ] ) { subtest $sort_direction => sub { my $so = $data->{$sort_direction} or plan( skip_all => "not testing $sort_direction!\n" ); ok( all( ( $got = vsearch( $so->{x}, $so->{x}, { mode => $mode } ) ) == ( $exp = $so->{equal} ) ), 'equal elements' ) or diag "got : $got\nexpected: $exp\n"; ok( all( ( $got = vsearch( $so->{x} - 5, $so->{x}, { mode => $mode } ) ) == ( $exp = $so->{nequal_m} ) ), 'non-equal elements x[i] < xs[i] (check lower bound)' ) or diag "got : $got\nexpected: $exp\n"; ok( all( ( $got = vsearch( $so->{x} + 5, $so->{x}, { mode => $mode } ) ) == ( $exp = $so->{nequal_p} ) ), 'non-equal elements x[i] > xs[i] (check upper bound)' ) or diag "got : $got\nexpected: $exp\n"; # duplicate testing. # check for values. note that the rightmost routine returns # the index of the element *after* the last duplicate # value, so we need an offset ok( all( ( $got = $so->{xdup}{set}->index( vsearch( $so->{xdup}{values}, $so->{xdup}{set}, { mode => $mode } ) + ($so->{xdup}{idx_offset} || 0) ) ) == ( $exp = $so->{xdup}{values} ) ), 'duplicates values' ) or diag "got : $got\nexpected: $exp\n"; # if there are guarantees about which duplicates are returned, test it if ( exists $so->{xdup}{idx} ) { ok( all( ( $got = vsearch( $so->{xdup}{values}, $so->{xdup}{set}, { mode => $mode } ) ) == ( $exp = $so->{xdup}{idx} ) ), 'duplicate indices' ) or diag "got : $got\nexpected: $exp\n"; } if ( exists $so->{docs} ) { while( my ($label, $inputs ) = splice( @{$so->{docs}}, 0, 2 ) ) { while( @$inputs ) { my ( $idx, $offset, $exp ) = splice( @$inputs, 0, 3 ); my $value = $so->{x}->at($idx) + $offset; is ( $got = ( vsearch( $value, $so->{x}, { mode => $mode } )->sclr), $exp, "$label: ($idx, $offset)" ); } } } }; } ok( all( ( $got = vsearch( $ones, $ones, { mode => $mode } ) ) == ( $exp = $data->{all_the_same_element} ) ), 'all the same element' ) or diag "got : $got\nexpected: $exp\n"; }; } # test vsearch API to ensure backwards compatibility { my $vals = random( 100 ); my $xs = sequence(100) / 99; # implicit output ndarray my $indx0 = vsearch( $vals, $xs ); my $ret = vsearch( $vals, $xs, my $indx1 = PDL->null() ); is( $ret, undef, "no return from explicit output ndarray" ); ok ( all ( $indx0 == $indx1 ), 'explicit ndarray == implicit ndarray' ); } } done_testing; PDL-2.074/t/core.t0000644000175000017500000004172414176366061013475 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::LiteF; use Config; use PDL::Types; use Math::Complex (); sub tapprox ($$) { my ( $x, $y ) = @_; my $d = abs( $x - $y ); return $d <= 0.0001; } for my $type (PDL::Types::types()) { ok defined pdl($type, 0), "constructing PDL of type $type"; } my $a_long = sequence long, 10; my $a_dbl = sequence 10; my $b_long = $a_long->slice('5'); my $b_dbl = $a_dbl->slice('5'); my $c_long = $a_long->slice('4:7'); my $c_dbl = $a_dbl->slice('4:7'); # test 'sclr' method # is $b_long->sclr, 5, "sclr test of 1-elem pdl (long)"; ok tapprox( $b_dbl->sclr, 5 ), "sclr test of 1-elem pdl (dbl)"; eval { $c_long->sclr }; like $@, qr/multielement ndarray in 'sclr' call/, "sclr failed on multi-element ndarray (long)"; eval { $c_dbl->sclr }; like $@, qr/multielement ndarray in 'sclr' call/, "sclr failed on multi-element ndarray (dbl)"; # test reshape barfing with negative args # eval 'my $d_long = $a_long->reshape(0,-3);'; like $@, qr/invalid dim size/, "reshape() failed with negative args (long)"; eval 'my $d_dbl = $a_dbl->reshape(0,-3);'; like $@, qr/invalid dim size/, "reshape() failed with negative args (dbl)"; # test reshape with no args my ( $x, $y, $c ); $x = ones 3,1,4; $y = $x->reshape; ok eq_array( [ $y->dims ], [3,4] ), "reshape()"; # test reshape(-1) and squeeze $x = ones 3,1,4; $y = $x->reshape(-1); $c = $x->squeeze; ok eq_array( [ $y->dims ], [3,4] ), "reshape(-1)"; ok all( $y == $c ), "squeeze"; $c++; # check dataflow in reshaped PDL ok all( $y == $c ), "dataflow"; # should flow back to y ok all( $x == 2 ), "dataflow"; our $d = pdl(5); # zero dim ndarray and reshape/squeeze ok $d->reshape(-1)->ndims==0, "reshape(-1) on 0-dim PDL gives 0-dim PDL"; ok $d->reshape(1)->ndims==1, "reshape(1) on 0-dim PDL gives 1-dim PDL"; ok $d->reshape(1)->reshape(-1)->ndims==0, "reshape(-1) on 1-dim, 1-element PDL gives 0-dim PDL"; # reshape test related to bug SF#398 "$pdl->hdr items are lost after $pdl->reshape" $c = ones(25); $c->hdr->{demo} = "yes"; is($c->hdr->{demo}, "yes", "hdr before reshape"); $c->reshape(5,5); is($c->hdr->{demo}, "yes", "hdr after reshape"); # test topdl isa_ok( PDL->topdl(1), "PDL", "topdl(1) returns an ndarray" ); isa_ok( PDL->topdl([1,2,3]), "PDL", "topdl([1,2,3]) returns an ndarray" ); isa_ok( PDL->topdl(1,2,3), "PDL", "topdl(1,2,3) returns an ndarray" ); $x=PDL->topdl(1,2,3); ok (($x->nelem == 3 and all($x == pdl(1,2,3))), "topdl(1,2,3) returns a 3-ndarray containing (1,2,3)"); # test $PDL::undefval support in pdl (bug #886263) # is $PDL::undefval, 0, "default value of \$PDL::undefval is 0"; $x = [ [ 2, undef ], [3, 4 ] ]; $y = pdl( $x ); $c = pdl( [ 2, 0, 3, 4 ] )->reshape(2,2); ok all( $y == $c ), "undef converted to 0 (dbl)"; ok eq_array( $x, [[2,undef],[3,4]] ), "pdl() has not changed input array"; $y = pdl( long, $x ); $c = pdl( long, [ 2, 0, 3, 4 ] )->reshape(2,2); ok all( $y == $c ), "undef converted to 0 (long)"; do { local($PDL::undefval) = -999; $x = [ [ 2, undef ], [3, 4 ] ]; $y = pdl( $x ); $c = pdl( [ 2, -999, 3, 4 ] )->reshape(2,2); ok all( $y == $c ), "undef converted to -999 (dbl)"; $y = pdl( long, $x ); $c = pdl( long, [ 2, -999, 3, 4 ] )->reshape(2,2); ok all( $y == $c ), "undef converted to -999 (long)"; } while(0); ############## # Funky constructor cases # pdl of a pdl $x = pdl(pdl(5)); ok all( $x== pdl(5)), "pdl() can piddlify an ndarray"; $x = pdl(null); is_deeply [$x->dims], [0], 'pdl(null) gives empty' or diag "x(", $x->info, ")"; ok !$x->isnull, 'pdl(null) gives non-null' or diag "x(", $x->info, ")"; $x = pdl(null, null); is_deeply [$x->dims], [0,2], 'pdl(null, null) gives empty' or diag "x(", $x->info, ")"; ok !$x->isnull, 'pdl(null, null) gives non-null' or diag "x(", $x->info, ")"; # pdl of mixed-dim pdls: pad within a dimension $x = pdl( zeroes(5), ones(3) ); ok all($x == pdl([0,0,0,0,0],[1,1,1,0,0])),"Piddlifying two ndarrays concatenates them and pads to length" or diag("x=$x\n"); # pdl of mixed-dim pdls: pad a whole dimension $x = pdl( [[9,9],[8,8]], xvals(3)+1 ); ok all($x == pdl([[[9,9],[8,8],[0,0]] , [[1,0],[2,0],[3,0]] ])),"can concatenate mixed-dim ndarrays" or diag("x=$x\n"); # pdl of mixed-dim pdls: a hairier case $c = pdl [1], pdl[2,3,4], pdl[5]; ok all($c == pdl([[[1,0,0],[0,0,0]],[[2,3,4],[5,0,0]]])),"Can concatenate mixed-dim ndarrays: hairy case" or diag("c=$c\n"); # same thing, with undefval set differently do { local($PDL::undefval) = 99; $c = pdl undef; ok all($c == pdl(99)), "explicit, undefval of 99 works" or diag("c=$c\n"); $c = pdl [1], pdl[2,3,4], pdl[5]; ok all($c == pdl([[[1,99,99],[99,99,99]],[[2,3,4],[5,99,99]]])), "implicit, undefval works for padding" or diag("c=$c\n"); $PDL::undefval = undef; $c = pdl undef; ok all($c == pdl(0)), "explicit, undefval of undef falls back to 0" or diag("c=$c\n"); $c = pdl [1], [2,3,4]; ok all($c == pdl([1,0,0],[2,3,4])), "implicit, undefval of undef falls back to 0" or diag("c=$c\n"); $PDL::undefval = inf; $c = pdl undef; ok all($c == inf), "explicit, undefval of PDL scalar works" or diag("c=$c\n"); $c = pdl [1], [2,3,4]; ok all($c == pdl([1,inf,inf],[2,3,4])), "implicit, undefval of a PDL scalar works" or diag("c=$c\n"); } while(0); # empty pdl cases eval {$x = zeroes(2,0,1);}; ok(!$@,"zeroes accepts empty PDL specification"); eval { $y = pdl($x,sequence(2,0,1)); }; ok((!$@ and all(pdl($y->dims) == pdl(2,0,1,2))), "concatenating two empties gives an empty"); eval { $y = pdl($x,sequence(2,1,1)); }; ok((!$@ and all(pdl($y->dims) == pdl(2,1,1,2))), "concatenating an empty and a nonempty treats the empty as a filler"); eval { $y = pdl($x,5) }; ok((!$@ and all(pdl($y->dims)==pdl(2,1,1,2))), "concatenating an empty and a scalar on the right works"); ok( all($y==pdl([[[0,0]]],[[[5,0]]])), "concatenating an empty and a scalar on the right gives the right answer"); eval { $y = pdl(5,$x) }; ok((!$@ and all(pdl($y->dims)==pdl(2,1,1,2))), "concatenating an empty and a scalar on the left works"); ok( all($y==pdl([[[5,0]]],[[[0,0]]])), "concatenating an empty and a scalar on the left gives the right answer"); # end # cat problems eval {cat(1, pdl(1,2,3), {}, 6)}; ok ($@ ne '', 'cat barfs on non-ndarray arguments'); like ($@, qr/Arguments 0, 2 and 3 are not ndarrays/, 'cat correctly identifies non-ndarray arguments'); $@ = ''; eval {cat(1, pdl(1,2,3))}; like($@, qr/Argument 0 is not an ndarray/, 'cat uses good grammar when discussing non-ndarrays'); $@ = ''; my $two_dim_array = cat(pdl(1,2), pdl(1,2)); eval {cat(pdl(1,2,3,4,5), $two_dim_array, pdl(1,2,3,4,5), pdl(1,2,3))}; ok ($@ ne '', 'cat barfs on mismatched ndarrays'); like($@, qr/The dimensions of arguments 1 and 3 do not match/ , 'cat identifies all ndarrays with differing dimensions'); like ($@, qr/\(argument 0\)/, 'cat identifies the first actual ndarray in the arg list'); $@ = ''; eval {cat(pdl(1,2,3), pdl(1,2))}; like($@, qr/The dimensions of argument 1 do not match/ , 'cat uses good grammar when discussing ndarray dimension mismatches'); $@ = ''; eval {cat(1, pdl(1,2,3), $two_dim_array, 4, {}, pdl(4,5,6), pdl(7))}; ok ($@ ne '', 'cat barfs combined screw-ups'); like($@, qr/Arguments 0, 3 and 4 are not ndarrays/ , 'cat properly identifies non-ndarrays in combined screw-ups'); like($@, qr/arguments 2 and 6 do not match/ , 'cat properly identifies ndarrays with mismatched dimensions in combined screw-ups'); like($@, qr/\(argument 1\)/, 'cat properly identifies the first actual ndarray in combined screw-ups'); $@ = ''; eval {$x = cat(pdl(1),pdl(2,3));}; ok(!$@, 'cat(pdl(1),pdl(2,3)) succeeds'); ok( ($x->ndims==2 and $x->dim(0)==2 and $x->dim(1)==2), 'weird cat case has the right shape'); ok( all( $x == pdl([1,1],[2,3]) ), "cat does the right thing with catting a 0-pdl and 2-pdl together"); $@=''; my $lo=sequence(long,5)+32766; my $so=sequence(short,5)+32766; my $fl=float(sequence(5)+0.2); # different as 0.2 is an NV so now a double my $by=sequence(byte,5)+253; my @list = ($lo,$so,$fl,$by); my $c2 = cat(@list); is($c2->type,'float','concatenating different datatypes returns the highest type'); ok(all($_==shift @list),"cat/dog symmetry for values") for $c2->dog; my ($dogcopy) = $c2->dog({Break=>1}); $dogcopy++; ok all($dogcopy != $c2->slice(':,(0)')), 'Break means copy'; # not lo as cat no flow my ($dogslice) = $c2->dog; $dogslice->dump; $lo->dump; $dogslice++; ok all($dogslice == $c2->slice(':,(0)')), 'no Break means dataflow' or diag "got=$dogslice\nexpected=$lo"; $x = sequence(byte,5); $x->inplace; ok($x->is_inplace,"original item inplace-d true inplace flag"); $y = $x->copy; ok($x->is_inplace,"original item true inplace flag after copy"); ok(!$y->is_inplace,"copy has false inplace flag"); $y++; ok(all($y!=sequence(byte,5)),"copy returns severed copy of the original thing if inplace is set"); ok($x->is_inplace,"original item still true inplace flag"); ok(!$y->is_inplace,"copy still false inplace flag"); ok(all($x==sequence(byte,5)),"copy really is severed"); # new_or_inplace $y = $x->new_or_inplace; ok( all($y==$x) && ($y->get_datatype == $x->get_datatype), "new_or_inplace with no pref returns something like the orig."); $y++; ok(all($y!=$x),"new_or_inplace with no inplace flag returns something disconnected from the orig."); $y = $x->new_or_inplace("float,long"); ok($y->type eq 'float',"new_or_inplace returns the first type in case of no match"); $y = $x->inplace->new_or_inplace; $y++; ok(all($y==$x),"new_or_inplace returns the original thing if inplace is set"); ok(!($y->is_inplace),"new_or_inplace clears the inplace flag"); # check reshape and dims. While we're at it, check null & empty creation too. my $empty = zeroes(0); ok($empty->nelem==0,"you can make an empty PDL with zeroes(0)"); ok("$empty" =~ m/Empty/, "an empty PDL prints 'Empty'"); my $null = null; is $null->info, 'PDL->null', "null ndarray's info is 'PDL->null'"; my $mt_info = $empty->info; $mt_info =~m/\[([\d,]+)\]/; my $mt_info_dims = pdl("$1"); ok(any($mt_info_dims==0), "empty ndarray's info contains a 0 dimension"); ok($null->isnull, "a null ndarray is null"); ok($null->isempty, "a null ndarray is empty") or diag $null->info; ok(!$empty->isnull, "an empty ndarray is not null"); ok($empty->isempty, "an empty ndarray is empty"); $x = short pdl(3,4,5,6); eval { $x->reshape(2,2);}; ok(!$@,"reshape succeeded in the normal case"); ok( ( $x->ndims==2 and $x->dim(0)==2 and $x->dim(1)==2 ), "reshape did the right thing"); ok(all($x == short pdl([[3,4],[5,6]])), "reshape moved the elements to the right place"); $y = $x->slice(":,:"); eval { $y->reshape(4); }; ok( $@ !~ m/Can\'t/, "reshape doesn't fail on a PDL with a parent" ); { my $pb = double ones(2,3); my $ind = 1; is(($pb->dims)[0], 2); is(($pb->dims)[1], 3); note $pb; is($pb->at(1,1), 1); is($pb->at(1,2), 1); } my $array = [ [[1,2], [3,4]], [[5,6], [7,8]], [[9,10], [11,12]] ]; my $pdl = pdl $array; is_deeply( unpdl($pdl), $array, "back convert 3d"); SKIP: { skip("your perl hasn't 64bit int support", 6) if $Config{ivsize} < 8; my $input = [ -9223372036854775808, #min int64 -9000000000000000001, -9000000000000000002, -9000000000000000003, -9000000000000000004, -9000000000000000005, -8999999999999999999, -8999999999999999998, -8999999999999999997, -8999999999999999996, -1000000000000000001, -2147483648, #min int32 2147483647, #max int32 4294967295, #max uint32 1000000000000000001, 9000000000000000001, 9000000000000000002, 9000000000000000003, 9000000000000000004, 9000000000000000005, 8999999999999999999, 8999999999999999998, 8999999999999999997, 8999999999999999996, 9223372036854775807, #max int64 ]; is_deeply(longlong($input)->unpdl, $input, 'back convert of 64bit integers'); my $small_pdl = longlong([ -9000000000000000001, 9000000000000000001 ]); is($small_pdl->at(0), -9000000000000000001, 'at/1'); is(PDL::Core::at_c($small_pdl, [1]), 9000000000000000001, 'at_c back-compat'); is(PDL::Core::at_bad_c($small_pdl, [1]), 9000000000000000001, 'at_bad_c/1'); $small_pdl->set(0, -8888888888888888888); PDL::Core::set_c($small_pdl, [1], 8888888888888888888); is($small_pdl->at(0), -8888888888888888888, 'at/2'); is(PDL::Core::at_bad_c($small_pdl, [1]), 8888888888888888888, 'at_bad_c/2'); is_deeply($small_pdl->unpdl, [ -8888888888888888888, 8888888888888888888 ], 'unpdl/small_pdl'); } my $big_ushort = ushort(65535); is $big_ushort->badflag, 0, 'max ushort value badflag'; is PDL::Core::at_bad_c($big_ushort, []), 65535, 'max ushort value not "BAD" per se'; { my $x = cdouble(2, 3); PDL::Core::set_c($x, [1], i); is $x.'', '[2 i]', 'set_c can take ndarray value'; } { my $x = cdouble(2, Math::Complex::i()); is $x.'', '[2 i]', 'type constructor can take Math::Complex value'; $x = pdl(Math::Complex::cplx(2, 0), Math::Complex::i()); is $x.'', '[2 i]', 'pdl defaults to cdouble if Math::Complex values'; $x = pdl([Math::Complex::cplx(2, 0), Math::Complex::i()]); is $x.'', '[2 i]', 'pdl defaults to cdouble if Math::Complex values in arrayref'; } sub hdr_test { local $Test::Builder::Level = $Test::Builder::Level + 1; my ($pb, $hdr, $method) = @_; $method ||= 'gethdr'; note "pb: ", explain my $pbh=$pb->$method; is_deeply($pbh,$hdr); } { my $pa = zeroes(20); $pa->hdrcpy(1); my $hdr = {Field1=>'arg1', Field2=>'arg2'}; $pa->sethdr($hdr); note "pa: ", explain $pa->gethdr(); ok($pa->hdrcpy); hdr_test($pa+1, $hdr); hdr_test(ones(20) + $pa, $hdr); hdr_test($pa->slice('0:5'), $hdr); hdr_test($pa->copy, $hdr); $pa->hdrcpy(0); hdr_test($pa->slice('3'), {}, 'hdr'); hdr_test($pa->slice('3'), undef); } { my $pa = pdl 42.4; note "A is $pa"; is($pa->get_datatype,$PDL_D, "A is double"); my $pb = byte $pa; note "B (byte $pa) is $pb"; is($pb->get_datatype,$PDL_B, "B is byte"); is($pb->at(),42, 'byte value is 42'); my $pc = $pb * 3; is($pc->get_datatype, $PDL_B, "C also byte"); note "C ($pb * 3) is $pc"; my $pd = $pb * 600.0; is($pd->get_datatype, $PDL_D, "pdl-ed NV is double, D promoted to double"); note "D ($pb * 600) is $pd"; my $pi = 4*atan2(1,1); my $pe = $pb * $pi; is($pe->get_datatype, $PDL_D, "E promoted to double (needed to represent result)"); note "E ($pb * PI) is $pe"; my $pf = $pb * "-2.2"; is($pf->get_datatype, $PDL_D, "F check string handling"); note "F ($pb * string(-2.2)) is $pf"; } { my @types = ( { typefunc => *byte , size => 1 }, { typefunc => *short , size => 2 }, { typefunc => *ushort, size => 2 }, { typefunc => *long , size => 4 }, { typefunc => *float , size => 4 }, { typefunc => *double, size => 8 }, ); for my $type (@types) { my $pdl = $type->{typefunc}(42); # build a PDL with datatype $type->{type} is( PDL::Core::howbig( $pdl->get_datatype ), $type->{size} ); } } for (['ones', 1], ['zeroes', 0], ['nan', 'NaN'], ['inf', 'Inf'], ['i', 'i', 'cdouble']) { my ($name, $val, $type) = @$_; no strict 'refs'; my $g = eval { $name->() }; is $@, '', "$name works with no args"; is_deeply [$g->dims], [], 'no args -> no dims'; ok !$g->isnull, 'no args -> not null'; ok !$g->isempty, 'no args -> not empty'; like $g.'', qr/^$val/i, "$name() gives back right value"; my $g1 = eval { $name->(2) }; is $@, '', "$name works with 1 args"; is_deeply [$g1->dims], [2], 'right dims'; # from PDL::Core docs of zeroes my (@dims, $w) = (1..3); $w = $name->(byte, @dims); is_deeply [$w->dims], \@dims; is $w->type, $type || 'byte'; $w = $name->(@dims); is_deeply [$w->dims], \@dims; is $w->type, $type || 'double'; $w = PDL->$name(byte, @dims); is_deeply [$w->dims], \@dims; is $w->type, $type || 'byte'; $w = PDL->$name(@dims); is_deeply [$w->dims], \@dims; is $w->type, $type || 'double'; my $pdl = ones(float, 4, 5); $w = $pdl->$name(byte, @dims); is_deeply [$w->dims], \@dims; is $w->type, $type || 'byte'; # usage type (ii): my $y = ones(@dims); $w = $name->($y); is_deeply [$w->dims], \@dims; $w = $y->$name; is_deeply [$w->dims], \@dims; next if $val =~ /\D/; $w = $y->copy; $name->(inplace $w); ok all tapprox $w, pdl($val) or diag "$name got:$w"; $w = $y->copy; $w->inplace->$name; ok all tapprox $w, pdl($val); } is short(1)->zeroes->type, 'short', '$existing->zeroes right type'; eval { PDL->is_inplace }; # shouldn't infinite-loop isnt $@, '', 'is_inplace as class method throws exception'; my $s = sequence(3); is $s->trans_parent, undef, 'trans_parent without trans undef'; my $slice = $s->slice; isnt +(my $tp=$slice->trans_parent), undef, 'trans_parent with trans defined'; is ${($s->trans_children)[0]}, $$tp, 'correct trans_children'; my @parents = $tp->parents; is ${$parents[0]}, $$s, 'correct parent ndarray'; my @children = $tp->children; is ${$children[0]}, $$slice, 'correct child ndarray'; my $notouch = sequence(4); $notouch->set_donttouchdata(4 * PDL::Core::howbig($notouch->get_datatype)); eval { $notouch->setdims([2,2]); $notouch->make_physical; }; is $@, '', 'setdims to same total size of set_donttouchdata should be fine'; eval { $notouch->setdims([3,2]); $notouch->make_physical; }; isnt $@, '', 'setdims/make_physical to different size of set_donttouchdata should fail'; done_testing; PDL-2.074/t/00-report-prereqs.t0000644000175000017500000001350614014062163015734 0ustar osboxesosboxes#!perl use strict; use warnings; # This test was generated by Dist::Zilla::Plugin::Test::ReportPrereqs 0.020 # THEN modified with more info by Ed J for PDL project use Test::More tests => 1; use ExtUtils::MakeMaker; use File::Spec; # from $version::LAX my $lax_version_re = qr/(?: undef | (?: (?:[0-9]+) (?: \. | (?:\.[0-9]+) (?:_[0-9]+)? )? | (?:\.[0-9]+) (?:_[0-9]+)? ) | (?: v (?:[0-9]+) (?: (?:\.[0-9]+)+ (?:_[0-9]+)? )? | (?:[0-9]+)? (?:\.[0-9]+){2,} (?:_[0-9]+)? ) )/x; # hide optional CPAN::Meta modules from prereq scanner # and check if they are available my $cpan_meta = "CPAN::Meta"; my $cpan_meta_pre = "CPAN::Meta::Prereqs"; my $HAS_CPAN_META = eval "require $cpan_meta; $cpan_meta->VERSION('2.120900')" && eval "require $cpan_meta_pre"; ## no critic # Verify requirements? my $DO_VERIFY_PREREQS = 1; sub _max { my $max = shift; $max = ( $_ > $max ) ? $_ : $max for @_; return $max; } sub _merge_prereqs { my ($collector, $prereqs) = @_; # CPAN::Meta::Prereqs object if (ref $collector eq $cpan_meta_pre) { return $collector->with_merged_prereqs( CPAN::Meta::Prereqs->new( $prereqs ) ); } # Raw hashrefs for my $phase ( keys %$prereqs ) { for my $type ( keys %{ $prereqs->{$phase} } ) { for my $module ( keys %{ $prereqs->{$phase}{$type} } ) { $collector->{$phase}{$type}{$module} = $prereqs->{$phase}{$type}{$module}; } } } return $collector; } my @include = qw( ); my @exclude = qw( ); # Add static prereqs to the included modules list my $static_prereqs = do 't/00-report-prereqs.dd'; # Merge all prereqs (either with ::Prereqs or a hashref) my $full_prereqs = _merge_prereqs( ( $HAS_CPAN_META ? $cpan_meta_pre->new : {} ), $static_prereqs ); # Add dynamic prereqs to the included modules list (if we can) my ($source) = grep { -f } 'MYMETA.json', 'MYMETA.yml'; if ( $source && $HAS_CPAN_META ) { if ( my $meta = eval { CPAN::Meta->load_file($source) } ) { $full_prereqs = _merge_prereqs($full_prereqs, $meta->prereqs); } } else { $source = 'static metadata'; } my @full_reports; my @dep_errors; my $req_hash = $HAS_CPAN_META ? $full_prereqs->as_string_hash : $full_prereqs; # Add static includes into a fake section for my $mod (@include) { $req_hash->{other}{modules}{$mod} = 0; } for my $phase ( qw(configure build test runtime develop other) ) { next unless $req_hash->{$phase}; next if ($phase eq 'develop' and not $ENV{AUTHOR_TESTING}); for my $type ( qw(requires recommends suggests conflicts modules) ) { next unless $req_hash->{$phase}{$type}; my $title = ucfirst($phase).' '.ucfirst($type); my @reports = [qw/Module Want Have Where Howbig/]; for my $mod ( sort keys %{ $req_hash->{$phase}{$type} } ) { next if $mod eq 'perl'; next if grep { $_ eq $mod } @exclude; my $file = $mod; $file =~ s{::}{/}g; $file .= ".pm"; my ($prefix) = grep { -e File::Spec->catfile($_, $file) } @INC; my $want = $req_hash->{$phase}{$type}{$mod}; $want = "undef" unless defined $want; $want = "any" if !$want && $want == 0; my $req_string = $want eq 'any' ? 'any version required' : "version '$want' required"; if ($prefix) { my $filename = File::Spec->catfile($prefix, $file); my $have = MM->parse_version( $filename ); $have = "undef" unless defined $have; push @reports, [$mod, $want, $have, $prefix, (-s $filename)]; if ( $DO_VERIFY_PREREQS && $HAS_CPAN_META && $type eq 'requires' ) { if ( $have !~ /\A$lax_version_re\z/ ) { push @dep_errors, "$mod version '$have' cannot be parsed ($req_string)"; } elsif ( ! $full_prereqs->requirements_for( $phase, $type )->accepts_module( $mod => $have ) ) { push @dep_errors, "$mod version '$have' is not in required range '$want'"; } } } else { push @reports, [$mod, $want, "missing", '', 0]; if ( $DO_VERIFY_PREREQS && $type eq 'requires' ) { push @dep_errors, "$mod is not installed ($req_string)"; } } } if ( @reports ) { push @full_reports, "=== $title ===\n\n"; my $ml = _max( map { length $_->[0] } @reports ); my $wl = _max( map { length $_->[1] } @reports ); my $hl = _max( map { length $_->[2] } @reports ); my $ll = _max( map { length $_->[3] } @reports ); # location my $sl = _max( map { length $_->[4] } @reports ); # size if ($type eq 'modules') { splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl, "-" x $ll, "-" x $sl]; push @full_reports, map { sprintf(" %*s %*s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports; } else { splice @reports, 1, 0, ["-" x $ml, "-" x $wl, "-" x $hl, "-" x $ll, "-" x $sl]; push @full_reports, map { sprintf(" %*s %*s %*s %*s %*s\n", -$ml, $_->[0], $wl, $_->[1], $hl, $_->[2], -$ll, $_->[3], $sl, $_->[4]) } @reports; } push @full_reports, "\n"; } } } if ( @full_reports ) { diag "\nVersions for all modules listed in $source (including optional ones):\n\n", @full_reports; } if ( @dep_errors ) { diag join("\n", "\n*** WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ***\n", "The following REQUIRED prerequisites were not satisfied:\n", @dep_errors, "\n" ); } pass; # vim: ts=4 sts=4 sw=4 et: PDL-2.074/t/bool.t0000644000175000017500000000113314146003631013452 0ustar osboxesosboxesuse Test::More tests => 5; use Test::Exception; use PDL::LiteF; use strict; use warnings; # PDL::Core::set_debugging(1); kill 'INT',$$ if $ENV{UNDER_DEBUGGER}; # Useful for debugging. { my $pa = zeroes 1,1,1; ok !$pa, 'single-element multi-dim ndarray collapses'; } { my $pa = ones 3; throws_ok { print "oops\n" if $pa } qr/multielement/, 'multielement ndarray in conditional expression'; ok all $pa, 'all elements true'; } { my $pa = pdl byte, [ 0, 0, 1 ]; ok any($pa > 0), 'any element true'; } { my $pa = ones 3; my $pb = $pa + 1e-4; ok all(PDL::approx($pa, $pb, 1e-3)), 'approx'; } PDL-2.074/t/ops.t0000644000175000017500000002136414177144657013352 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::LiteF; use Config; kill 'INT',$$ if $ENV{UNDER_DEBUGGER}; # Useful for debugging. use Test::Exception; require PDL::Core::Dev; kill 'INT',$$ if $ENV{UNDER_DEBUGGER}; # Useful for debugging. my $can_complex_power = PDL::Core::Dev::got_complex_version('pow', 2) && PDL::Core::Dev::got_complex_version('exp', 1); approx(pdl(0), pdl(0), 0.01); # set eps { my $pa = xvals zeroes 3,5; my $pb = yvals zeroes 3,5; my $pc = $pa + $pb; ok($pc->at(2,2) == 4, 'pdl addition 1'); ok($pc->at(2,3) == 5, 'pdl addition 2'); throws_ok { $pc->at(3,3); } qr/Position\s*\d+\s*out of range/, 'invalid position'; } { my $pd = pdl 5,6; my $pe = $pd - 1; ok($pe->at(0) == 4, 'pdl - scalar 1'); ok($pe->at(1) == 5, 'pdl - scalar 2'); my $pf = 1 - $pd; ok($pf->at(0) == -4, 'scalar - pdl 1'); ok($pf->at(1) == -5, 'scalar - pdl 2'); } # complex versions of above { my @w; local $SIG{__WARN__} = sub { push @w, @_ }; my $pa = xvals(cdouble, 3, 5)+10 - 2*xvals(3, 5)*i; my $pb = yvals(cdouble, 3, 5)+10 - 2*yvals(3, 5)*i; my $pc = $pa + $pb; ok(approx(cdouble(25 - 10*i) - cdouble(25 - 10*i), 0), 'pdl complex subtraction'); ok(approx($pc->double->at(2,2), 24), 'pdl complex addition 1'); is $pc->at(2,3), '25-10i', 'at stringifies complex'; ok(approx($pc->slice([2], [3]), cdouble(25 - 10*i)), 'pdl complex addition 2'); throws_ok { $pc->at(3,3); } qr/Position\s*\d+\s*out of range/, 'invalid position'; is_deeply \@w, [], 'no warnings' or diag explain \@w; } { my @w; local $SIG{__WARN__} = sub { push @w, @_ }; my $pd = cdouble 5,6; my $pe = $pd - 1; is($pe->at(0), '4', 'pdl - scalar 1'); is($pe->at(1), '5', 'pdl - scalar 2'); my $pf = 1 - $pd; my $got = $pf->at(0); is($got, '-4', 'scalar - pdl 1') or diag explain $got; is($pf->at(1), '-5', 'scalar - pdl 2'); is_deeply \@w, [], 'no warnings' or diag explain \@w; } # Now, test one operator from each group # biop1 tested already { my $pa = pdl 0,1,2; my $pb = pdl 1.5; my $pc = $pa > $pb; ok($pc->at(1) == 0, '0 not > 1.5'); ok($pc->at(2) == 1, '2 is > 1.5'); } { my $pa = byte pdl 0,1,3; my $pc = $pa << 2; ok($pc->at(0) == 0, '0 left bitshift 2 is 0'); ok($pc->at(1) == 4, '1 left bitshift 2 is 4'); ok($pc->at(2) == 12,'3 left bitshift 2 is 12'); } { my $pa = pdl 16,64,9; my $pb = sqrt($pa); ok(all( approx($pb,(pdl 4,8,3))),'sqrt of pdl(16,64,9)'); # See that a is unchanged. ok($pa->at(0) == 16, 'sqrt orig value ok'); # complex version $pa = cdouble pdl 16,64,9,-1; if ($can_complex_power) { $pb = sqrt($pa); my $got = i()**2; ok(approx($got, -1),'i squared = -1') or diag "got=$got"; ok(all( approx($pb,(cdouble 4,8,3,i()))),'sqrt of pdl(16,64,9,-1)'); } is $pa->at(0), '16', 'sqrt orig value ok'; } { my $pa = pdl 1,0; my $pb = ! $pa; ok($pb->at(0) == 0, 'elementwise not 1'); ok($pb->at(1) == 1, 'elementwise not 2'); } { my $pa = pdl 12,13,14,15,16,17; my $pb = $pa % 3; ok($pb->at(0) == 0, 'simple modulus 1'); ok($pb->at(1) == 1, 'simple modulus 2'); ok($pb->at(3) == 0, 'simple modulus 3'); # [ More modulus testing farther down! ] } { # Might as well test this also ok(all( approx((pdl 2,3),(pdl 2,3))),'approx equality 1'); ok(!all( approx((pdl 2,3),(pdl 2,4))),'approx equality 2'); } { # Simple function tests my $pa = pdl(2,3); ok(all( approx(exp($pa), pdl(7.3891,20.0855))), 'exponential'); ok(all( approx(sqrt($pa), pdl(1.4142, 1.7321))), 'sqrt makes decimal'); } { # And and Or ok(all( approx(pdl(1,0,1) & pdl(1,1,0), pdl(1,0,0))), 'elementwise and'); ok(all( approx(pdl(1,0,1) | pdl(1,1,0), pdl(1,1,1))), 'elementwise or'); } { # atan2 ok (all( approx(atan2(pdl(1,1), pdl(1,1)), ones(2) * atan2(1,1))), 'atan2'); } { my $pa = sequence (3,4); my $pb = sequence (3,4) + 1; ok (all( approx($pa->or2($pb), $pa | $pb)), 'or2'); ok (all( approx($pa->and2($pb), $pa & $pb)), 'and2'); ok (all( approx($pb->minus($pa), $pb - $pa)), 'explicit minus call'); ok (all( approx($pb - $pa, ones(3,4))), 'pdl subtraction'); } # inplace tests { my $pa = pdl 1; my $sq2 = sqrt 2; # perl sqrt $pa->inplace->plus(1); ok(all( approx($pa, pdl 2)), 'inplace plus'); my $warning_shutup = sqrt $pa->inplace; ok(all( approx( $pa, pdl($sq2))), 'inplace pdl sqrt vs perl scalar sqrt'); my $pb = pdl 4; ok(all( approx( 2, sqrt($pb->inplace))),'perl scalar vs inplace pdl sqrt'); } { # log10 now uses C library # check using scalars and ndarrays { my $pa = log10(110); my $pb = log(110) / log(10); note "a: $pa [ref(\$pa)='", ref($pa),"']\n"; note "b: $pb\n"; ok(abs($pa-$pb) < 1.0e-5, 'log10 scalar'); if ($can_complex_power) { $pa = 20+10*i; $pb = log($pa); my $got = exp($pb); ok(abs($got-$pa) < 1.0e-4,'exp of log of complex scalar') or diag "pb=$pb, got=$got, expected=$pa"; } my $y = sequence(5,4)+2; # Create PDL is log(float($y))->type, 'float'; } { my $pa = log10(pdl(110,23)); my $pb = log(pdl(110,23)) / log(10); note "a: $pa\n"; note "b: $pb\n"; ok(all( approx( $pa, $pb)), 'log10 pdl'); # check inplace ok(all( approx( pdl(110,23)->inplace->log10(), $pb)), 'inplace pdl log10'); if ($can_complex_power) { ok(all( approx( cdouble(110,23)->inplace->log()/log(10), $pb)), 'complex inplace pdl log10'); } } } { my $data = ones 5; $data &= 0; ok(all($data == 0), 'and assign'); $data |= 1; ok(all($data == 1), 'or assign'); ok(all($data eq $data), 'eq'); # check eq operator $data = ones cdouble, 5; $data+=i(); $data &= 0; ok(all($data == 0), 'and assign complex'); } if ($Config{ivsize} >= 8) { # else the IVs below are NVs which aren't exact # check ipow routine my $xdata = longlong(0xeb * ones(8)); my $n = sequence(longlong,8); is $n->type, 'longlong', 'sequence with specified type has that type'; my $exact = longlong(1,235,55225,12977875,3049800625,716703146875,168425239515625,39579931286171875); my $got = ipow($xdata,$n); ok(all($exact - $got == longlong(0)), 'ipow') or diag "got=$got\nexpected=$exact"; } #### Modulus checks #### { #test signed modulus on small numbers # short/long/indx/longlong/float/double neg/0/pos % neg/0/pos my $pa = pdl(-7..7); my $pb = pdl(-3,0,3)->transpose; my $pc = cat(pdl("-1 0 -2 " x 5),zeroes(15),pdl("2 0 1 " x 5)); ok all(short($pa) % short($pb) == short($pc)),'short modulus'; ok all(long($pa) % long($pb) == long($pc)), 'long modulus'; ok all(indx($pa) % indx($pb) == indx($pc)), 'indx modulus'; ok all(longlong($pa) % longlong($pb) == longlong($pc)), 'longlong modulus'; ok all(float($pa) % float($pb) == float($pc)), 'float modulus'; ok all(double($pa) % double($pb) == double($pc)), 'double modulus'; } { #test unsigned modulus # byte/ushort 0/pos % 0/pos my $pa = xvals(15); my $pb = pdl(0,3)->transpose; my $pc = cat(zeroes(15),pdl("0 1 2 " x 5)); ok all(byte($pa) % byte($pb)==byte($pc)), 'byte modulus'; ok all(ushort($pa) % ushort($pb)==ushort($pc)), 'ushort modulus'; } #and for big numbers (bigger than INT_MAX=2147483647) #basically this is exercising the (typecast)(X)/(N) in the macros my $INT_MAX = 2147483647; TODO: { local $TODO = undef; $TODO = 'Marking TODO for big modulus for 2.008 release'; diag "\$Config{ivsize} = $Config::Config{ivsize}"; diag "\$INT_MAX = $INT_MAX = @{[ sprintf '%x', $INT_MAX ]}"; cmp_ok long($INT_MAX)%1 , '==', 0, "big long modulus: $INT_MAX % 1"; cmp_ok indx($INT_MAX*4)%2 , '==', 0, "big indx modulus: @{[$INT_MAX*4]} % 2"; cmp_ok longlong($INT_MAX*4)%2, '==', 0, "big longlong modulus: @{[$INT_MAX*4]} % 2"; #skip float intentionally here, since float($INT_MAX)!=$INT_MAX cmp_ok double($INT_MAX*4)%2 , '==', 0, "big double modulus: @{[$INT_MAX*4]} % 2"; } { #and do the same for byte (unsigned char) and ushort my $BYTE_MAX = 255; my $USHORT_MAX = 65535; ok byte($BYTE_MAX)%1 == 0, 'big byte modulus'; ok ushort($USHORT_MAX)%1 == 0, 'big ushort modulus'; } SKIP: { skip("your perl hasn't 64bit int support", 6) if $Config{ivsize} < 8; # SF bug #343 longlong constructor and display lose digits due to implicit double precision conversions cmp_ok longlong(10555000100001145) - longlong(10555000100001144), '==', 1, "longlong precision/1"; cmp_ok longlong(9000000000000000002) - longlong(9000000000000000001), '==', 1, "longlong precision/2"; cmp_ok longlong(-8999999999999999998) + longlong(8999999999999999999), '==', 1, "longlong precision/3"; cmp_ok longlong(1000000000000000001) - longlong(1000000000000000000), '==', 1, "longlong precision/4"; cmp_ok longlong(9223372036854775807) - longlong(9223372036854775806), '==', 1, "longlong precision/5"; cmp_ok longlong(9223372036854775807) + longlong(-9223372036854775808), '==',-1, "longlong precision/6"; } is(~pdl(1,2,3) ."", '[-2 -3 -4]', 'bitwise negation'); is((pdl(1,2,3) ^ pdl(4,5,6))."", '[5 7 5]' , 'bitwise xor' ); # Check badflag propagation with .= (Ops::assgn) sf.net bug 3543056 $a = sequence(10); $b = sequence(5); $b->inplace->setvaltobad(3); $a->slice('0:4') .= $b; $a->badflag(1); $a->check_badflag(); ok($a->badflag == 1 && $a->nbad == 1, 'badflag propagation with .='); done_testing; PDL-2.074/t/constructor.t0000644000175000017500000001625014165321571015121 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::LiteF; use Test::Exception; my $scalar = 1; my $pdl_e = pdl([]); my $pdl_s = pdl(2); my $pdl_v = pdl(3,4); my $pdl_vec2 = pdl([9,10]); my $pdl_m = pdl([5,6],[7,8]); my $pdl_row = pdl([[10,11]]); my $pdl_col = pdl([[12],[13]]); ############################## # Test the basics (21 tests) isa_ok($pdl_s, 'PDL'); is $pdl_s->ndims(), 0, "scalar goes to scalar PDL"; is $pdl_s, 2, "PDL gets assigned scalar value"; is $pdl_v->ndims(), 1, "vector dims"; is $pdl_v->dim(0), 2, "vector size is 2"; is !!($pdl_v->at(0)==3 && $pdl_v->at(1)==4), 1, "vector contents"; is $pdl_vec2->ndims(), 1, "vector2 dims"; is $pdl_vec2->dim(0),2, "vector2 size is 2"; is !!($pdl_vec2->at(0)==9 && $pdl_vec2->at(1)==10), 1, "vector2 contents"; is $pdl_m->ndims(), 2, "matrix dims"; is $pdl_m->dim(0), 2, "matrix is 2 wide"; is $pdl_m->dim(1), 2, "matrix is 2 high"; is !!($pdl_m->at(0,0)==5 && $pdl_m->at(1,0)==6 && $pdl_m->at(0,1)==7 && $pdl_m->at(1,1)==8), 1, "matrix contents"; is $pdl_row->ndims(), 2, "row dims"; is $pdl_row->dim(0), 2, "row is 2 wide"; is $pdl_row->dim(1), 1, "row is 1 tall"; is !!($pdl_row->at(0,0)==10 && $pdl_row->at(1,0)==11), 1, "row contents"; is $pdl_col->ndims(), 2, "col dims"; is $pdl_col->dim(0), 1, "col is 1 wide"; is $pdl_col->dim(1), 2, "col is 2 tall"; is !!($pdl_col->at(0,0)==12 && $pdl_col->at(0,1)==13), 1, "col contents"; ############################## # Test more complex array-ingestion case (6 tests) with padding my @a = (1,[2,3],[[4,5],[6,7]]); my $pdl_a = pdl(@a); my @testvals = ( [ [0,0,0], 1 ], [ [1,0,0], 0 ], [ [0,1,0], 0 ], [ [1,1,0], 0 ], [ [0,0,1], 2 ], [ [1,0,1], 0 ], [ [0,1,1], 3 ], [ [1,1,1], 0 ], [ [0,0,2], 4 ], [ [1,0,2], 5 ], [ [0,1,2], 6 ], [ [1,1,2], 7 ] ); is $pdl_a->ndims(), 3, 'complex array case dims'; is $pdl_a->dim(0), 2, 'complex dim 0'; is $pdl_a->dim(1), 2, 'complex dim 1'; is $pdl_a->dim(2), 3, 'complex dim 2'; my $test_ok = 1; for my $i(0..$#testvals) { $test_ok *= $pdl_a->at( @{$testvals[$i]->[0]} ) == $testvals[$i]->[1]; } is $test_ok, 1, "contents of complex array-ingestion case"; { local $PDL::undefval = 99; $pdl_a = pdl(@a); $test_ok = 1; for my $i(0..$#testvals) { $test_ok *= $pdl_a->at( @{$testvals[$i]->[0]} ) == ($testvals[$i]->[1] || 99); } is $test_ok, 1, "complex array-ingestion with variant padding"; } ############################## # Test some basic PDL-as-PDL cases ## Ingest a scalar PDL my $p = pdl($pdl_s); isa_ok($p, 'PDL'); is $p->ndims(), 0, "scalar PDL goes to scalar PDL"; is $p, $pdl_s, "pdl(pdl(2)) same as pdl(2)"; ## Ingest five scalar PDLs -- should make a 1-D array $p = pdl($pdl_s, $pdl_s, $pdl_s, $pdl_s, $pdl_s); isa_ok($p, 'PDL'); is $p->ndims(), 1, "two scalar PDLs -> a vector"; is $p->dim(0), 5, "5-vector"; is $p->at(0), $pdl_s, 'vector element 0 ok'; is $p->at(1), $pdl_s, 'vector element 1 ok'; is $p->at(2), $pdl_s, 'vector element 2 ok'; is $p->at(3), $pdl_s, 'vector element 3 ok'; is $p->at(4), $pdl_s, 'vector element 4 ok'; ## Ingest a vector PDL and a scalar PDL - should make a 2-D array $p = pdl($pdl_v, $pdl_s); isa_ok($p, 'PDL'); is $p->ndims(), 2, 'pdl($pdl_v, $pdl_s) -> 2x2 matrix'; is $p->dim(0), 2, '2 wide'; is $p->dim(1), 2, '2 high'; is $p->at(0,0), $pdl_v->at(0), "vector element 0 got copied OK"; is $p->at(1,0), $pdl_v->at(1), "vector element 1 got copied OK"; is $p->at(0,1), $pdl_s, "scalar copied OK"; is $p->at(1,1), $PDL::undefval, "scalar got padded OK"; ## Ingest a scalar PDL and a vector PDL - should make a 2-D array $p = pdl($pdl_s, $pdl_v); isa_ok($p, 'PDL'); is $p->ndims(), 2, 'pdl($pdl_s, $pdl_v) -> 2x2 matrix'; is $p->dim(0), 2, '2 wide'; is $p->dim(1), 2, '2 high'; is $p->at(0,0), $pdl_s, "scalar copied OK"; is $p->at(1,0), $PDL::undefval, "scalar got padded OK"; is $p->at(0,1), $pdl_v->at(0), "vector element 0 got copied OK"; is $p->at(1,1), $pdl_v->at(1), "vector element 1 got copied OK"; ## A more complicated case $p = pdl($pdl_s, 5, $pdl_v, $pdl_m, [$pdl_v, $pdl_v]); isa_ok($p,'PDL'); is $p->ndims(), 3, 'complicated case -> 3-d PDL'; is $p->dim(0), 2, 'complicated case -> dim 0 is 2'; is $p->dim(1), 2, 'complicated case -> dim 1 is 2'; is $p->dim(2), 5, 'complicated case -> dim 1 is 5'; @testvals = ([ [0,0,0], 2 ], [ [1,0,0], 0 ], [ [0,1,0], 0 ], [ [1,1,0], 0 ], [ [0,0,1], 5 ], [ [1,0,1], 0 ], [ [0,1,1], 0 ], [ [1,1,1], 0 ], [ [0,0,2], 3 ], [ [1,0,2], 0 ], [ [0,1,2], 4 ], [ [1,1,2], 0 ], [ [0,0,3], 5 ], [ [1,0,3], 6 ], [ [0,1,3], 7 ], [ [1,1,3], 8 ], [ [0,0,4], 3 ], [ [1,0,4], 4 ], [ [0,1,4], 3 ], [ [1,1,4], 4 ] ); $test_ok = 1; for my $i(0..$#testvals) { $test_ok *= $p->at(@{$testvals[$i]->[0]}) == $testvals[$i]->[1]; } is $test_ok, 1, "contents of complicated case"; ############################## # test empty PDLs. $p = pdl($pdl_e); is $p->nelem, 0, "piddlifying an empty ndarray yields 0 elements"; $p = pdl($pdl_e, $pdl_e); is $p->ndims, 2, "piddlifying two 0-PDLs makes a 2D-PDL"; is $p->dim(0),0, "piddlifying two empty ndarrays makes a 0x2-PDL"; is $p->dim(1),2, "piddlifying two empty ndarrays makes a 0x2-PDL"; eval { $p->at(0,0) }; like $@, qr/^Position\s*\d+\s*out of range/, "can't index an empty PDL with at"; $p = pdl(pdl([4]),5); is $p->ndims, 2, "catenating a 1-PDL and a scalar yields a 2D PDL"; is $p->dim(0), 1, "catenating a 1-PDL and a scalar yields a 1x2-PDL"; is $p->dim(1), 2, "catenating a 1-PDL and a scalar yields a 1x2-PDL"; is $p->at(0,0), 4, "catenating a 1-PDL and a scalar does the Right Thing"; is $p->at(0,1), 5, "catenating a 1-PDL and a scalar does the Right Thing, redux"; $p = pdl($pdl_e, 5); is $p->ndims, 2, "catenating an empty and a scalar yields a 2D PDL"; is $p->dim(0), 1, "catenating an empty and a scalar yields a 1x2-PDL"; is $p->dim(1), 2, "catenating an empty and a scalar yields a 1x2-PDL"; is $p->at(0,0), $PDL::undefval, "padding OK for empty & scalar case"; is $p->at(0,1), 5, "scalar OK for empty & scalar"; $p = pdl(5, $pdl_e); is $p->ndims, 2, "catenating a scalar and an empty yields a 2D PDL"; is $p->dim(0), 1, "catenating a scalar and an empty yields a 1x2-PDL"; is $p->dim(1), 2, "catenating a scalar and an empty yields a 1x2-PDL"; is $p->at(0,0), 5, "scalar OK for scalar & empty"; is $p->at(0,1), $PDL::undefval, "padding OK for scalar & empty"; # This is from sf.net bug #3011879 my @c; $c[0][0]=pdl(0,4,2,1); $c[1][0]=pdl(0,0,1,1); $c[2][0]=pdl(0,0,0,1); $c[0][1]=pdl(0,0,3,1); $c[1][1]=pdl(0,0,2,1); $c[2][1]=pdl(5,1,1,1); my $d = pdl(@c); ############################## # test bad values my $x = pdl(3,4,5); $x=$x->setbadif($x==4); my $y = eval { pdl($x,5) }; is $@, '', "a badvalue PDL works in the constructor"; ok( $y->badflag, "bad value propagates from inner PDL to constructed PDL" ); ok( $y->slice("(1),(0)") == $y->badvalue, "bad value was passed in" ); ok( $y->at(1,1) == 0, "padding was correct" ); eval '$y = pdl(short, $x, 5);'; is $@, '', "constructed a short PDL"; ok( $y->slice("(1),(0)") == $y->badvalue, "bad value was translated" ); ok( $y->at(1,1) == 0, "padding was correct"); { # Tests for a segfault bug in PDL through 2.4.2 # (Thanks, Alexey!) my $x = pdl(1,2); my $y = bless \my $z,"ASFG"; throws_ok { $x != $y } qr/Error - tried to use an unknown/; } done_testing; PDL-2.074/m51.fits0000644000175000017500000220660013460433355013400 0ustar osboxesosboxesSIMPLE = T / Created with PDL (http://pdl.perl.org) BITPIX = 32 NAXIS = 2 NAXIS1 = 384 NAXIS2 = 384 BUNIT = 'Massaged Data Value' CDELT1 = 0.01 CDELT2 = 0.01 CRPIX1 = 182.5 CRPIX2 = 192 CRVAL1 = 0 CRVAL2 = 0 CTYPE1 = 'X' CTYPE2 = 'Y' CUNIT1 = 'Arcmin' CUNIT2 = 'Arcmin' OBJECT = 'm51 log-scaled' ORIGIN = 'Hubble Heritage project' RA = '13:29:24.00' / RIGHT ASCENSION TELESCOP= 'Hubble WF/PIC2' DEC = '47:15:34.00' / DECLINATION HISTORY 9-Dec-2003: Reduced from Hubble Heritage image CROTA2 = 360 END xurolooooouuuuu–––––ŠŠŠŠŠ“™Š‘‘‘‘š—”Ž‹Š–ŸŸ™œŸ¥¨«ÒáäáØÕÛäáÃÉÉÀ´ÌÉÃÀÆÉÒÞáççüðÿ ÿ/55/228;9AMSYnqnnefrofoŸ¢rKNTWZrrrr;2Vƒ³¹ƒ˜q>5A/#8>GJGbnqnbkhVJ2>&#2"?NKZŽ•†tVbk_h}ztnn€€\³¤ShnjVO68AMPt‰wV†IF.^IggIŠ«ØðœcK9%ü&&Hdv€CVš+1@þ þþûõñãóêÏóððóëëëëëëëëëëäçêíðêêêêðóöùüÿÿÿÿÿ úôñëêêêêêö5DJM>9   ŒŒ}}}}qnkhehhhhhttttt€€€€†††††ƒƒƒƒƒ†•†“Š„–¨·´«™œ¥«®·½ÆÉÒÌÒäÞÞØÏÌÉäáÛÒÎÒáêêíÕÒÞäðÿÿð ü2>;,//5:BJVY_eh_b`lucil¥¨{o]`ilruuuuXGJnwdgŒzGhw_PhkqnhVY\YUa_M>#A/-\›A&#_‚—ªž†\__YYhknbY\eP¶žAS^UD^ý %0<HZ]~rN{rvL@‚R‚…^ofx·É~riq~&äð# ^G@jRo+7: %%ìæìØåòìËàééàÙÙÙÙÙÙÙÙÙÙÒÑ×ÚÚÚÚÚÚææéïïõõõõõþþþþþþþþþýîåâÜ×ÕÕÕÕçÿ 5JSYJB  ÿÿÿÿÿ      ”•wwww}yvspppppppppppzzzz€€€€€†††††•‰•›””””—‘…€v‘£ ”£¦²»¾¸©¾ÐâÖßýîèʵ»ÊÙÜâèóôôâÖÖÙÍÁìõõþòéìû.+7:=@Db]NHDir`cvŽŽd‚‚š‹d…lr~„Š““““te=:Cmt‹°fsˆ‘—…šyd€€}nbYMGMYaqwnYD5/,_KQ]3îî6nx}~{r†w}n\czbMfZ´¶¥nVOXpE #%p…fwhl3.T$Q• uyXRª«KxoJlÖPí¨“î*0 ööEu…£0 p(é:ø++þÝï1aûì áñÎìãÎë  ëäããããããããâÜÝãææææææèèëññúúúúú      úôéáßßßßÖô /JS_5+     ‹ƒŽ†}xrqq~{{{x„xrp||||ˆ|yvy||y|…ŽŽšš—‘‹Ž—Ž†“ŠœŸ«±´Ÿ±ÆÌÛäçÞÕçêçäÛêíàÑÚûéæÝ××Ýðü    üÿ& )&)/8>AP28tuvfr‹—|v…¦…phfwŒ›­¤•Ž”€JK9[^^ˆrrs{{—¡…dUXLI=1GO||[d@UFDS€b8 üù>†Nj†Št}¾…~l_^hw|‚ÐzVFdKB0*û*jsJIcs8,@f8j†€¦¶d‘¤uh>05ÿʪ (-B_m<6G’‰€_)& üöüäâïöæóëçÞÒÕáÞØØØØØØÛÛÛÛÛÛÞáäåäçù ÿ   ,&#&, üÿïààÝÚ×àéïþ'*--'    qšŒzrrjvzŠ„xrlx{{~|}zƒ}tz}zqƒƒ‰‰Œ†Œ‰˜—£¦£…šŽ£’™™––™œ–ÆÞáäáÞÕÏÏäóðê çðÚÔé  ïàù &//5/258;:VOOdjouŠ€Š–Ÿ‡‡}ƒ˜˜•ž§ª¤¥¬žvxÊ—„mWƒxVbˆý“§¼|agvgR@^‰Å›¤}‰qkVLbzPA@1,b}…mG`„ffhuDhn[irPN7Q<! à  Ko+Gšb2EzZF]8PcbH‚ƒq~6PKm$ "!-k@û0Mh»‘bD8zhq85 üüöñø%ùèáÛäääáÞÞÞÞÞÞØØØØØÞáäçëðö    & #/2/#  õãàÚÔÑÚãìû'! ÿþ  …w‹†€~s|‰oŠ„xrlru~„„zw†€ztqt}ƒ†Œ’’›•¡ ¬¬©—©£Žž¤¡›††‰ŒŒ¤ËÚ××ÔÑËË×æõøõ òõðïû  &5>S25;AGEZ^[hjl~”†Ž‹‹š²š—›ž§ªª¡¡¤°­®Ÿ˜¥›Ù zReaKRö–Ê» £vmˆ|jUm€‰˜¿­}hPU__>>,55/=78Vdgiayˆeb_fmY}€hS`JT=ZZC39wGU­iA(hWEYPX]GµN^ã§Mgf‚': E<!4& ÿ2z˜€ƒMž§˜P  ûïòúøC:öâÞáñíçááÞÞÞÞÞÛÛÛÛÛáäçêñöÿ &!-'!'363'  õãà×ÎËÈÚæ$ý  ""…}vw}~~‹‹zx~{{{xio~zt€eqtwt†Œ•›¡°¼¡§º©µ¸µµ©¬²©»»µ¬ £££  ©»ÍÐÖÐÐÜë÷÷ ù #,/DD&)DDk2>J_kffqv}xr†–•¥´¥¨±¥«Ë»¼¹³§¤ž¶¿§›™²©‡Žwxn†€±æËž—}³}hqƒ€kp¦s…mŽ‚—y|^^^RCXC=Rn—d[XPP\eupd`c¥}[Ua]N`]8?1ý)>-6_–irK6<DDEjycM|¿xf7796"8ù,)1_<á€\Vn›M5;)3* ôîëø +êÜÛðüêäçäääääääääääçêíúÿ   %,0.(+.71.17'&""" ûæã×ÈÂÅÔã!!$ &  úý    %%! €‹wn~‡ysw„„„ffŠolo~„{u~{{xox¥¨¥ºÀ®±º¾²»ÁÁ¸¸ÄÓ¦¾µ¯¸ÐDzÜÓÁÍßâñâÙßî÷úý/%F17"&5;MS/>PS>VzGYVfcl~‰”Žˆ‹“¨¨Ã¨¨½®´˜£­•’­³³¼Â±ÀÁ¥ ‡¥•Ž£–´Õ걊ˆ’z’}}˜³˜•”q}z°°°‰nysgULI4UUж…Œ‰S:DU^vpbt„~``n^ucJc;X:ûû:2=Hÿa<Ö°~@dP~I9?[F@J#T^7UL"U:jWõöC +a½Ò˜tŒkJ¡€>,*!!03!úåÓì"ÛåíùÿóçäðððððäääääØáçð ÿü #""(/..477:1+%%$ "öòéæÚËÈà××ï!0/)  %$|}‚ww„ysw€~“~u{olluvlof`u{~~u‡œ¨´ºÀ±´¾¾µ»Áµµ¸ÇÐÊÓ»¯µÁÍÊÜÊÊÓâëúèßëý  +":.4"%+) ,;GM58M\DS݃tSZ`iu{ƒƒƒ‹‘§¤æÎÔÝïѼ›©§››ª³¶¼¿±ÃÇ §„—ž}Öµ‹µÓ¢ñÖ ‘†•}‰€tž¡˜¾±›•¼³­npm^UOURspz‘jv|jRAICemyqhu]ZjalW=S4=-þ-,=C“'Ïhv¡ÕžYXU…A7?WI©T%":0WN--u®&ùXMgÌ«Œ¤n2P‰eYL90K90÷æïù ïäîóÿùùöóóðððððäääääÛäçð üùÿ #"%(231144=:7.*$ÿøàÝ×ÎËÝ××ò$22)  "%$pnjq‰{vvtw{“~`of]`asyspg…ŽŽ”——¦²Ä¾Ä»ÁÊÊÄÁÁµÄÐÐÆÕÌÌçðÛ´ØÏØÒáíÿçáù%4+7OF2PD8/;;AJGS\MS‰PJh‡ZXXZ\pŽ™žÑòìø˳¶›­¶ª¼¼¿¿¿ÔÚ±³Ú ÿ©¿Ñkð턬ÃÌŽ–u‡·íœ¥ ޻ʸ»¦¦©‹a\MJ\ž‰\kALJEZštIC>OXn_M]TTekwbOXW"&, ù'+8J^€bqún¤»}ÉIThGID;;>C5(=6%9P@$>2Azãé§ÚkGSh&J4JPk¶ÂG85!. íãÝÿÿÿÿÿðððððêêêêêäçêðý  üööü "(+5996306EH9!  ãàÔÅ¿ÚÚÝò  '*-355,#    ++' a_ghwuovvtk{loriic]cd^jjgp©²£¯ˆ ¸»µÁÊÄÐÙÖÓÊIJÁÊÙÜÏäØÏÒçêáùçíóóöêêö #"%(:7Ca^Vqe\\PMPVqeGM\Y__wTXVUUUk€ˆ· à¶Â¶•°§Â®³§³¼¿ÅÅ¿ÈäôÆ•ž ôΚ¾ÓóÇÀ¸½£‡li„#ÞÒëÛž¶ª§›ª¹ªy}nP_SƒSJQKC0Dj[diC=:Yp]e_]rJPN9EJ>2 '&& "%Mj>¡‡¢[TwfYA6/KS\ATb#>2M? !3O`—¦–†°tYGƒV5+LU[©4FC8U:ûùóðððððíííííííííýÿüÿ"$+1897=CC:@@4"*    ýøòÝżÔÝãõ!'-6666=:4*&&"#/44*![Ypebllsyqixi{rfcclp‚Ž‘Ž|»Ä©¸Žš¬²»ÁÍÊÓßÙÙÍÄÊÊÍÙåÏòìà×þûéûû  ûûûþ  ("+(+@:Fd_Sh_\h\_\VqhMS\Skk˜u[Y[^an€…Æd ­˜Œ°¹¶æ¹¨³°¶ÎËÈ¿ÎçýÌÈ«ÔÝÐØÎÕðúãȯӮ[g…'úêž¼¶¹ª³¶¤‹˜†S\;YGJ=9,*9fj^`U.4Ibmhqh\tK_iHNM;&"5#96'Da&JͧˆuNkcN8E<QGTJ‚z;$/)![N_ߢnžq,D‰w +Ojp‘4U@5F:,ÿùùðððððððððððððí ÿ %$.1;68DPVPMJA90&  úöûïìàÔÑÑÝæøÿ$*099666==4+'* "&577*"]W^Ugds€ƒt[ds‚……|m^ms}™‘—±´À¹€…”˜¡ÃÀ·ÄâáØúéÕ¿ÌÒßðëçö##ÿó÷ÿóùð MYA5&9?E90LXORqWiurvpeenixx`uf``iMfrŒ„‰£}À¬Œ•°¼Ó¿©³¾¼¼ß½¼Æ­ÜÙÕÜÜåÝùíúþéûçÕáÀ“rr™ßÁÄââ¦Ô¹ÎÉÝ»»´£­¡eUAA-<?!2&Ces‚Q&Melfvwtlccxd[_3<"7(28AAABB9E;Cn_AQRQDAPJL$;fCxc%->^' d[”ÃÓræGnt¶‰}2Bý-NHH0$ET "&%*!  õòïêçïðððððíçäý 4HF/ÿ !'66Ees€~r`U7. úööòãæéãÝÔÔÚìÿ+..5466;;885;2)"(*K?9-'#iZVq€qkz€}my…‚|ˆv…ƒ“¦£Â¿ÅÉ´˜¦£¦ÅðüêîØêìêæßÞèîöáíê üü  5An)&DA25)&333N_[pvy‹yznn{ph†Œˆˆ”ŽŽˆdU[{™ƒ‰ž•ž¨¬¡¡§¼Í¹›¤»§¨¯¼ºØæËâêÑïïèýçðù,Móýôºœê´Ãܾ¸ÁÆáÚêÞØÑÖØ«Òʦun\0$3;D,;/FX>PhI\et…yqmvˆsgj8Q39É„+2;AGTZIG9?\[7>6>>MJ7TRC;poI÷žh"7?!4‚lÃ%}÷­›hYžVSY>NBBNH30‡6jaJ(  õðíêçïððððíêêç1FD2"  %31Ep’«Ç°žqV71 ùõðïòõìæ××Úéù &+)002255;DD82, ""=1+lf\wŒƒz€ƒ}r†ˆˆ‚v‘‹…Ž‘‡‘±«»º½ÈÈŽŸ£¬Ðï#2óü þäáîïÿùóöùó , V¡/ /;8>8&&66?Zh=LX|œ|Œtn‚w†‘Žˆ—Ž‘‹v`Uxsˆ†‰‰ŒŒ•¬­ª°³µªž–¼¨²±ÅÃÕÅùþòÚæûëýèõöíStìó䨯¦ÃÌÙÄ»ÁÊæÕûäçÔÜÛ®­¬¦ˆP*0Q9/ ;/FOPen7Re•¡‹‚|wvu…pdde`EBè¬&5>GYeUE;>MV8@@SPYeVI`R8gŠOzP"v‡:/®;kkjª›M\\)G\e`0*9QE6 Š?|p5 üõðíêçïððððêêêê,?@2$  %01CvªÇíÓ»€X:4  üøðõõûòìÚÚÚéö #&&--//22;GJ82,#"7.%  ‡}}˜›˜•’Œ‡Ž’‰€˜˜›¡ ˜œ²¸ºÈÈÆØÐ˧ž«ÜñO£S/øçáýõè/5 ,/A)#,5)A)5hENflevady{|Œƒ}—˜ƒ‘ˆˆ”…‘—žƒ„Ž©ƒž’zš‡†›¸¸¾£Ž Šº¢ÉÐØîÿñ(áÌêbnü éðáÃÆú ß÷ÿêÒ±ºÌðöæðæçå½¥¦´—qC;Ml; 8)7vPV€jp’þ”‚vt|l|aRO°‡±œ3D&/:CW`[=<BBHBMfN?-P\>dfOZg1=?6bs‹‹ps*TB319‡ZZul0?HEB90$E*?E0RX/ýÿúóõðíêçïððððçêêí'*(""*4G}Àê( í™_@7&ûíõøûòìãÝÝãï"$$*,--//5;>522,'%((7+%  ™™Œ¡§•Œ’›°¿”—‘‹”š ££¤§©¾Øôôáí×âÚÚõ·Óýë%ùþøÛÛþ/ ð'& &;J ,)2#YJASSWTZr€s^dycyt’x{|§ž§§•¡˜˜¤¸Æ¯½Õ™«¡™ã“†‰¶¼ž­ž’y‘¯wª¹Öß$ë/:ðîU\>íä÷úBiêÛÙ¬å@ðåãç ¾½³²²œ‰XGG>bMG&pkbPOy‰wt‘ymn|Žp^[zoá–*,"!5.6<KOW3=ICD56Ii[OQEVq…ŠmQK3_/.12PFC(B#)\F}5#)/P&B-EK6H6? -%C (?-ùüÿ÷ðõðíêçïððððäçíðúû   ""'9HzÀò;ÿ¤c@:&þíïòõïéæàÝãì"!)*,,//,,,522/-(+.14=1+œ¥†ª•ŒžªÚÅ¢¬¬¦—š¬µ·Â¼ÓßÊåÙóëïÝìÛÙÜèïêÿÿøÓÏÙö/á8M) )),8A58/28GDA\MKN]rwpjgmvv‰ƒl„‘’¡¦®¨™¥¨¥º»³–¾Ç”§¸¼¯ÀªžÆ½¢Ÿ‰†Žq€­ëâÛñÿù %å(#üÙ -ºäöÌŠ–îïðïÿâ¿ÀÚ¯iI\>,SPGO^wƒb=[z\b‚pˆnsy…^gOhfo`.+* 93E1/G%NORcdso”]EnVsgRW8V)/#!<0,67jLi0*0iN]-NKB009$]fõ&-÷ùéççççòðçäáÞçíöý   ûøý !GHj½æ2ð¡o@1)  öûõòòÔÈ×õ 0221&)//,A;88/"%+4:4"&„~›¤ž¤Î¤žø+ÊÇ»¯ ¯²¸¾½ÏÓàìððê0hŠÏâÙèòéêÿþùåÏ$DMù 2,2;858MkVPJJPJG88<Hrz…ˆ‘y’ª­®– •˜–˜›ž­ÝãïªâÙÞæãØÔÈŒ¾¼ª¥ÊDzß÷ È«–ÀÛåÿÕö5 +% #850/AöÏÊÜÙǬ´&üýûÈÏíÏØË©£™U_eVSdyhnz7L†‰}Ž©Ä¡…‘……—mYTTl>!&88I7E&NI=EP}{XK7igOZJVJ{ù’D¯¯<, JD25:2?==Ld=  HW!KŸi`]'îŠ)C?H'ôíõóóóóïíêçäáçíóõôòÿÿüúûû).16AC`§ÉÿçÑ—oF4/)! öøøõïïõéãàç #+3/16;A;)&,8;;;>@=1%1.1:)"Ÿ¢ªž­¶ª³¶Ô³µ···ºÀÃÌÒÐËÝÜèýÍè òüýñøìöùó  5óÞ/8D;5,YGAASPAYVSPJDMVPnxriot‚‚‚‘‘’›¡®–š†ƒ·´±Ïá áíæÊçÔÈÒ8(ÆÝã×ÄÆÃØêúÎÌ¿$ *CCR@R|!GS ð'2ê >eçèÚÅÐÙÉýçöþԡ˨ÕÓš ˆ}_S\gpnnkOO\}†ŽßîÅ”…s… mkK?]RO/)/,bI4LTT\]oeZKH[3HL]k8G6;+,<5F!PS?"4aX%14'KlNf{NHH!ï"$B<&ôçãááááæêêêíçêêíæéòùùùóîîòþþ #)&+.3<:R‚–·­Ÿz`C452* öïïïòòæòû#*AP=ADKOD)&,JVJ)5++++(417L2+“™­ž°¶¶¶¶ÚÇ´±·½Æ½ÀÏÛÜÑéßë ÇÜ2e… õÿöý , !'5PJM;0)_GAGb_JePVVPJPYh†‡~foz……ˆ—¥’˜¨œ ŒïÞÀÌÒÛÞÿÕòâùæÚàÑßïéÖÏÌÞíú%Ⱦï"&J=L+=q6JääÿPùâÝÊï ûØÙàþÚÅàÃȾ¦‡–œƒebkpYSzdd\nƒ¦ÓÄ°²{v|”jqNE]Q`C  lYDRZZZ`ZVW:?U%9sQT2SV*H)/7(ý%%rB=(.L=7:?TfiZ< ò3;#ÿúçÝÛÛÛÛãçêíðêêêêåèôúùùîééò)/&+.367Jo‚›’ˆiQ=.20) öïïòõøòû #*GVOPLNFA/,2J\M)9(""147:@O71# ¦¡¸²ÇÐʾvÙËÃÆÍ®·Ðæííÿ  ø¡R@3Q!ôþ ú5 >>>8,DVQ0E9N\neqÂYhqqhVY}z_bt‰ŽššŸ±Ä©˜˜¤Ã·À²µæѶØáÏÏì4ïòêáÔéåÑÒèèåî÷áü÷÷èþõîø   +1,CXLLP,;þ$…Òñ!ئ‡¥§ LeíÛíèù üøÿïå¾Ð±£˜€•””ˆ|„––r‚vѾ£‹„–~~`RewNh?!iVEfzk>QNXJQFÁüÞ_HcWC‡O +$'*'D> ›N6O(OIF|a.6ToN]N'6Nù""9üñêééççàãìïòìééæåëýþúúïììõ28=BEH47D[f~xoQ<0%,-& øòòøþ" #E\md[R139;8'NK6]R:"7E?NQH<4'•¡µ¸–¤¯¶ÇÄÖÀÄÄÄÀØÓÏÓØä  øý $JR':GƒŠ<þ üî))9/8>>>52JRMSXZNGV}vwnwbthe†•Œ…£Ž‘‹‹ŽšŒ“¡›¡ÂÅþÈ›ÂâÑËÏàÒýT $ïìéàãàøõìöäÞí  %3#!-=ID8C|Y"ö…ÌóSʱ®ÌìøöèàäôïëäÚüóäÞÏÕØÒʾ̯ ¶¦ª·ÝÏ«ª«¹Ê¾Žƒ‡Ÿª¶Ýw{u[piZE3 9kt|h]U`BBa„QTl™uH`ryz@&Ti6.82,    #_3hU+ =1WKEN$'+ ÷ '?+( îïïèäðçäíðçááÛâéûòéïïïïñù#+HFC>9?Q`fff`N:.2-ýöÿùÿÿùóó3B_a_PSG;FAB08:11655ALFQSJ/‹~¢¨–š­²¹ØØÒ;½ÃÖóöóë&9 7(jXz¹ToÉKM / F:A9H2JSAMD>PXGYdfWY_nmtJqkzw}˜¡€•ª¡Âø­¤‘¢¹¼ÂÝÈÎæÑãøÔÞóæáÛ™6õõàÈÑ ûìåõðÓØù ÷÷&.!)3HNð5HUB3"ÏÆ»ì÷óÉÈÕùîüàÎÇìáÛÔóùóÞÕÏØÛØÐÜÞ¬’…§¤±·ÌÏÃÅÞ š|Ž‘–•¤¶á{Œnicx`6*!Fbb†ŒoQQ]g‡W]{––TTfC,;>*!042 06(59/Y92M5,5):I(7I"ûüòø   ôïéåçóêçðóçááÛâæòìæææææèïõ((('<<HZcif]E1.,$ûñù  üüöüüðÞò!*M^bbJGJL>*<'/7.'&&;gv„\YM{¢‘›¶ÂóÓØäåØÅËÛõêäô!+? 3?¥I‚ªÉ,MS½LSý'g^Q+22MP;PSSMN5P^`Zekw‚kAhhw}wz•šz¡¹¤Ñ ¼§—¨ÅËÑéÚÅøÝ×ãàïóç w1õõéÔà üþìÙéùÖÖ ÷Üóû ".88ðæCU@ 39ÇÑïããé åíßÝäóãÖ±ÐÜßÚ÷ñîÜÓÜÜÜÐÄÊÓ¯˜ÀÂÇÆÌÉÈÛÝ£‹‹¤™ §‡™“mmdv^@F:+Ige„lcZfal`H“¥ŸZHW?WVN93:PG#?@$÷õ>?lHKT3!!*):"1=% ù  ùìæåêòêçíðçááÛãæìéæãããããîô    %<<BWcif`K71/!øñù ÿÿùðùùêÛïÿ +P[\VMGMOA+6$5 :.A^p_\Pœ¡“Š– ÀÑÉÍäðôñæäîüôí&EP.^CXZ_ÕŽj|I?óíþSOI')>;J†_b_SQ,Vjictthynn€q‰Œƒ˜”¦¸¬¦ÊÊÁרÎÝàòã˼×) ñùÕòìøõø"# üõâå ùÕ•žäðë"ÝAP#<"³«òñ÷þ5EßäêíÉÆéßëÖéÍÙÖÐÊÐÐÇ»ÃÜÛ×å·ÄÒòççêÚᬯ}‘kmy|‚‡r3EEQZW<9'*~‹‰€…ž„ftorolÏØ„™{lTL3!+1SP?0!ÿ .&>* !-K #2/  þ %ÿéàâðæÞÛáäçááÛææããææææææô÷  $),2=<9Qccfi`R@8'*- ûýðîäêÿüöêäÞÞõùú$=DLMG\PDOJ'$S;2;AUdZ_S8«¤›¼oïßçøÔäâü÷ðÜçôðùêý4  ^¬sBZuãiaONS8û'E#Ee522˜VSheZ_h^f~nw€Rƒƒ¤‰Œ‰’Œz¤›§ÈÅÈõCÚìÒéø×ìù,ûûþ÷ñ%û  +Aôñðñôö¹¶²Ñâî 41(.5ó(4+&&ÿr¸µ‰â<ý-¼fÐÜLñľÖÇÜîýëѧÎàËÅÈËÄéÂúëäÁ³ÇäùçÛö毵˜kQWmdSKoNr<6x]QO]~ŠºÌ‰ufnœ–~xó®0KJZRJ#A$ +%ø "P”s! ù&&/ .ùõòëçàÌÉáêÞíêØÚéõàæéììòõôúõ #4E3NZfii]L:2-  ÞèäØÛÞäÏÕðáû( =SAJG;:>:?6 áû9GAMa^K\VM™•À´Î#ÐÞóöàéáëùöôCyôÊVi‡Ýs^JED@0?<DT8))SVVh\OV_XcoŒŒtsŒ‰¤˜‰‰›’ª¤ªÅÂÔ7Xû½Ëæ ûÝìØ2( ÷þ%ûû   #, ùæÛå÷;²ÑÜßõ *KT%AD-/=óØo§™a¬8’HÌÊë$4ÓÍâßåúýäѳÑÚÚàÝÔÚÊÔôÚáɳÀçóÛÒòÿ ÊÇš‰˜’zrvpeb~N!f<H~l`89nz™ Š„rhoŠ¢‡“«{$>?QRP/D.%,"*H Ö,*$ ÿ P# öü& ÿ #^LD0õòëÛÞÏÌáçáääØÓàìÚÝæééïòôýø#):K<`f`il`O@;'ýáçäØØÞØÏØðáõ'8@AGPMGCGB9-é <JD;ad]heP¯°ÌçžÍû9"  Üäèèçáú &NC?Toe.aM[K,FkfB$03'31>Ge>SbkM=AGLQW’•t‘‰›˜˜ž³ÃÀÀÀÀ´ùÕóÿÚæû ûì éÚ% àøõïþ1"þ ý×ÂÉæòëÊ£³ÍØØç!$-*$!)/*  7תÔù¹¦ÐÎèøâÙâÐC2ðèó³Áñ »ÂÚæàÂàԪȩÐØÏØàØÎãѮêáÐÜÊŸܿ§˜|‹‹SAY;Pzt\:@€z|ˆ‡‚ÌÕ¨r“uuH€UR\SA%5M:3  ÿB25(@%%W' !  0Y1ABééñÒÛÕÕáçäÌÉÕÐ×àÚ×Ýàãæé÷ 55(NTT~QfriRIPÿëãåðíçÛÕØäóüöÞøöô387>_MPVIA9ðø"ESM\saKAMD«­ÏF JSkøE. ßîúùææ.C|¢–w` nP/-=86úý÷ =),,Vhk_^PJLEWSk›v}‰•‰³Â¤¶ÉÑÔÈËÈÚãÚ%þõïòõìõûø1.[&"1+ " òøéææÝÔÎÎÅ›µØßÓÎÑñ  +&áöfƒ© ºûõí¾èÜÿWR=üíú×»ÎÎÀÏääêØäÕ«¶Ä«ÄåÔÛþóʹ¨Õ¶½ì»Ç»¾Íþ¸©‰z}…jgF.=@+o`f€nevw‡©¢¥¥‡u]Š]z|Y\<9=GJD!! #iV".2*<6-'!"%ÿá TEîïìâáØÛÞääáýÆâàãéààãæéîý1THFQWKxlBNW`^45<üîìñóíÛÒÒÿ íäý*BD…¹˜MSY4 1+BPJwpmfVYJ´µÎ Sv(e2K>kVÙé7Ýæ 13:aŠ‚NKG(-IP;)   !9& 5Vhknx_PRBWVq¤…€¡˜§Œ¶¼Î×ËÔ×ËÔÝÔÎàLûòïòûãõøý :CF#:(+(ûõ2 ìììéåÔÅѪ’£ÆÈËÊØóÚÂÚ å$û¾«ë"SnËœ«ÕÝÙçû+9D ö ÕÖÓäëåÓßÜÖÇ©¢¯½ÄâÚÞõñÇźÛæض”¯»ÍÆ´ÊǤ™xŠti!'6N3N‹ml¤Œ`€†• h~œuif{x_l>M-6.2h˜$þ )EM+DP))22    êù   $!öõÊØÚÞäääÞÆÀÀÝ×ÚæÚæééïôÿiXIqKW?ZZ??EWd%Qý÷û ÷ðÛÒÏçùóáíþÿý!7>ˆ­w\eh4&#7+<JGjpl\YMÌØ,uc(•Õ(dfe^" íõÿû÷0'%)U*•h0*?>8<,;A>V)8,/4I=µ^Rj~ywgjX(Ja‰º¾—©‘ÊÖÇÍÑÔààÝÚìÔìÚààÝÔãàì '4&Òý$øö&JüÿõáÛáíÓ“ÚìßÔ”™½³–§ÆÂÂ’ŒZ]øâÊÌÚö –¾•‹7yPI QLêç««®óhÁÙ°º‹‰˜mÌ·¹ïñë§ãÔæï“¢®Ìà¼Ø¿ÕãÇŽs~–|T&; "Q*{Üûšê˜ˆ„mtc‡œ©®œl$<"9';#'C7 æö9-G:D·-6!'-/)ôýùðÿäüÿ ý ÿùÜÂàáÛÌÉ´œ™¨½ÇáØÆÔïïßâéôï„CAB<77:=<EhŠMA5ù  ïÚÔËÔÚæíÿù1@E\SKV`_69T >JSGJP’PJqHHNÏÝùíùBŠÊ¢qÁ‘H9µÇñþ,ýüd'Q&nG55DA:5 /D))5,N7s[j44Odf‹eMWSRYz˜µ»¬»µÇÊßîãæìæãÝàïàÝìãéìÚøï190 ýüÿø ×æíÞÞàÀÈ úÔx}w†š´˜ž_xzj°ÀûWK7jcœ®xnftü>%ìÕÀ¥qÐÀ“–¢‘¡Å¶ÉÉÌÒáÛæàÑÑÎËÈÈÑâÝàÕÊȵœš‡d32qW%*$ PŒ€‹±jedŠ™Wrw¢–l›¡‹ƒb[=>7FJ 1w(NSC&CD;>#&  2+36ù -$$ñññüùáêííéÔêíɺ·Ÿœ¢¢¦²¬¥¶Ñ×Ðßæñ#125I\18PH=U?6AZP;ö íØÒÏØÞêó ÿ".AW_PhWS:ä')>n‰€PD}__Œli]´­ÑºðíŒÃÕs“¯s4Uüú.  P!),HHf>qP >2"/2kSteb‘4ICU17Lac‚qP`_ah€•®¯¯»ÄëÓÙëàãæàÝàÝûÝàþòïïìïã;3    üþ ûþûþééäØÞãÆÆìê͘Tbzw…—­Œ|€;kNB]Œ®Ûíüõø_"LmêÝ™gb]”íú⺖rP³‘mœ¶Ùì¸ØÃÛêðêùüÒ¸ÅÔËÔ¼ËÑÔÑî ÝçàëàĤ„@*kz?,.¡Òriw””ª]o‡ÐºkžÕ•†x_YGN:Xq+>wUYDLe42GM))# ,40#?0÷âùÿöáçêðïÝêçÏú¨¢¢“—š—–¿ÔÔÊÙæëø".GR(2VH2<435<8)ÿù íØÒÏØÞêó ü">KMhfJ="ñî2Xn‰†\V€nh†ll`ßäÄ°åí®Ê÷óN©`1j5ùøükS ,AG)5;,D>&MVY# 2& >k\°€za*N]U^d]WY_†ryc}‹˜’« ¸¸ÓîÙÜÎÔàãàéìûìé    ýýñõ+#óØáÿùüÿôðúÕÓßøåéãÔÀŒ‰hgw‚}{wYe,C\S¥Ä—´°ÉŠ:G° J"¦vc xyÊs0-–Z^|˜£¯ÁâìøÉÉÒÌÆñç´ÍñʸÇîýàÛãéÛè×ÊÛÃßÅ„y9k}Hü þ÷ü5­¡™J’‰®Œ›Š‰kiÙ¸ªŠ…‡h+ 2.2;1Vq@Yi<3ZB0$**+#=$ &D#& ñî?Bë ÿöóüöíçäæøäÕÛáÏÀ·¨•žš”¶Åìçàìôò%06G$&%ù"'##ö ,,# íØÒÉÏØäê ÿù5<5Œ´Sø[V__nz‰nb]`iº´é³ñ Ús¦¡unŒ˜*öÌõ  ÷*214C(/2JYV>D8M]YY#&5YP†Xi`cQyX76kusyzžºÏ¼ÚÎïõ ûÚÚàõòìòì þõUAöÿúþóïååëý÷úýïÄêôîéïùáîÙêó㳟t˜NV^cu\D>> B“À¯ucbž½€³€Dú’£4àèž  ?(a|ee€v‹†•©†˜°Ý­‰_éÅÍâåßÓÇÁ¸¶ÈûèöíäÜÑØŽü“´¥Jƒe5ñ`lrbhMŒmœ¾Î‡œ­¢‘±Õ‘”„¸Ÿ†A)>pžéX\\?NB9<E04A/(WxAt/3ëèýëèëèíçííäáêõíïéÚÔàÔ˶›¨Ã¶¦ ±´Èòæâÿ %C+,åØÚüø\e&;;2 íØÒÀÆÌÛáùö"5Be}•cV K` 1enb_h€ŒqYflr«Ÿ·¼ò›9I\F`ƒ‰æéý :9W>_5MS5,Jtx]™HTNo`iCvl`]c‡CXeymu‹~ƒ¤ÄºÈïÔàõ+1ÚÚøþ @ æì"ãïûÿ  îñÿÜåóñ÷ôÜ Ù ÊóáÓîôÚÌÞÞöÌÍÓ³¡“}†YJzmcJeSMF2¸˜[&clz›˜È×ÙwŸ€Â—t7!9eƒ˜³Ù¡g€–Œ•~xƒh€t•‰w˜ÑùôÙÜèÐÊÍÊ£™´øèðáãæÀI‚±x—À‰w_ì;5]]LZ€‹©¿¡®Õ¶¢ºÑÄζŽ³¹¯ˆq^Pvf\pM;G//;)8A5 &8+BN A3÷âýåÍññÖäùðóíððóòäêçÕÏááØ´¿´ÕŸŒŽÁ©ºÔÚé]-ó4( ÷÷áêûCk_&)>88>2)ÞØÞÒÏÒá×Õö78u˜žhuY+=/93 /\MGY\h†b}Qfuª®ÊÝî÷9ñø#Nbúë ÿ  $-.FXG>8_DA\hbQ]xuŠdjrro{Ë­x„”~uZ¯Å²£å´ÕÛçêçêÞàïò  ï:ø õ@þæü ýë½Ðîîôñßc<ôÇÅÇÞëáò¨êŽ áüº´¯­`YOMyf\QWI]‚fšhD:XV<K?S9DÂ'âŒnI&=dŸËÕ••¨Œƒˆ‹”fk€nnŒ¡€wÞÊÁñýÐâôÙµµÈ½ÄÚñóì8ÉÇÕßßÓt·ÚQqw«}/C°Â·­•ÂÈ×¾½ÌêÚ›¹¹•æ@@#7Hepa;APA8V;AG285 ùó&-$å÷ܲÍñÍäùäðöíêóûïããæàȽµ ÀºÅ¸¯©ôÖ ôâùü <üÓöú5* 3>2;GD,)55öçüÛÒÉØáðöÔá:&Qhe_Z8"%260&DSYJS_¡Èž›u`ßÞöÿú/-2ø/:C,*'2/'4=FDnPPVYteYznYk‰z}ƒ”qzˆŽ“€œã(Ù‘‘~lc—Ÿ¬òéÕöØüäÞÛããøþûãòéæ ýÖ¬¯¬ºÓÕúÚÚÝÑòã×Á¸½ÛÞ¢Óëþúè¶×µ’eCPKJ8IkAZ[XkTx|pa¸¦l`hi†i‘öª¿\@;  U¨àø³‚Ö¥‚gon`T`oŸÆÕÛêϺííùùüð»Æ–€šÑÜßÒÎöôäâÖƒ”‰Éå›àòêlYe¤Ø¬È„¤ÄÀ¿ÕÓÇòõ«“•¯žIsS…fM7FJAS22),/Yk! )k!$ßëîÄÍúÓäðÞð üóíððçØáêíêÀȸñáÌ×é¸ìõÝÝáØØêù>äÇê!+cG2A#8AêÞðçäóöóçÚÛ"@eiqY/*1:;?9/JJ2n˜P€ªª„roÜÖâ åà>.-øþþ‰]()0E@-@C:JwkV\_wnbÈ’hz›}€ƒ¢‰†—«±µÚ Ȳ–x`ZŽ¢µãìðóó®ÞÛêùãàþøþþ õøûãþ1ÿöÕºÍÃÁÊÎéÆÃÉÃÉ·ÛÉ ¦ÒäÒÌÜîøÍêÇ£Ö¦†S:R+B@@PA^kd±qi‹Î½«‹}®–ƒ‘ ¾u})Þõ Jq‡Ÿº˜”¬¸{M18NKKr™ÃíÿðØÀáäÞáêöÙ¾q™ÍÂÊÌÔèÚâȶ›Œ†šŸ¢¡ùî“9)ƱÄ~œÌÀÀÑŸ½þÌÔ„œ›Lb5m†\L4;;>, >>>  8Jþ÷ ùA ÓâñÖÐëÛáääðÿüöðêáÒáíðùÌÎÊåÕÀòþÊÔïãàÛØßñ %óÂí?%E)#D28> ìÞðíÕäðÿéí"=ST\JDB,%.?KH2=PMAbt†St‰{ouîõç ææüô4åîþ45&<`^?UOEJ\Œ}__w€zçtteªƒ•¤áµš’£ÊÌÃæѨ²œ²®ƒ¤Â›ÏÉÝÂÎÏÌóÜÞ" ø&#" =425ÓǨÀî›Î¥£ª¨—¯Æ†­¬¾ÞÞÊæ÷îÇ® ÖûÞM-EQh%1&)S]Njq[òÓ‹™—j·ÇÑxZQ(ÕÖèÞèî -O@@¬šp?!EQcTocv«Á·ÛØÊÙîñåÜÇ¥¨‰Ÿ•ÝÇ˼ʱהU¤}¦“–ºÒÄŒµŸKgÒÁ°¾½áÄÁñÐ×Âß •¥…y<pYž¶AS56E?'-0%  à ðÄÖÜßÊ·íÛÒõòéìõýúåßâîú í;š¦¿ÿãÆèèÜìøçùí÷àõ/&B6'$é×æØÛóêäìø1d..*D_q;JF4OG`]5$>SnYM°zh\s^øéøþûæòÿ/_#)#)2&&DGMVS\ƒ]dZQNpne}ŠŽ‰}}™§¹‘ ÀÌŒ¨†a€â§´¹¶«±£}›~¬âÛí»³³Äàêìö  ÿà'õ 90÷á Ý˦¾µÚ߬œ‹·è„—¶²º²úä·£Á£W(#>! )4;*3`zb¼ÏÉÒl€­·ŸÃ¤‡_äâôëîæ!37(2`+4?KQMDe•­ºãø¶éø:éÖв…­›°Ð²©¬ÇÈ Ë¼bï"¹”¬Å¯Ü½ù×›¼ÁƳ½¾°ïø¶ä±ùð½Éϧ€‰_vc]ftX+""4=:%% #,  ý×ÍÞØËÎÚÔÒàÝÉéìçüôõøò PV ðª¼Ò7< ðÑÅÎìðÿüòïäÙ'$$'"+õôðöõæØà÷ñ I0<0$MG;82JYSGVMhzY_\b}›|…[õûóüùó ð' nù )2)/8PGMPS_bYSQˆfHHphw•„ˆ›ž’Q€¡­ª–›‡ž~br¬¡¶æꟈŽ“”“Š(ðòáËÇÝï"ÿùøø!+? õü÷áÛ¨¥‰m«š²ÑÅ…üÂSd’ œ© ¢“jTs^o&:",1I:@Of4:‘¡›l¢Ïºà㽺{je'ûóÿüÝÖ (QK^žSl^LIZc˜£ñë/µiVv–¬ÑÚŽ|¦ž­Î®®Ï½¢œÏر«ÀÀÙýľž{¶·¬çø´ËÊãÕ×èûÕס—”¡}qqVkwnLV=%(+1.+ G9$õãïãôùâÜùѶ¨¶§á-þÊæô÷öþøøøøì=emN9 "47! ÜÏÃÌÈâôùöïêîñ-0 !  "  øüóêãòÕ×÷.4"% #*J>SnG2;;Dkì%qVth\w€gvX  ú úNÿn&ÿ /5/5>\SMSSbkn_T~`Qj€z}œyš¢œ}‹Žœ’œ™ž®ŽŒˆ”¦Áâö¾§€®¨ˆµw ëðØÜðõ &þòÿ$úöOq?2)÷íëÿåÕ§hWw›•©ÉÅ«ï䯓`]e¤Á„½¹yBearpŠ)T%7jd[^gSn­º·—noŸÆøÝœtŒOA3 ü¼{à==[lR€l y*"PDixzŒ°ÓÇ µ[6-@gŒÔ¡Ž²°Å׫·¨–“ØÆ´·ÒÄØî뉖€s¡¯« ¶ÒÙÕò½¤ÆÔ±Û¥—¯›±“ysez}_>^A)),)2/ $(%"ôòò ظ©½¨Ø*ëòúÿóþÿø  #,LbFDu]J(äüÜÜÐó ëýèùú  !'*  ôãÞþãáü  ñòüF5PwP DMSj7}VnV\qeWdUþõîT0<å,)5>5;DSPGS\S\q_dlmmz¼½„–u†˜}”‘„·¨»£Àĵ¯‘¤·ÎäÚÌÇ¿²­Ñ²¬ÎÚÎÃò õÎ øYÀ™AùÚÚâθ½–†›©ÆÞãßÅ– fE3,rŽ‚ â΀>#-8FE.ú9--7K~¨}ï³Ï· ˜zx{¥•Z--,( ÔiÝY`GQ›ö'Ò°k'7`xzft©¥ÉÙù¬ÉÊŒEiL^’‘­È´’­°Î³ž•€˜v´ÏèæÌ€NL}Ÿ®{ãäæÐç×Û0ÍÄ˾ýÁ œ¨Î¿“r‚vMGI5)5885)2/'1I!âôÈõ  ʬ¥ÃÃÚðêöÙÛöù õ2=H;1,e•f( Æøýôöÿûâååèîñ ú!ò%òûøþëÚáìéù#&$'êùûóûþêhM5D/>PMRhnŒYJD_beZgUO;,5//;JJGMSVYVqneƒsgt†§«Þ´˜„ˆ¯¯ | ‘‚ÈÊ¿ÈÅ—«±½ËÒ¾ÊÐÍâ©«ìþËŸ¤ìãÎßùíù%êý"³‘— íøæãÍÍèí£€TÁÅÛÙ&³„p‡m '*,Ve}H#0F+!9K0÷ý-0¾°¨äÀÏÏ€z…v][&-Íý ø'ÿ ö'lJ7âù›¢’A .B8GK‹iÊ¿¯Áô8<9X¶¬’ž®––Ÿ¥«¢œ¨·‹‹Ù ìªÏ³ØÌàÈÓääÄÙÐÈÎúÐÍ¿Ë¢‘¥¯ÕÌŠÛ¥Kag6*-'T9*B44+"%ëÄãíþýûÕ¥³ÑÕÛÞûïçêò). ôûMŨ¾)<îêùöÕçøÐ Õñ÷ââ øûò(åïÚÂììÓÂÒ¼ JG4/$ ÿ-O>;A/2 Ohk>G>/JSS`daûéü # EA&))2>PPPAb_SYbkzqns†žÛÒœ˜y©ÄÄ……‡¨»ØÉ°‡²ÁÚÁ±ÁÎÆÈ׸¿òæÈ¥µûóëí$ ÿþ" g‚˜/ùåÝ·­ñ ¥—PˆÒÊ¿ÅÕ}dPV$ '/ÿAGZ&ý0@ ö !íøø*œ†®ÑºÃÌub»jTZ"åâúô÷ýï  ñ wF‘®Wcq0óìù<(*I\C‚“tq—Õw8Nrv®¦ƒ‰–œ¢œŠŸ¦”àÍß﨡ŠÖÙóßÒÑÒ¸ÐÛäâýÕãÞ¿´ÁáÀ™œŠÃ“QbM66$HE<EIC(  çäÔÝæõéÖÑðغ¨º×ÌÞëûøü3÷>+Hæ€IìæðùöÛïýÓêêá $÷ßÖþ+=øÈîðØÀÈÎ?8<ÿ"VD,)ü&M>Sbh;JD;DJYaaR4?þ.F 8)&),5;JSSMGYebbk€‰}‰˜ž¥Æª°¤Š}°ƒŠ agÃÌÆʳºÙÈàØÃÁÉ©´®Ñëñ ç«ÂÚ&ðé/ÿýIöLYFð2ÚÒ³³¹¤é«gž¢¹–À¯ïγm#'!ûäýâêõ)@:êò&;, 'B˜öÃxPGufD0õñ÷÷,)ÒèðçåòãÒ1÷úßñ¿Û  Ao95_9#7"‚°˜‘‘sqzƒ†•‰›øØÐË°’£¨ª³×áßÜìÈÑËëàî×·³uW”ÁÚ ´¿|{rmpM?3 ô*'* Ò 2µÐÑäÕÍÓÁ¿ÜÝõ"+õ&,l I[åÓf;ùøõ ø 4èôûææì ÅÔæÿêö× Q #E.öíõ U5/)YG58Mb2PVMJPbdmmû ÿ /DS!$AGAAMGDJMe†}kq›‰h¹›‰‰˜´Ÿ˜€Œ«©þ­À¯Š¢º<hÅÝØçÜäáǨ““®¨¯ÌíºÈžeªÆÑóÁáò±´ÏàSa¾éû8M5ñéÌ›¢‰¶zYST›¨ÆÆØßù?y&ãñæ _xX  7.êÿ,L1?œœi?*-+óñç÷9@,=üþßêÝ× åýÅÏîÏ´ßÐÜ0œ‚ íÙÖÑøúèëúæ ø(frrkmv|7v‚‹Ãª ±«â¸´ÐÔçÂÅÒàÒáÑþXPýÅœ~ƒÄËíµàÈqiƒ‹’R"  ß÷**%ÎÏÂæÓ¶»²½é õþ !9(-)>DËíú ý  9ëî÷ïòïõòæï äɶ¹"]0*0`{* /JG;G/  AG2MDJ_bV@O[ü>Ph--GGGYkbVVYw¤Œq€§¡€¤•“™¨›‰}Œ±ƒÀ²¾½‘Áß)Zá øï÷þÖÙs²¯Œ¨Úœ¢ƒ[kŽÌàÀÙᨯ«â+,͹ ð+ .✥°ePZZ~~–ÄçÇÒ*g ÷òþîÝñï  }—mE6!  # "Þÿ8MG-d‚O,0 $îèG78>U# ÷ê×¹Ô¹Ö´·ÖñÙ{ àÌâÿ5ŠWñÊÀοçâßÞßÚÓÖÜXjgyqqzƒ†8wŒ˜º³´½ûÊ°Õ‘²ÎÄéãáíÌð*"þÔË‘ŸâäºèËor˜™——X1%"4%9060 ãSQûè¬ÊÝÙ·µÁÒø øDD%%3A_BÜõóæ÷+#?îúñ ýôîøæìõïÝ×ã %ßÎÀ¿ >4-3?V_&  8DMY\5>;5G2MSVVusX<Eö \DDPH(eAPhkezthqn˜›°q}zŠ‹—“®…|}z”¬·£¿°£Ì9ø ó–_o‚§—£è”®#ȯ¢]sÀ›¦œœ½½Ž€¡ÁÚîæäÃÕûßÌÊçÆ®¥€£ ŒUdm˜•ëÏXêÞéõæéÔáe G‰šËR68S44ü_ 1*+$EKJ&(8çaqE Gs@IC8á®ÃÑÛâÍɱ×ö›#ȵÑöp?Ô½¿À±¹Æ£¬Ê¦¶áý! Q?5sjolqƒc±Ó¦¿ÎÄ´Æ×±—yÕæÌóèñÕÊàJ:E橉•5 Ù„º‡u”[|=TQ0HL@GjýW…ñ°ÀÏöíßÞÚÔ`#ùø$&%*ÚÚàñ÷ë÷“ñë-9ë×îÄ÷ööÞ¾Äèâôîè÷(àØÆÑ2+4/D6-þ÷ HD5>GG 89E90Q9N?$WÄO$ +4aC@C7@j=FOjmjsyj…š‘‚p…‘œ—†Š–¨s\z}¹ÃÈßø;<Ž¯€W4ðð§O]¡û¾ëÌœÊ*¶±Ybn`Z\}~\2Mz¯Îîå¸îÁZís‹Ä­¼ÐÔË”€ MwºÊ–@   îí ú!ŽO?“¥Šx_OU6?<3<Q$$3<Ia1@R^g"T,ÿM…„_'S€›&)ùçäöñ  Ûª³Ù•¿¹œ®ý××ﻯªÊ¾ÌÉÙí¾¹µO(F-gdo}rwuƒ~©ÁÌ­ ¡ù¾°¬½Ì$ NüÜ "ù-xAúéóðm2íÓ»‘•¤mQŠoQ--K2&YU*ÊÑò÷ îûöæãâøî“¡E3$ þû   .O(ü6üçêêý÷ýëåñ6ûèÍæñ²î×ÄÔÎÚ×ïÔ¿Ëõúç•ÍðàÚÝ#JD,!%!#)8>S)ZlNB9E<?xZjg9 4=aC==."L7IRjsgv…|ˆŽˆ…ˆ”¡™“–‘eV•~u¤®ÂÕë>C$AYh›“<!ÈÖžO}ß> Ñ£×Ræ߃qnLDZ]xw?0Tdn‰ÅÄsÂwöº¢©ØµÐëÁ¹…‰sPEi«c<.ëè"%(GohÆ«Æ~kdaKTWEH`BEWX:j=Pp‚s?_C%(9u›†‚o<S’ƒkS2 Öê íØ˪¨“ÍܵÁÚÇ ÿÞʤãØÙ²­ÁÀÑÆ!F99_ar…on“ct‡­¾ÆžŒˆÕ¨³ÐÏ¿eìÇ‹ëÙN<ý÷"Oð½žÎŸmW{Š`4(RT;)70õÿ üøøÿëÒCk)$- ÿûÿý.ö%?8þø÷ë úÜñúòÓÖÔß:ý¼ÀÂÅ×ã°ÅøñÕ˜»ÒãÓÈ)!*-+:Cý*5/#/;A8qlNN63$0fH^d!177@U717((Xp” ppp‹—¬‘ˆ ¯—•‹ªŸ–œyY˜ª¬®³Ýà»äøË Y^CQ¨šŸ¬ˆ£Ò-4ÈÏ∤zŠ{IXROC5;C  b_Y=G/&U¶¦˜­ž›ÇhŠ[iV) ýÝíþ'#>iYQœ‰›zpl{rn{xB3<99E) DEd€DV\o‡Ìxƒ„Š~jjˆd%+1õӾ˙”àêìèç %/ÉîÇÆÇ×ÛÉÖÓÇø6uTSp|Škcws›¹¼Âڌϗ˜Ñ«Ãç*ÿõ¹¸ø×Ú¯œÅä%èÜ"1 º&n‰}Ž{uU('<U&ø.CGý&#äéù<).# ö  øøù"õûî èô% ÆíÞ»ÍÖĬǯ©ÄåÞ¨ƒ¾çÝÍÝ816.$$ ù, )5Je<9Q<<ZBHocUL-@C.1C++:1FXUm[yj‚  ² £…—pv‰x¢‡™t檗›—ÌÂÕü³ê òê>,Û¢®Ú’e€Ù¿ ˆqJeSUP^“^hk9.PA\H49cDSD+3G_|×Úïž¼¶Š™~DDô *_zY?dzvjruruR\lu<'9?<?,</C+Y/0H¾¡¤‚”}¡§›ªœwJ&S\e_J÷ÞàÚÖÑ´}ÄìUB¬ô/0a+ãÁ³Ò ÐâÐÓ BBKƒˆ…e`yˆ¬¦´ÌçÃœrŒ—‚·Æéêã¾»òì+ÛÓ´’ëñ óÆÐÓÁ¹‹Š„u`3*B d>(;<ó*Ñðûú þ7ÿôÿéû ÿ·î'úúýëñùýþÓåœÃ¶Î¿•­˜˜³°«„¹ßçÚ¬Ñ O H$ø* # #$6<$BE<?x*7RL^.XaI=XRs|gg^|‹ˆ²»¦£Ž‚¶®Œ®¿ì^„ŠzÂÚÑÝÝ((""%HÛ/ýš‚¿çŠ“¢dîܦ¤c€fH1R@„ˆz€KI;J_EjEpiWQ#(DG/›¡•¡ªå˜ƒ•Y38E+$=éôÚÝ_y˜:X‚eDV]Q'3TK$@><^TOs¦~wg© ¨_Œ”[a:Fs‚^,'ýïÀíȲÑý úÙOJ)?V óúاÆêâµÄ 3-W“<‘~ª¹–¿½Â|_—|xÛØÃÕÛžãòþ4Ë—É†Ç ó ÷ ûÛÏÏë‹‹m„„xT0-!$' gY305 &+êè  ( $ýþÍÈÝôèðéýî î ý&#ò˘˜ÂÅ’z€’›¿¨‡ªå û¿°2_û ò$9 å 52# $3W3l`TŠ9FX?N"@gXFICC^^Xmyy|y‹‹…£‘”¦¬av…‘·¦¤‰Ý̲»Ê¬V…Î6õâÐèÇô5ÿÑNkªºÜÕÒèÎе¤´A:'4c„Y@C>DsOC1šcL1"+<Uezz‚ƒƒ°š›•`kqU‡#,.#0 ¶Š±¢‘7M>:%'6 ÷63-PH5E@ n/äðSn»Ê˜˜ª§¡¡z’‰ƒƒf\G4#Û +,þÞàè÷÷îýÞ;íäçãÚíÜïú÷ w*KlŒÚš¹ ¾¸”¢~Ž|]H›¢¹Æ™¬Ùsò½—¬ÁÕÜüù3( ÏÖô©—l¢£si<šÙn&*(DMMG-2@3÷ "%ÿú ñþïøùúîèýñëï% ûòѺ«›˜¡ƒŒž­›“r§Üé˼   ëë 2,D8)22)60**Qc``™ud490O4CLFIOUOUdv”Ž‘‘‘”©—””¦‘”pš§®Â¼ãÎçå¾Â£´Ï(Ò“Ž‚ȹÃËÉ´ANiƒÕéñÇåâšLdgB8„¢§Z(&-6QLv^E@.ø6wšVe‚i¬d‰¬Q!N\\jŠ¤_]MA}“›xQ® ¢KA $&*-$E]c`mˆjRD". ôß,ƒox…‹zž§¤°ª¡ƒxt‚{`Š ê¾ÅÔÙãóçü-KFÌÁìõÙòñ×' hfY‘²§¸³®b\^/0„Åø ìï¶ç™pL•ˆŸûÊÑúÍÓëvæòïß¾¡©¾v`o-œÕ{)>qdLHJPG5J..*$&%  íôôôúûøìè"Ìîåôñè÷ÖÁ÷ ôàýûéäÑÂÅž¤­žŒÂÔ¶œo¤¦ÏàÂíóâý 5$ ÊÖü PS )*'03ZroKH`j=K<+1UyCLX^C[v||…Ž‘ˆš¦¬ £ …‘yž®­Þçéã×ÎÈàÁÇè!(Ê^oqáêæùàÂ6ZpzÀãï ðĶšz~icKŠ¡«•}<?h2>G`dG  Ü/Re3bv[}†shh W'hkbvu›vn\JMooVdS]02#$9]li]ˆv^O4"146 ùc]kˆt§ª¡˜Â×Ëwvƒƒt` 1ùÐÎÑ°Òý"L8âËäõéìøÙ   óAI2t‘¾¯Á¨¨—t\_//r¶þêàX41­dŽ¤€Îë 8¾ÞBbíòôÙ𱕠·uT`-WucCU†mNG:GSKN6&, íý÷þòõéÝâ(Äñè÷åñèÓôÜõ òúôìðÆÉ¿’‰’‰•ÈÑÅ´¹£ÌøâÈðú)  Ë°Øù)5)#$3HW]Q<?o|OB01ImaRFOaII…Ž…‚ˆ…v¦Á¨ÃØÁ¬éؼ"බï¶Ëþòòž‡P5>?f´½žÌí¢½º‰»ìãÐäÚ æã¸à¼†wi˜p°·®<B†,G~iSEAGcAQT^ikP–“y7Q3MVD{Šl[PSJ@9$á•SV¶¯…383?K9< Ko]L`g]TKx? $BHiPbPž·ª«ùÛœŸ«Ï¼„†zgtkéÚ<JB ÏÛ0C1¼²Ø"ÜÑëòäê ÿèg{Fo}‰ Íð#±³e[#6Ak½Ç¿ "].ÊÁðàñ:ÚÂÛÄßúöüÔñ,ü Ï±o9{Ÿd$`stkNBOBUY490 "%&üû'#   &  ï úñþúôúûõé"$1!òúë÷ÿ´Ó¹°°™Š¥·¢­ƒM˜w¨´ØÕù÷þ!' ù,# 7**-TTHŸK-~eUC/W:[Oa—|mj||ˆ—‚Ž££ «–„–¢œ±±ÔIÛàÚàÑÁÎûï}sVSecyn¥¹œÛÝÏÆÌ·½Ûÿð þÔòàÖÿ°…¾²vCF^[gydeD)Jz}ebwrl3HBØB**YnmfZJ<NoW+€MqƒbY>#5-?c]TB?{hgWW`txN 6KZiBBEW‡›‘Š§³ž¬£›˜‰d}”;Lf<0%#($,DÕ·öÿççÎÒæ 4A!7‹…¹Cï ¡y1a\j{ÉåPOPo*,.cæȿƸô. ËÞáýéÝÀ¯aI@1IO=llYDIY-$; ÿû&ôå3'%+2îîúøò ïûééÚ×òûðíÒ%ýߤÂÄÄ«š™ÂÀ¹Ô¯‰ƒˆ¬Í¢×ð  æñ$)$" *<‡kJ^aM_eXF)*OdOOgpv…‚…‹‘š—££¡«ÉŸ­¶ÍºÒƬÒ+ÃíííãÝãÅÑÈãʾ†äê™olŠÒï!ÓÍ©©ß÷ÙÃ÷ìÞùôô›~…s=L|y‹‹…•‰ŒqbkAJe†„kDeƒ¶hnW4''\emrf">€}hD  DILWrŠ6*69HLNHT`or]“zsor{‰‡„HGT03ÌÛ3i]6}…Ÿ¼­ž¦£„¡€ƒnp?#xQ<=ï  àÝòŪ¹âÌïãûã"(Ž|`HRÁ¸¡ïﾪˆ77:´ ˆÆYGen”—ý/ÙÂÀöíéÅÁŸ¦ˆLgL7RI=mocU_‹O[3(êåùûÿçç6,#33&&êéê Þ þòþòû õïãìéþïÚãì4øCˆïÈÈÊÇϱ ‘ßäÖ+%ÕÔ‹²¯“Êíèöõ '6÷  ''((!GP}qDBTSq‡d+bJ^j[[Xgp||vˆ‹Žšˆšª¾®¨ãÖ½±ÕººÕÖÊåçåÞÜøÏÈ»–Ãâ¦w;Qªxžªôúp1ìïݧÅѲ±Õ õ¼Ñ°ŠuSM;\††¼ªes˜‰zk;V}krhPq€‰›2;S@*6€hjfWBUysjO++R^]lcc-BZ]]`]NKTcf~ŠŠƒ{x{}~‹ZMuZ?œ®EZWTzƒš©¾¢–›ž‰žp”r> E_HL ýßÜèÁ¸ÁâÚíÕíÛ#gpl‹Š¶¯ÝÈĤ‹I+Àî vâ|a@*.ËœÀöij¾íä鯯“Íåmâ‚7@4=ddioqŠm€N.ðáñÿþóù 0)'70 ÔÛñú   þõ  ìãàìò ìÑã÷Ö<ôëÊ’²¹›‘“™ÓÈÙÛà—¯·®ÚáØèú'.86*$+Ebs[K**ALsg.¡’spˆš‚‚yˆ””‘ ©‹£¼§°¹æå©£À¾Èõ•¶Ôâíäãêýýåøê⫤znƒe§ÀÔòÜÝõ.ÚÔ¶©¨§ëþP£teNEKEKc„¢6F.:1FFL1"þ(L" 39qYL9?jgapsO:.=jn_)5›¤qSTHKcWBZcf`qrxxtxlMWoix`ZEQxtaj’˜†Œ†„ƒuvrvvN/2.O8)=D %*$ýôÙèå åÙÐå÷ôôZ]amWkqps›÷ž…|"’miÓåQMPzK3ZbôÊȬ´ïÒÒʺºÍy‡¨»Žyj‚XIFORqb‘Ó´ƒkQâÇÔãâ&0* -ããôûü ýúèéøþÚì×òþõ ôþÚÞὶ”‹ŒˆÀ¸Äà̶ÃØàÊÒãðçî3!+ "3*(AM)7 !)ARI4­z‚‚gjX…Žvjv‹‘¦©³¹»ÊßÉÀӤŮÂÑÍË ÞÚÒÏËø÷¼¥‰Él~KÃÞßöùüí½äÛ “§£jaqb¶N003-?rQ-)%% :IF+óúôÜå 0T>)$]do~u*630KXv4|y¾¦DZNff„THE?Gf]WexgKVoiZTWWZ`o{QŠwžt—š–Š†vy‡f2 LP\ò#2]B*)),,üö7îâÄÁÖ!ô1sEY\hŒ»¯¤ŽR[§£H¦þZh9(tÖÿáÛÙ¨°ºöâðûµ–Ì‹ŠdˆXLUO^…v£¹¢Ýœ\|EéºÖËØê#ý &%$áìß$7."ü'þ *3þàÔÎòæïþôýËÿÒÜ‹¥§gŒ—«Ñ¶«»îóËâæìîð ô3!BC 0'*H@"öü!6 7CC:źŽsgy‚—Žsˆ—…‘—ˆ”‘¦ –®¸¼ÄÙįº¥„ ù½¾ÍÉÉäíèÝÃÊ!¬‹YŠ¬³ÍÚõà×ÂÅ›ª¼°Œ»—Nb€w´fB-<-'<]9$560 T<<'úþùáä  !0WP)'WjloooBB6*DOX" @vy”©>N6K]c03`YRc]`zfTEDTTQQQ]cfllx„Y‰‚‹—–“ƒvmiR4*@<Z>?l…M81"+4OCU77-ëèÓÖåB .Op6JSb‰ˆwg4@’‹$ræíuªCS”‡¸ÞøÛŠÔäAêØлÀö¢™”p‚=1Uam—²ËÁ“–Xêdi<å°Ä¹Æô  õÅÜôH9.7."þ NÛÿúþõãàÝõõï÷ôîâÚÆÁ ­¸†s›¼¼²ÐÔöù´ÍÝéñðñ  FE"0H+) ,;%6CF@›”—…|‘—…ÖÄš‘”‘‘²¯¦¢½ÂµÀÒ±’§–•ù Ï»Åêö÷àÒïìØòþã§÷á—‡ÒÊ›vÈ°˜}•Ô¹­ž­¨¤zÅ—pv’€llHH9H-9TS:::ˆ4 :,22 ù)F9K`_)+9BlppmgaUC1PO:O¬Ü¯aW6H{!!Z,OZfrƒK<Q5!3BENfrrcz‚c{oƒŒŽˆsyvfpKZS36B`0/CutaKG>>A)5>2"+ýâèè- '3<Hf’š”Œy=L}v0nè*D& @1ÓÃIÎmHᕪèânBﵜ _ªÌmUp—¦Žˆò¶£, Œ,Ûñ¼µ¦¼Ò,<(ßêý/N,)'!ü  ÿAÂÎþûìãàïãéïâãåÄ´°¢xìÖi…‰£±æ HSÙÚßô%FHøý'ø03ý!6ü"69*17:®²||‚”—‹pv£…Ž”‘ÄÓǬ¨±Ñ¹²¶ñâ½µ›ãÃëÜÐÔ欧 öô ø‘v€Ç¹¶òìä÷Ò ììææþæŒ@fŒ}z‹«¦qK?93`lWcZKKZ<?0BcownV>#>;EEl]G>IE<_nŒt\APMMh`.=(IgmgXbWfQHH?BE;Rf~uMNKlb0--9B<Wi{~„fUj‹Žˆ~hz‚g/+c{vQF601N9c[aHWu]EEK?TS@((^,)#EK%CRpŸ‹ ³ ^I;79iˆßÑ÷øÌÏФmVÜ`ç²Z±öñ¹¿““”w¡Š—ˆO[‹¬©²Êµ”ª’¡‹yÿã&ôØÔø .212;1+?$%,% ÿÿöùêüöÞòûø×ËÝÔÔìäϾȮ˜“}Ÿ³ qt…¬zZ¶Ú íä æÙêü(-ø $0":ØÕì3;5"1kƒ…— ŽŽ……‚m‘…š¦ÁÓÇ©¥½Ø¯³¹åÙÅÁ£àÐúÌÓت¬žß'%œƒ¦ÑÒéØÃÓçÖöáÛÌöêê#б•s’·±ì›eJM>€tS_ZQ:OFdCLdm„ys^C"(FRN<`NDMUHBZdydO7UXR]UF@:X…”‚sxZfZE6c]0?}x„{MHOiqQE09EHWcu~‡l[d|……~k~ƒtF8XqlKE(21<bVgZVWbwbJJ_MV>7,&A2Œ #8<"@Ig“ˆ‹¡švpSFBr’ÒÏåòɭʤfs¾ Þ¦zWÐÒ縌†…~‚€—® ”dp ¬Á²š¡ƒt\H ü1èë%,3457.('-5*/%  ûééøþõáõøï×ÑÚãÝéÞ̱¼°•©µ­å$÷y‘™”`ÆI÷áååÚÙëóâå9Z÷û)&%%'!:  * ïÝò85+(=s|||ˆ‚‚‹” ©—£¦ÍåÇ»ÇÃØÏ®±÷õÉÐë¸ÇÖÄÜëÇÙñ*=-›£ýúüð"úÿû úºù46îéјµ¦ö·|„]M°Ø›ouV4(XÐgCm|zpjgRCIOX_YK]cWZ]B<>8Jf`UWZ^]MYeuHzma‘ౄB, Rmr{svXIa€\ZK63<36Z€~ulcTRIIOˆ…zi`;Jb3I^9N`lxcDUdIIO|vUyiS);gUO.  &)—™`xŽ‘„jGZuÕ¼ÏÍý(ÑŸ\‰`†¤>aà¥VYcoÜŸŸÂFþÆš‘½©ƒŒª­¬‹`WJ0ûÅ,yž<7*@*s3  !$úôÿòéïäêöüöèóêóêÞÞáÞÏȳËÂË·áù8>@ß„y¢q¨ûÚëûàæ©ÀÆÍìàÙ=$ þ,/ûïþ  "..&0ˆ|ˆ”—”Ž‹” ‘Óè²ÄЯ¦²®ñôééÞÉÕöÀ×àòÈæþø ÷þC_nváîäJ*!#õŸ•°¼ËÐÒ;[ ͵¯Á‘z}P{d‹Œ¨fû´«‚XL[vga—z}nJ>PVYbh`C=7CLCLTKK^`OYbs|…†s|Rnn€DkT]ihCZ`o‰dy……yyjgppdagR+L<C]NKifK<0WfgQZWcn9+H'!69EBEog^aada^UTˆM %hJr{]E8$6!AZ—„}‹ŠxWœ–ļ«åý^Yv}±²«CP«ˆ_!jw°§­³ïÍÊǵƠs…”’ž‰91E4<Cÿè</*LK]Ea ð  ñÜÙÖÆÚÝãööóðóöïïæãéì×Ñ×Э‰…—ĸº;ý3溜ƒd\Ÿ®ôóÑÕ¯œÌϳÔÍßðõ$ "  '% ûãþ &'A ™‹‘———”‘š£”Êܾ¾Á£ ©ÀôÜÑéçÞÒÐÂÈæÑæ ÎÔþúþßìézm¯ÜÒ=-Üž³­­ÈÝÚ*Køʵ¯Ð•q†2`Rfy¶v÷#ت‹ddgXjm‹senhDGPSV\^ZC:4:FCR[UR]awyvws‚‹s|^š…y\lWBT\Xclu~hs||vvjdgvgp‹sX7H@fTT‡lH9$<Zwco]lrR9$`0*6HQKZrdUsyvadvid_2042MhZK;"$*#T…cotvi]MiZÇÂMr…4dm¼¢¥@AqUPu€‡¥±¶ÎèÝǦ¦Šs¬™‰mV/A73"þX"ùìÿGŽFxpyJâá ñôôØéò  üðêðúõþìïøéÅ¿Îåć›³ÜäÎШŸ‹KÁË> áܵªÏƧÕÐè+"$%   æïéþ,*D¸®£šŽˆš””š¦š²²©¾»¯ ²¾ºÍÄ¿ïÏÌÉËÒ¼ÚïÑòãðìýøÀµ¤¤z†ÈÚç³Î,Íñ¦‘|̽ÀêÙ®¨œ¡tƒõMYN'A‡ð¼½Ç‰‹tqqkz}S VVPJSPPSSR]LXXIIRIRRZlgirz}ˆ\wb{wheSTEKealxl€k__khk__h\bƒ}M5& $4(.[^I@: 98GDJGiX]u<WK339`NILvˆF4=mu\`7.&A.FU0)!  EÁ¢‡P^0*2>^[(í 1òÛÜ&'cGGGPcûó&TV¡±ÆÂÓɶ´ ¡ˆ‰’dmQRJ5+>ZF7Oëæ =~WtoWêÓ!$ý yGöóðóôÿÿ ằ½À®~»Í¬Æ¹ž¹ÓÌ©“e¿ìà7ðßÇÀÔÉÀÀãðíçþ+((!*0 ûþ.( !8 œ”””””ŽŽ” š¯îš»¬¬ÐÜÒ»ÇÂàÏäðéºÕêáäÛØç âõéÂòÝ£€êè ëåî÷Ó k“¬œ„®±½N@CCH<®YbhZl„ºœ ƒ ›‰\_‰ƒe5A58ennnkkgiUXXCgjOI9Sƒvulhb[Sm‡f|]bG$fnvWZ~Reqne››t_^U."+UŽˆOXF-'0?HKQcnK÷'%ü6.6PP€G)8hBORL^ULIa{OZ72)'+:=3,!÷/#‘ucM4$öÒæËÝÔ¿žÎæñäß,K€€`d‡+>v|¸¯Æ¿˜º¿§w|yj{iZ ÌÆíü~]Y„xmP%QN}‹¤Ut^46#;;2/8ã:)êöüöèåÜô÷î÷ÖÍʵ¶™Õή¾Òhj™Ÿºƒ›´üº¨êÛüÒÔéûÏ %*<9*   úúþìþ ûø""#¾®—”ˆ‹¦Ð¯—ˆµâôÁĵÁÍÙ·µÄμÞÀíç¼ÏêçÕäÞêÞúñÌàÖ‹ã¿ÓmwÞ÷ ,î÷ÓßÀ~myy”Ç¥E]H(Z`qtkkq…‘yrƒ—‰}nknqz†>);D;YehhYJTF@CO[IjUHYnp~WA;Uwmc]R;*<Jý<<Svf]]pbkzƒ‰ÈÑbwm>25P;§¡}g/(%"(COLR]iô4E>!"$SqeA>)5JEX1LjygggE7XOIWK!N0EJÿ*E3úC]K2=$ ÷üæÀÕØϺÃ2>üø|7]|¯vK÷L~…¹˜Ð³É®Åqbj‹fjQàØÓúëöôlƒKv¦‘‘~ANq»ïSis-@)FR(:.ÿÿíãÝïõþÚ¿›Ž¢¼¢±©¯es[bì‚tÂßÒÆÉ×æêØÛÞñýô:a(.'3ÿóÞÒöÿêóð  šœšˆ‹— µ¾Ó͵¦¦ÇâÐÖÜè·ÁÁ¿êðÿÌØÓµ»ñâúý ‘²Îѽ´¼¹šˆºùâ ûÑæé¹”vpY€§}XZc]FZhpyw†ˆ‹ŽŽ”‘Ž‚ƒ€thhhVY_A_h_>JbPJM\B=CIRRX[aX^vzmeTH>@(!<HO:0BB]o^kqwz}nkw€egR[O|v‹t:S85AA_hb`QHe‰Q_Y961Rd^FLUa[HU47Is|jfajddxc(R}iGA& %0 @B6/+÷Üãæõôá®Ãà= ï#IB„óTäÖêf·§‘²¤²¤‹©“š‘_-$Ùîùë,/2AA“è´d¹oYñ0¤N@Pj]4YSSM,>>%#ÿçÛÝÝø×°Ë¿pg{½Ã–ZXu¢¸sW”°ÉÞ¹½ÒÚÚ¥Çßÿë÷ ýñ†5/(üùò# ë ! ÿ±Ü¦Ž£îʯ©µ¯ÖâÄÁýßį²½Ùèé×®ÕÿÛ±¹Œ‰¼Î³°¸¤ywŒ¹Ëƒyb¿  Ô,)ÞÒ¾ž’nYMGY88?T|Žƒghkf’›•n†ƒ_\ticflTWfMSVGJ>PYSAQXdgj‘”ROa^sxbSURE7EE0BB'QKD'cpnloorcH™Ô·“·–u„„´ˆ{—RO+RLLLYE\ú8TWLUIKNQQN?KZfgaFIam{hUU_r`^X>`dYNb31:5,7$!,4!ëÇÊÊÁ½¿²¾äE òúôñÁGb\ `©Ê¢…° ©Ëzpe<=ôëò÷>8R5~Í©|];èðˆÞÄšw‡cER6!„0HE-%"üóúêê íÀ¥«’˜¹ÓÍ’tzy´™zƒ’°»¢„°½¹Éö 0 !Z( ü5ô÷B?B* ## ®¯¸š¦ÁǯĻ£¦²ÄÇÜÇÄÄÍÌÍÖÝ×üäíøƹª­Å¹Â¿Ëµ§¢›ˆ¶‡˜¹¹¾Íó ì˪®ˆo>&/9ZW`v“v‡…€xq}hn†„~o‡zGVuoloxŠŠueebPAJ\bP8T^d^Ugm@[W`oefaZTLG'3ÿò$, )AETWP7!3`LZclrxc`iZhr–ùÀÕ™‡u—pj—‚y…c?BTihW^`H?H]KBNZ`[vIFOUapf^g‚YNlo7?FMWcdA8/+,+''þîÏÕÈÀÏÏ>нá ÕßÿúHE&€J`¥‡›Âƒ€˜wdS:H"-@=dl]_uB¨Ÿœkõî$¥ªlrKVLp^K`E?HE60/%"( ùðÞ™‡‡«®°¢––†uµº§§ Œ‡h´Ê·k{³ÏÎÙö üþ*Y6*þ .Ý9*? !)$/›¤‡´œ¥½Ï´Ã©¬¸ÍßÁîÖǾÄÓÂÂÈÔöü ᘤ¼ÅÔÑÝÁ²§²—“~l¥•¸ÞúíÀ¶¢´_YD8E5LY†Œ»ek…†|Wb}~xT{v^…xoou~ŸœrlUYei`]\YL@LVYSG>G8kTco`ip_SGG$2òÝõ;  58FZ\dT^W]lu~oci’›†¹Œ|¶‰Œ‘”x“"O ‹se‘}]`n}vZ[cH9E]NT`ZTPtGAMFUpZiHWbcKag<H;>_Vh;,'("*!$ûóËËÅÃϨÝÄåî榲 þptG~ &Œs²Át|΀[V.=*Czmm‰“„Æ»ýÝ<-Ia&3Jg\5h_nVD,)&%0, ûõï鿪¡¢ž‹}|‚¼Èý¼±«°‹u£ÀÁŠq¿ÞÞê+Oû -3+ùø&'$3ñ 07/$›Ÿ ©¬ ¬¬©²º­¹ÅËȼ¼ÂÂÏÉÌÉÉöóÞüèÆÃœ„œ±ÏÌÈÎÉ·¥€\W;Xf£ÂÅíåÍ®œ”…<#APBNw€†¢seŽz‡”•Œy€vxxdRXy^[€`Wv^cL<TJ?BH?$BTB9E-$3WbuzYbybqGC1>;/)5G?B[ ,DETfiorlilem|ˆ‹£Žpsp†Š…sEeqhmˆFwgoppf[`lWNZZT`cah|hW_SKXobLbPTZXUN>>AA?[I+,>P8ºÈÐðFýÝËÀÖ´ÞÚ7,G~›-L6%t˜z„†55EM"'-:‘²›arˆQSj¨pL+7M,î9+MWYxGV_wj4#&;9J9ÿöùÛÌ™¨Šœ’ƒy˜|’ páÂÛÏ¡Q“¶²¾f~“¿ÑÝìëùôü[ V³@õ %@ÿ$ *0955"4NR(.È«§›§¶¶ž¤¼°®¹ª°Ú¹¿ÎºuŸäêáùóÛäÖÙ£‚yy…¦ÇÐÜDz¸Ûûæ, q—ÓÊU§‚ok£noö”`C^my…ƒzlrˆ–‚Œž”Œ~xU4^p[OY??[SN>+93&A;$*09H-'KQtž¡=I†zze^FD2&# G;GJ33XDGSD_TW`oZKQZedapyp|‚‹‹š’‚j1:XœQgVborj[cllouiQN]wƒqb^``ccfZ{wU<FRL.2;53.R1#5>&>,D )!0ôѸ»ÜáýÒ©ªÍÌݬ2V›™ÎZWg$bŒpwkhFLP3D%$'U—šhj„¿|g{i~r?‚ÐçP9[UbSJJJ_=FJP% -'öëüüíôŠ«´œ~šƒÆö©›r‡€°ªi®×µ»l‹ÏƼÏâÐYý›:hû=ÐóÿëÙöM;=:!62,7FfmOXæζž¡ª¼¡¤¼¶«À´±ÆäóÉÍ´ááÞíêÕÔÌК‹Ž|…©Ð×êÛãÝåã%ª«±´Ü$Ü”tgrÙ—¼€bc’vzƒ‚ly|†y}’Ž€”rUF[jYMHB7;A.",)$?9!6?H66TTDq’a‰†ztjWZZTK--3GPM-'IJYkVXLIO^C%Udoifr{u~‡ˆ£}gU"Hgv˜Sj_alojaiiuxxoTKWqvwk_YmvlTlcnv`HBQY75,/67^7,=.CD>9 òÞ»¸ÍÊÄóÍš’ÊÏÓžÞtl˜Nfx?(oƒTg^U`iM<>9*C‚bxrŸu„¢r–“`˜×ÿµ}zmw ÖµRdy‰>**Eó÷üüá´¨™Éºƒ¡‹«ÓÙ–FŽ˜µ¾²‡±àÁ»mp…»ÉÎËã×7}9ª/ïÇöë÷5&)/!*&47fjRXÛغ±«¨º±«±ÌÞÉÀ½±óíÆÌë诣¾ÁľµµÍ¸¸vŽ¯ÊÐõ#òæc!ÇРiilwok…‚gpQŠvkƒ…yx‚ŒŽ“˜ˆ€ƒ…q…{oR@JVZN97,$ þ",SV;S_P_‘ˆmhk‰tƒw^QB93?B<',;G<?OVhz_XVPMD>/;YeennneYSYe\JqyR &Qip›\fbm_\gyufu{lufQEbfnpnprul_U‰\^NQEXQ75256O^4 1 %%+[oZ[(úåÈØÔ´¯xË»µ¡JTnTo™«OGfD[RSN,RÏrFgy†qosœ{Œ“l—‹XÁ£]yŽß/†UnSZLC1ïð2üöØÌ¢¢¢œÃ¨¼º,+#æ÷êí¢¼¡èÐÁp…§ÈçÚàù"Oc~nŒœ4þòþ   6)PF.9=1LÆɱ®½ÀÌô®Õ¹ï³Ë¤­­˜°Å¾è¾©”¦‘š{—ÀÀ¥u]r·çîäù^I ª°ïâÛßÏ»žocqETzƒnP&l]\G=mXxvŠz– ’wy€|lxs(E?+&$öB*öHaULROC^vwwtkh\†žžƒFOsvU[XOI*2JNNYSnRWICC==7FC\hkSV\AG_VCU^WD5NQW‚hkgZZamfxfc~l]WQhkj`[cccks™Äee)KE8B4>>)3XC7)+% *$?Z\J:TV ùÖɹȥ”’Ñ䬸DjNh®¨´eaU_8PO@@^K6=p‚zz…Œyjc~rŽ1me’ŽfTrfrUVTFCH6-!û)çØýùų̀Ïƺ½ÆÔÓB$Jñôٯʲ»ÙÓ¸©—¿»½èçýï&2Gÿèûæ'<0 ñ '27@T.:O´Â®®ºÀºÀº±Ïò³Å§°ªž³Á©¸©š‘ Ž£“”®¥ŠTi‡½áëøS,½ƒ—µÅÍÕʹžiVZY`VeWJ3XX_M.gkhw~•‘‰tszvcop40- 2-÷þ^]&&CRILdaR[ajioqqbz‰˜˜h[mp[[XOF38JQN1G>\@NLLIC7+RF?GJGPeJJYLATa[JHV[TmtnmS^WT[gcxlfuf]WTdgi`[[]_ju´tm14%5.8>/9XLF;77!?QA;.64$ ñÌͪÌ˳ÁÏ©Ñ#D Zwi™šºŸ`jG8,,,/:5)C$!4gyƒ£‚ˆ{m„¤‡“{q|„.g„[v^cdXWK9*!& ÷ðöØŸ«ÀÉÆ°Û fL/ïËùðºÍÓÊÁ©Ç™’ÉÒÖàì Gÿÿ5G/  ó@E<> ; ÷ú 2CIZdg^¤«¯²µÁ¾ÊÊÊèòøÂ×àγž‰zuW]{of{ˆwnb>’ÂÅÑçô î瘬‚˜¼º§˜€z]NuZ]o_d’NTý$BQn‚ƒv|beng_aKN^L6õù ò G'HI]WZrTWficb_fl¤ƒq_eqe_YPYVMDB>AQNF&)M(?E<9KNoZO?3Z`]NKQTGVde]<Ei`pXš{pQPPTW`uulZQZ]]\_c`ZJGId{s­[XM" ü #)5AHFRXVI6/,,)ù282E^LMB$!Ýߢ§ØýÜØÐæ'/“ˆ~~oX#ðæ (û=7as³µ‚˜•‚Š©•~PZZ “Ù„]yyr]W?+==7   ôêóö½{u¢ÕÛÕñ/Sb/þ;èîôàÈóÆÌèßÓý )  * )$+éT7HH$%PôâA>VUIZmj[¼®ÎÈ°¼ÚæãàúÂÅž›ž‰†——IOgOUOg‡Wl~„«ÕÆÏåè4õ‰‰Âªrk{“¹{ltAèJ¥ŒU55 îì'Wx`XJMP_^VXHB:4E+*$ L^ïø  0U~lZx„x]pgSPVZ__YS,SYPGSPGA9))QN72PY;<]{Z]LB*--0??KfUVWYVQ_q ŽEV]cb^lioiNH]`WNU]^]G:7Qo=() /72ÿ(&2JK:@CD@he5 &,"RchK(û˦'ëÕÅòÿeQeWosKf51÷â õ=?P"!Oy…¡‹­«Ÿ²® ‰/¨{¼¤Ža{`B91$<\RJ=. üÌ„ºÆççÛð ãM„æþçØÕèÈÂÌô³ÛÁÔÙññ×úñ!#-3Kÿëòù0aG:AZ-$MPtICTIC@¼ÈàÔ­¹ÈìòÝÙ˲|sˆs||…„„lllZoi‚Peƒ’­ËÅÔæÔëÜÖ¹Œx¹šˆd_u§]Pl$âZÝŸ$5&ãøûD`ZFLPY[Y[QE+:8 ÿ,7K + &)Lrrfc„–„`h^MS\i\P818VPJSSPG>-QQC5M>>:OLaCR?B9'*-<<<[[VNKJ%HIpm`O`kqohycifNK]`QKQ]^]J7/Ef`050!.)/JHFC@AC_h>)###,@__D@&ûæ£&ç×µÜè÷z3G0Wo<`)úâ PV\"-<L|Ž•žƒ•›¨®Ð„“~£ž˜ÁˆB·¥‚xuiRL;*Bcyb<EE'! ,ÒŠÃÆêíÞöëÿö ÌÜÿïãïâÔÅÐß¼çê÷ÒÔÑì.?P)-3ñó?3?U8.<\6GV_O[W@:@«ÉÜèÌÙÿàÛªÁœB]}fsceaUƒ˜‰~°™š“|J–ÃÁÔû¿»àú¯ÜØƆ‰§¤õªQ?@C:ù4+64éèö2W`>Y5=M\\ŽUE?ý$'ÿÐøðS õ"$G>aŽ‹^OU||bP<HFE5UB-4AhmU=5)/5ÿ'<2;28fQZ$K?*$MMMMM\JDGVgN9=NrVS5 û0/lŠŠŠvƒYesrZI@^Q^si]QNE3-?1ù3A2)TJ29E@/8VK/,5>SDDG2 @CN_ZB "ÎÊäž¾Êì;bOTX[^U ü ãR7\e\NÑ® ŒÈ†È¶ƒ†Wsj‡9)hÚ…º’o‹t{’uSNI]ZMQV)3&òÔ£šÁÐðþòÁµý.4î#îüÿ ùððâôâÍãËó3 `[N& -?+òçö f xrh•6,K26TQCJWJM>@ÉØÏà×êò4âÊ̇`qÔ…‹‰‡}‰Â°’¤¡¶š€ÃØ´¼Ášé!Ü°²ÀÖ‘b°¹ƒQ,,1ëÏù+ øü  .:)?DJSML7PG/Vƒ! ÿóÓú#6ÿ  66flMM\~mh[TQD8d[$>.=@/;K<.7)!EQXMMRKC^LIjdURLMS\YSYMJYk^QB<:2<E?<0Q“ûÛ,ëliZV[8VUJ`aaaa@1@dYVB û#;:B?A>0'CAD>#D>;>GAJ)&6936FoH-3doáÒÒÖÕÌ8KnY'M\U=ëå%8(÷Þ BLKE3*ŽÇÀ§“œ§¤Õ€k“ °M¬Îý6ó»¬Ç²¬¦–ž¨ˆk\OFUMPý ø·®ÂÇÓ&ÿàôíÿ 2íóÿÕðÒ½Îâù $% QS'783À êŒX)0=D,0[dDCC]_[dßåéü2£bùźyjfÊŒ—Œš¢¢¸´››¹°·¡ÌÕ±¶¯”æÓ§¯µ½¡tѶB!%éÞÞýÿ",)<MVYDC+>>5M]9*!êúÜ)%4B>.+PQ68D`dg^XSB +%+ /NH18/*@?PAHX@/PSSkh\_VMSb\SYPPbvcN96:)<BE9%BJdåÉä¦ix\OW/IKGfaX[aC.@s\VH ;D:?EA6'"&8DE0;>DGM>A)&!'.oN9!/Ur_;ÝããÏÿ$V>9VV@4ÿÊ; »» FNE- 'Yº¹®›¤›æm‰•fbÒÚãÕËÚ¬¡¼Ñ¡Íã˜d`OGXJMÿçØÃÎÙÙöãÿíó `äü ùö)óÕÂÐ%< ö!or(ADSø4)%î±U864H3-XdB<?bggdóð&§t®˜‡qf‹Äº×À°Ñìú쥟¬ÜìÆÂÅ®¶¯£¶Å¾…«¤˜³Nü&ð:/#'<3%  $'&.C %/89M__5:I,2A99ðñ9'h_{ibm„WBD?& VQECG=7!  ßüô *XC5)#'$*@B7<ENZ]WcTVVSVV_VS_plK--7><9QdIB€–—Ê\ö¤ol\X]>$,Dc^RX^[CI^JJN7,5"49SRF%"-EQN.$/JV\A/2/ IXHQbiN1$–F=ìéåÓî;2YcX:ÿ õÚËÈÑËÒÒê@1:%9P‚º´Ì©£­â¢žQWFLw³Å»Œ‰…µÔûÔÓˆnehk\RH-E(ÈìàæêÉÈÅýîô$B9Kðó )t\´Ò×»ÚØL]A8A&-? :7žIGüj7+"&(JJ@ENB<H\W^|òOL2,M1ü¹»À‰¬É/G'êöáÍТϮÂØÖ´°¤¤¬©“vqr¶zuoK336  !TB.!(FHGeNGY#=#/ G\_5=.PJ)2<!îÿë$`WTšxaXd{sWZ^S69);;-!6;=2ÝùúÿØèúXU&6<>>.%HiQKT`c`o`_S>GShVPSaKZN6 )`QDO‚rt¸Üˆž^5@LJI)28UXXXXLOOIM`eA1* 99<:4DSK9N!2DGAPD&2B;<H81Mfr<SšIóÛÖÓìá>112ÕÜÃÑÆÝòÔÛí$úòä-£õÀ󪨩¥ÅÒ»v™|g„n‡¡yy×Ð|—|=Ôtmƒ\b“#,0ò îóáíÔÂ'üöí/G/óY&ó kÿíÒœÈÜ(A;þåø. ,õ%/Ho3ÈxO7=‘_)RP5FWEGSLBIˆÙ3P;("vz;¬È§‡®öê'ÜîËÏéáØÔå°ÂØå–¦ª€ÍŽcx|S??382)2-B]TLC-]K)jydU982.+D85MDGJ;172,))G<-,*c|/:.ŽXN_npnbJ[hH&V00J[M$í Aj&>2BE0?8+R3ZZWf{{uiGJDDV_eh\MUQZKKOGY}{cœ™flu\IIPRAG17Camgd71LDDF8'  /9HYX\cfH05PM-MA8AeYA88HG7GQ‚?^DLe íÐåâî*G4')ôÀ¨µî´ÜÝôê R÷º+N…ÁƯ¹±³¸Å¼ÛäÍ…cO‹–€¨›Ä†ùÚÈŒÕiˆ\d4(E=Iøi$íÅûÙÛöçä&ÿ8öíáSØù䢨:Œ9ïùë5D|gÒIO17/?"TC>&M†KtG=EdX6œ@,MezxŒ+.ÙÖôx*FSyý+DßÓÙõ«±Ã„vƒ‚Ý®Zh€z ú ,-& dIB?Y`D[|d`ci^BD:7;G,;MD;5#)1F&úPSc™“**9DPÜË\°ÁÎl¯˜Ï´r~‚^vaR[<ñý<Wa&2nH_KPG-3Cghwkbe_\SMnq_AAP\bhe^T60:599H>Ke_ZwoMgUCON/3PU`g[77CRg[7U`S@=;5@HWhdYMHKDJYBB5AJJDD>G?H(:43hbŸ†PZi~ðçÍÌÓø).'0 ð×ÌÆ·ëïâäþ7 ÊífÏ œ±Í˽ÝÑý~ɧ[iYFm‡„˜¹Å#æI5;5ÏillÒºR%&ØþÞ@Åõöüüüý"" 11øùêí̽·òÞçú  ý¡ÒMr¦q+ 70Wg/9Cuz{Lmí(\·Òœ¤q`‘Ž/¨,‘k"Hhh,ØÜ××ùäêÏÉá±v‚ŽXwŒ€b :&AfeHFDDB5D_ecQWiWhS>88>MP  êáí 0cH38&-–·©jqF`fi“ˆH’UpÕ®HÍ‘/\S}_ýÊÓF†T W*$N1ñ83Xk_SPG&A_>PVSGPYSPMMOW90CD0!65LkVQdqhOL7=TP+D[NE^[LLRL@I^NU?07KQZ^gZWTNMPPYgNO2DPJ_G2/EV#0;.V“_\eYSªÂÕä-* õÃð¹ÄÔÒã,%çS|óÈw ØÒ³.nÿEážRH;%U„¬³Æ§¿Ùz🕠¦wÞ¿ŽÕÞSà öóùú÷-Öß-$õÒØöÛçóü2çüêéóêúëúôód6% /2% ÿ6?BLF^Æ4Îqd^‚±×F˜¾šoM2„èp$Ç¥ÏQ) Á´ ËæäºÀ´ºÒŸUHL©£€€c?'ö9]*04<741LJSkrlNB3EQPGJA/& éíó #,$6$ú,co‚uPD!uEBM'T{Œv;DÔaWÞÿF)5?êÎõÝÛKE oE`P:4ó…JU=LXR[O@IeePYtqe_bkd?6<IA<'0:?\yzf]Z\a.ZSM^:NKOOC4.I4.49@63:K]`djhe\PJTHVttLVGA>AJDDGQ8C;.$N3cdMFFN' $¼Ìêí÷!! Æ¥±íÜãÙ *ejÐÔ:Py§æ‡4¾¯X7:>v© ¡Äß«ŸÌÙêpíè ¤¶¸t•„ñÓ¬´ÉØö'-óìõíÀØMqðêÛÀÿðäÞ YäÌ´ÚÖáöôäô $ßÿ >?@: .G)/3Lb_A’†ˆˆÅ ]Ÿi;0U—Y!º³±ðÐÕîäãζ¥µ»¼¾ºµÄÙ£j^KwhqoS6G--A*+/552\MPPooTW<QTH/G8&2)  øþ)u$è$Dbq2C4 1(LQVDLCauY ª`JÚêíì òìÇñÊóNMoI46KQ:RaajgU:YXRv vnkw‰u1(?Q?O71=9U‡ˆoTK]s-cQKs2I@QOIOUHE-0<;?CO]cdi{sbJETES{‚KcK9<HTH<GN9S@"#Iø>twQK^…T<ËÔç÷Ü£ÁõÆÎÏ#8‘d•§4[aj·ô܉“5% êÐŒ¿ç½¯‹¸üÖýM†²‰B22öÄšº¾Óôúîûòó×Ôíó&³È³Ënó öóá>çõÔñ°¿ûÙþÊ1Ü'ô ú$2/YCAk*'0Xy€QJžtk–é $Hb'9Àu“£¥²Û¿Ì·´³Å­¸¥¼ž¤ÐÒuZ4 < )#%0??;!-%4DFUO=…d[vPKW@7@S;*!+TþO%^i{Å5ÿA8PS,e8-+6`%28-$ 1[m"ÞÊáË¿ÅÙÌ ,ô)øÿy4"0(P89[fgq_V_VVMSEP][efXG<[a4.7:LUOXU\ZNZObliZBLOJAJ@Z.BA?==AB3  633DhUTfa]NXdta_k]?iZfZN?HQRROJE--ù%GFHa\ õýçÏÉ ûôÈèùèÄ»æ<€‘¡‰¢^“É¢Á|HN‘zrbF+v±›“Ê÷©—°äðQNª¤Â¡}X;~Rؼ·¼ÈÎèñÿûêçìÖÃßÕêF*ÿÍÖôßÍýîèΰԭ¹ÑÂËòûìøï +8<+'# #/AGk¶žŒžUe¡¤ãú3HJäÓʪkDJG›•ÉÆ„žd]@l ¤¡ƒtob™xW?' )üüç*3*-E4CY[XFLF4.I8NE5/2e>*’‰4K‚-[^I++@4€J` ±N7FP$!03(*K 6 "wåAB)C5;&>5ZÔäÿKSLBWCw\\§wGhSXZaahu‚yVQOE6*?HE9(6[dd1O_S4d‘„iLg'+/$%%( "<HHD\ONZeaONO}vytRNEZuHK?BNmm[AEKN'KOð+V|jYWTáZS ÑÛ±ÈàÙíõîÖÉ¿Ûì$t€‹”ª‡qw®ÇÍŽO{œ  «ƒ•‹s†µÎº©˜ÜÀåºóæ«—£¶ñ)¨$$Ì´¶½ËÎáý õöÿô×ÞÑô ãêçêíêóóäØãÔÑæC4éÎÎÚïììC ø4íç %<[& DY_n¡¼ŒUGnäÒÏÈî÷ ùêÒ¬N>5&o„½ÂXq^N1džš‹„lnN†ŠjC)% %" þ! EZIIXjdR[IFCdaJ658;P;1"5;B¯­N.pBi_†z&>)D;S]²Õ]FL_1+(# €ò Küí !/8'Q0G2^>_!õÂÕû/J„;U5AMhª’\wYc^ahhQigD9[`H60EE!)Pa[CFF7(I¦wH7À8",!)50NWVVRQTc_UQTqnvdfKTo3EQNBkp[AKNT39+É 8rjxnOÀˆ2νʿÔÕ;+üðäàù Bj{“¡¾s{~¶°å„uª´ ñ«‘œŠÇèâ®áóʱdzŸ›‡È –!øôÅÊÄÓø  ùö ÷àãß öêÝÚÑ×ÝÑÚÑÅËËãËÑïËÈÝåÚÈææûõ7OîÖ(BcE>)>he\ž§}OGMíðæËèÄœÛüß|]H]9'0+\X(-Lwssx]`WVth11K<ôë- ù!8<E[OCa^aX=C:IO\56?=11D9 éõ8zhCHcK?N<0HH‚O8Lm%19zJH7% $%I *HUY8D1ð™‡<(,>A\’•b]kebekzzkqsebniKoxoxgy^I@I@@+??QfYjWNDF.JB72ÐfJêÞï#(..<T_Y[ZWMPampj[bw~cN`6BQH?MXRD]c!378moˆU]wßæ>ÇÒ¶ò#Ï_V&Ñçß Wh’‚gy–§¾yTw¡ŒŽp€ˆ­£°³®ó®§ŠÛ¬Ñ¸µJ.$ ñáÐÓÜÆ×ã#  %ìéòòæäûïéòÎÑ¿¡§ª¶Î×ÅÅÎÔ¸ÈÑàþû%    L ø E™T5GA2G5b\_h@>;Ïá —½Ãʬ»§v/eYK7  óþöíËßUb;WBJ)...%ûàðö00#:RXR7LLjˆgXLR18 5! [ø1 8;P>55D8_>88MGtMGC89@LE\‚PI`T<ô #'+4+kÌ´_`…}YG;ysvd48}beGenqYj`ixiHQW``QuiZWŠo`KB9Eln[`]VYauWLVPWN@ìÌF,'3?V_CBcNJVqqc]RMq?QZNE?6PR@)9T<* ñ#+TSMOøÎfת»äZ?=Aõ-ùü.AeŽ¯®[y’’pC°Ãª¼­b¿¬Åݯ˜ª×÷v˜æÝÇÓWW*.ûÏÃÕâÙù1  ÝèëùËÝÅËŹÎÔàΪ­Èà×ÔÑÈò¬¶ìÑ  ( W3Y>;M/A;8ADJG_=/;®¥Zo¨¾ˆ©¦ÎË‚WtkE!( ëûûýóæñ5hP]57 ëðùòøçè 1U\L7LLav[ROL(& '@4[8KH_A5/;eicK9E*<DA7;BL>MmVWRJ;ñôú=7:3ü'&-'jª–e“ž`Z_DÚkI2>web\\eqbWT]`KQ_hnh_}qebzqhYB?H_bjc`_h]lbYQ}mu'Îü))L*EB2PINfQHMkndrog}tZ]fNHE?FOL56K- ðý)?AHPOoOñΩÀëS*,C ïø ëþ$8qž°š~”vŸ‘‹¼º¿Å±‰q <å­«Ú6¦˜Â­šœ\=?!ûöO1ì&Øïôè 3!9Iïôÿ ×ÿðçÉÃÆÒØáÏ­°ÎæÚ׏涼ìÔ ø ïÚõüV- p_J>DAAD2\_bUS>ˆxèøÔ¸‚s‘šz‰`xd2>TBíøðûõù)*íìãäç ÷$3 !ú èÙ;007OSC:FLmX@+(,&14CaITvsstzlPDPkFhDPSžqe;;;=ADEMOS_e6?< ÌÉ,**#3,F0/užrW’ÐZ£nqbSVbPVh\Mt_ekbg_O?6Vw…‚mu‚|vmm‚‚pCPS7:aX^j].;]W/_`E^€J·Ã*$!25+!BN8DFK`OC<Y_A[^]qMl™rfKNNNFLOD?3 ú&ëùî6E[G. ¶Àå3#? ø $ZŒ†wU„„sv\^”„Âñ£Ž©ÇÚÕ±Æu†¡µÀsQ' ùáäçÚÅçóûê !`=^c"îôüöóÒÆÏÒÌÉÀ°¹àòãÚÅÂÝÑãþéûì.éÎêí,  Hi<3G5;>5,b\8LzV¿ï²v|«Ë•‰oŒqr{‘¬šeqjK$ ìÛë!óîððù'<E9!-b*ñâÙ $6L@5IC4:.@LwrLR@†\'š‰hms²pH8nª#AVG;_#!&2:;J^jkLF59-úâÛ 45:/57,.:40<,@Z,ûWÛ‚Èn€tqzpbknŒt€}k\D? -Vmyxi~ruuf„‡lSZZ<012EZ. 20[}nuE;åÍ 8&/4<“–AP.-NICFWQ\YRWY]{lTKKKHOC1AE$!!$,ü FX`-ÖµÆ 5;÷.>éùé+* >hRŒ‘b‰Ç¨ŒŒ›#+„ v•w’W]‚K5,áØóÕêÌÃÖèÚüç÷ B"ìãéÞðûÕÌçØÆ̽±®»¼×ïéàÝì×Îøìøûòûéï ù#3Q03 & #J5##MeÎû [Ew¿™œr{•°‡`c…ebB$&!,ò  ö<3-6$ !bëô)!-C@@LI+. 4CDBTLgehANyˆs£²uofWM.A8D\A;h5,45VLUhGG1#ýú!)PUM17=-2:!#:6‰ŠŒnketSNfn_tÔƒ€qk8??7Ecpy{vur‡„~u]\]H3=$0T:)*&&;NK^>5'ìó6 846Ÿ¨GA46QGBR]NSYUOjYNWl]NHE?A71D?$<E<&9!/QQ úý çÂÌöD8G(ÎÛìô! ?fHj:q´w!9§û^2 û‘ª‡Žd1+^lSA8&1óØçÒðÌÇèîùéõ 0[1õõðäñëõååèÙÐÖIJµÁ¿ËééæÔà¿ÊûÝ×éøû)ú&:F@4#  #D5,JFMV¿h,6c“„¢ÃhŽ|WnY`4824=D&,)Qc]H-ü&ÐÖ" 9;)0KE?MA"DK66>?B]ZZlcxs}4NYC:^=I%=R[( #/2DSM8IR'-7I2ZK 2 )ó`vxŠÍnknnfYj£Åªž„~XJYƒ†z}jq”Œ£‘ztru|‹ˆjzPF3+*6ED7DAHKT?,"ù)9&4[RZTH?+%2G<)8>LZh;ezezbhA<3!2DT82<3+1( >AéïÃû1 942Y,óÎòåú3$Aû qte:@œºÎ§Òü‰—ö¹ŒŸqfkXX}G+?ùîñöàÚï ÷û ýA$÷ OAéëúöÎõÿùÕäöêäÒ̵ÂæïéÎû¹à¯Ïϯæ çâê÷óæ 'B-$*Š´l6iEN?Z“œ¢€“„}‚•WDOE3-Va2H+%9<8,DVb #,G;#-.ýþ6;,*-4460$+/"!+U_nhJ}qqerfFIPIUYVN†LssU=@7()585#>MJ#O*6?0BQ0-,1&1"öü  0? ýë+H—ksqhb[XpŽs|knZv‘tjtŒˆvvƒ€zvw}‡{‚Š„y€}hglZN;6./#&98ABK3.5*á*,Be**xW<WW./7A:+,AiRb@@[…y‹m3339>0J\`0'0S-÷ýäéåì e5Y:z>ÿûÖöñûH9õä÷Eo\5\¥³š•®ÌÒÀµnfisbO(W;8[A, ûäÿì&*,+2* /úöÔïäÞááÞÌÒÌÒÑÎËÔÚI¿ÈÁçîÖåúÙÙÜíý÷!+4"1.Lb85ZGBBWuu{{uqr‹–‹q</9@9*>UAT%6F90?N`0*BNi>8?C ï #,#'01%!!'=;&?cezn;nkt_`\D9<<BNajz=UCLXR@1 #)& &2DJ<3<<0EW0*:(1 ,85) ó $g_cthb]`n”jpewiv|zp}˜Œˆ‚—‚|}†ˆŠ„…†}z|r`T>4#))+62;<E-1J3ä 0#E\!œo0Wi-0:=8.(ArM<47X¯v‚ˆj?BB3,!;SZ-)0c3ùðüöüùçÜÉÙY$:}_ÂÄìëï9/Üßê"W\N}Ÿ›{‘š¤ì¸€`WYmyQVSXID;)öÿ%+.3<;#R1úùÚèØÒçáÒÕÕÕÕÍÎËËÎÝì¿×ÁòýîåìÖÖÜêãô!÷K91U@@.4.FB&=L<99H{~{lkXeqla)66uŽpJH+%:=3EB?N'$60H.IFHK$÷Öýñ&.)PjP LcWbqhM>JeJJLYO9`VM?:˜©y^‹C:.1ADJGAADJD,0$30<60T4, :/D/8558) B:Uagice‰x‡ymwfes˜€|Ž”§Ç¬ ‘‡Ž‰‰…``]M@:(.7628>D96=22'G8@1%© 17O.7A209)7YLBB6Bx`]]Nb`N$3#B9N5 $)*ÒæïÅÍØ!<05O8&GŲÞÚßÂçêÐÔÚøBnŽ„˜SIŽŽ~”‚=//jÄàkads…SD)0$-3"%+EZ% *%<&T?ýÿùæÚÞØÛÛØóççÛ¾ÈÝÑÂÅÎÅÔÑðüøãÝååíùûýîâñë  4Fj^:7%(I1#Y]B<E]icfcAiYB9,/;FEEz\O54=E'*TN?<**B<N6L%C8&Nÿ#) '3UYxd =4NnnqŒ\GAGS=2QEP\ehcBaXmIIFIR8;GGD>w}G#=O.%7E,J#E=2è S>8AD>/98ö)8PV@fnt‰\ˆeVhŒkzvˆˆ†©š‘†‰“—‡~Ž‰’’|{bI_--9<8>DJM8%/KYE&_SMA52D,=F/2E5)1M,?QTNKHKfZTE0,#0Z@$*5*K7 ïÖ½ÏÓ¼Ùð÷ D:,‰µäêý±ÄÃÀÒ  ;@‚ª±¥—Z……duTK@MŒ‚4Xjvm7=X3AA%1'3=R`ð&8 #á//üüùìÔóíÉØêÕÒáÞÍÎËÑ×ÅÈμÛàîãÝøü*ññý-!!'CsI+%%"#'RGDQN]B`NrqjQ.&D>XsBUOV9E?.>'*06?!$EQK?*96--TDV8 ##IGEC30+FT\YVGzYb5VMMXI9-kíi=|4XC==aXXVG5A/YkY,&5MD82A65+ÿ8H)(ä ;>MAGJ>@-ý"=(%90peVi~z8Sq¡žŽ‹‘’•’£•¥‡‹“Ž’•Œ…o{rPP=;AGP!'-K[E").õ2SU0,GJee5e\\(;;[L=4"FfMt_GPbe_QN?!$;/9QK.-#,! ú÷×г·¾ØÕÇÛËó”>ØÚåÕíåŽķäÞ3,Od†½Ø¦ivz‘ª¿kmIV\‚mFj…jPPJPK?HN57<Wo&#) þÝì ùçÛãÿùÞóÉü·ãããΧÅ×éæÕ×êà×þè×å$$66LXF:ö49/Nxuo!TQ<$5 5>DN<</,!2*/ü üðùÿúKT7:"Uj <>KQ#úôù^`;SY\P>A/,)-4*í®`W:Ua@F[FI@A;/8\MA5/0''-6TQ<]MK6&þA\\YYV\ee]JCI7$o‚|†rTE3Vve˜¡‹”‘¡ž•Á¼¡xŽ¦§¡…Z„ŠhY`MAGYB+1#(,EF/5RabP5?0HB6~]QYP">F8GG//y11.U17:ITK3/)BkcùèêÓçÒÌÔÛÞΩ§·AM5èÕÝƪí ú %<GdlŽ˜àò½˜žMƒ.lgenŽgax~c??=8;D8+?-'Cif*ð3äÚôàÜúìíðöÿóêüVÉÏØààÝÎŤÅÔѼÀÞľÍà××üÓè K$-:(@C17"(+LNKHWK$!$Z&LZùøê2/(?<G0?<1?B!0ýîèèø   >7(:N<~ÊJ"6&ÔÍ;M\A88AM)JG3 üÙ  !X>7I.^F=C:4;GAG;;;;8017@OXdR=X`M:CM22(DAMV\eht}][eL!+10E$T`TCV\WZKUMq}¬”¡†•š¡ž–‘ƒ‰ƒ|l{xnƒfrqbG3M5/;;EC/&1:MY<H'0*?Q];,/KN_WRF88) M5//>E?0$ oeA-Bn*-6*ÿöäʼßÍÌÓÙç粡½Ô秋™×Õæ G.*AWbl•«09Úª‘ð–ˆfŠjy|enrNXR?9<+44+--ñé6*# #õùùúóÿ çáíÏÏÒ´ÚÚÑËÈÅÚãÔ¹ÎÜ÷åÖëÜßéýë3*÷ 7U:1^[ *9ijŸ0÷B3*3/  øø)+%<>GHQH.69$ ôî $!#""%&#"%3'HJ?I)%ÿJncASA­P,;>KQ0îÞé!1\b;77+7L@1+88>PMG5$47FOa1%=7G]jITc,66]@Rdmda^jrhmvZP$!3!*--'>MB``aknnI‘Žõøª¦¶³Ÿ—“‘’‰qdoxrez•rbhƒ[bV!**BVKf_XKB9^IC…djR8;HFmloa1.<?!0?90!!-HE;ZV>Huvd9*-)ññøßÍÖËÐîûöÞÒÙÌ¿ ð¼µÉè3# ?LX=DJ:]—›ôJ`àž³ ž~nî”jvy{V_lfGE??>%.! (#"(U$üõðððáØØÕÒ½±Æ×ÑÅÈËÑÑÎËÈç+ô÷ýáðåå $ '%@.@=”g;9(pg€,8#G,;0*#  0B;AKMB$), þøõþ+!!0:4#%(#4LCcUHáYTGAN,HKõ›VAG<A'éÜÆ00:F'6<SP#'ü ,,2FC@@F=<EN\D,Og@XmKRV ;IzP_nw_YS\ka{nT?%.$$$]]^vqo€zqM}˼ଥ®­ ˜”Ž¨¦’n]g~{ekƒ}yyzTYk0HeYnmmib7eSL°vCJ)8;<fto#@H?'<5,'QSE¥ŒePmQ_;3B2îðóÛßÐÖü ûÔÕìòÛéÍÜ¿Ðöñ>)$WQe>@D/U–žÖõÕ­g¡« owjÛ_|vxKETf-3B<5!  ù5h  þó÷ûððÿäÌÓßÖÃ¥©Ð×ÑÅÅËο¿Äâý3.!ò èÍÎõ ú=4B'6-90+Z9066-?$!?D<H-*(?NB60'39&&8öö$6.(&)825M(((:IRp¤?O:¡mMC'%ïòÚû.B3+(&&BR:5&+ ,RMEBC6JRDHEAKQMsQBI ASHCIUmgXLL^Y`^I*JG0,CIIL[FFLp¢™¢––€ƒ‹Ÿ´Å¼¸»¿¯¢¡·…€e‘‚(jq“œ——‹}a@>vmiPJ\dl\up7<KYH6P8@Teh_JGJ!%ø 6>Pepr«tˆxWW6 ìçÔßîôîËÚÕ¯ÙÝÖÝÜéûö&2;3C^47W=4V6…—ö¨S[…——u‰{ä‡ekX½ÍHBC4CA>?,7/5ö5_ÿ_x]÷  æãñàïÜÏż̪²×£ž˜³ÅÚàïÎèÿ>  õññøöæâõï b$!.=:8 'O`#5A />5G> DP2AGD 99*''! "   $-"' þçA}’)5P/&5GGMzƒBL^JIAL-%  7"- îì-ô02(8'<cEWQmebaYNZ_CH>_@3:5;MVCGSYeYPbqMRssX<R[VMK}ƒwthPVMl„z––± ¡¦—š˜ž©¸À«¥¡¢–]{o{„fQX• ˜§ŸœˆN1)1djx€t_xqw‹}?7@R[>SL6TtJDYVhK?B9B &RZggrÀ«–v…x]Z<' þâìþ øâÐÙÉõðÛ÷çßã#AWXF7@ijF/Yœˆ¸–xKLŒeqr‹”‰|]x|umHPT@ED>6/@  ùÿ, &GÌ8 ÷÷îæøðßÚʽ±ÃÒÞĶ˜¡°ÔàõÑâï õïìÕëòûúèæ# ùK'0f¦°k?/6I/G)PYMM>%=C+CF:$!*"D?*'T6*$'-öí)&Aw•(KT<<3*3N:KZ[dSI81!+=+43ÖËé-BN..0*7ZBOQ`_SOMTfqPMB\A7GLLJUL_nkbn}wtil‡~`:Sewo[aŽ—[Ijj]~†¢›®•—ªžš”“–Ÿ½®¨¢¶©pŸ¢lu~ˆƒN~‘”¡ŸœŽV:4=jv{ƒt\nXk€rD%NfeUYS;PXIQrftf<6`T3!]grmw¾êÞw~z``B0!  $åö 3àÈÑÙçéâ éÕß5NO:4=cmM0XŽqÆl."?xEOul‰›‚^jsNCH\hWEG>0/% 5ðù/##/ðD-8!ñï áÖÚÌôÕÜßĶžª¶ÅÑãÈàÝÑøõéõÎß÷þúæì  -Zf„X¹ã€9'45&) A>Y1:2GMD;2# !),)5JY'! -!-*39-  ü,5&&>;@LFIC1[F]]I4;.   (  1ÌÄÝø( Ssq­Œ|k^{iw,;2@.+8AToZbUeMEQXUQpwhhktƒ‰ƒ†„‡€hP_v aj|‘‚ˆsskzŠ™¨oo£¥–Œ‡‡§®±²ô߉®±›Àƒšl]‡Ÿ™‚e%+Fl{’€yjUXebYE<·¹‹j[EBGep|‡\KkheW1/-h|‹|×Ë‚Z\cN99?** úßþ$$îàÖÐÉÄÁñ˪á ,-COOO]mS`b’Œˆñø/,Z<5V5[6][gL`fBEJ;'/4# eöÞ8 üüõî* ßÚÑ˪˜ÛýÜÒ˜ž¶Ô࿼ÎËôÖõÜæíÐÊé Ýã$ïòG!$?yšRò÷ ;B.71%+8X<ZcHE-÷,G;DYhe/OIFIL (:4."îý!ÿ,;14CC:%=I4XK:.#% éõ »¢µþ+;;__lnµ“Ÿhÿ&D+YAAAJY`[YX^_rQlju’RUm…sy¦©’˜tMkk†Œ¬¤nGPn˜¡˜ƒl-9V€’†‡ˆjyŠ˜·±¬¡”ŽY“§¿®§‘…‚Ÿ¥Œ¢o{‡<39ek˜²®„|nVrq>#LT–Ã6HEZj”sh4wnhE1Dz•ä³­Wl`TilH<EHB-5Øßå DïäíåÌ¿¸ý'/0=^aacbWcf^[ ('$/,";\LWUm@OX?PSM3&ÿóó2któ/â ûÈÝÚ³©íùÉÊìÝãïÑÈÎÑÝïâÓïâÈëÏûååñ÷èýéA$<`mjU/&.+".6#3HcŸ<$$2/MVbb_MAAFFC@1("ôô '$  &2,1"%+[II1xe]LF;(  øþ¾ÌÍû8)Fqw[ƒŠ}52R >DM>J\VOS^delTojlw^^gs|… £™˜wbwk€†®©z\_t•¤§­™T?GViu~jvMVs™–š°¯¦eŸº³±ª¦µ‹•«¨™u„Š33JnnyŸ«•€|_orD(NLl£{3BHj”[V4VYST6@BvŸú¹¼îuTkZKclWNHHB-)Üáêûú.ªÚ  çÒî 0:Xjp`DffT6+þ ,** &&+*'2S<iHICFN<8;GB;(ççù#A#áü/ø ùúèõíð÷ñéòÈóÒÇÒàïõìéãÅËËÎÝïÖÐéè×ÖóWóìæõñåò$)&P_J`aL  ø"ì%IOio!oÞx!-.QBT{¨B6`<RXL=144"û+3& #& S}€>D>SJHC@81& %+(òÍ«ôF=ý %Q]‡E9“Ã2VRMVw•G>AGDS\sm_g_npYSsg^g” ‘—¬›Œ¡¡Ÿ¢™”²°¦—‘ˆ—”š¬¨¨Ÿ„tWCY…KY2@Ysyx†®©p‡Š–ýš·¬¸œœˆŸ˜BD_zftŒ­’•j`]G97%EG87KryˆˆXPdPtw`^c„äéÿ•wzQUlHR`illWKB3úÙãÿ%þ!QàðäÑüð?FXXUQJd?/KE<PPTC%A-19<$efr^KOCAA>62=/&çÏÛú÷üÍÑüî[Kô`:²ÊçéóøïÑÅÑÅËæéÑÑÔãèìÚñÑÿóçûøï Td: >-*0+?.+++"7mecXRO=:4IXVURLO=jd@dkeM8), ,56*)  &#17=[7"CRUYTLF>.# (.+1+ ñûú./ýøJ¯ùý½nOB>AP>>8;Mnqzmb|qh}bjqqz˜››•ž°¥ª¼°ÐÔɦ¤¦ª¤›Œ¤ž•’¢¥«—‡v,*M .i’¤—«¬®B“®²ÀË­‡†›t¨žokYg‚“zz’¢’~h_TW, 0(9KDP©{i`KGYkƒ}cYy×ꯕŠ[WKRiYaouifiNE9-* ãÝá(J åæ#øäëÿ <RLg`248DKLRmzwy^?8>B?&116‡Ìldi\5229>7 8çö&íçôßãØè.†µ õÙïÅá²ßàãïì×¼Åìßá×ÑÜß÷×ìêèöüïÓ3%û.4P 00)<E?EQ9HoWiaOC7FO=%#gOIC=X[IOPJ>5)&/  '' 3# &),/'CUmšI1II\ZQC=2+  +1.(++þ&&øò,`\˜¹¿wDSHED8G5>OOilpvvŒ{fƒopp‹š£—‘š¦­«´¹­¸ÎÌ© ž ”‹©¬¬£±±«Ÿ˜p86J!/ Iz˜|“ªÁ©g‘¡µ¾Ë³¡ž’w‹¥ŸrqeavŒ†Ž©œ”†zllG;94BWPP{uwfk_Œ†q|h‰ËìªviGeRQehTorloQE<$ üíß!- óÒø$$*ýùÙü'F"CRQ5+7@A>EUgxrnZA,GMA8(+Bc‘]aiV=8/38. #,öÿöèìÔÏØù'€˜yø÷ô·ÅÌèÝÝøòÚ¹ÅïßÞÉÚëçüÑ÷ËñåçóïÝ. %8 0%#JtC<?a7#Q@<0-'9E<EPRR=1@p[UF5C1)5) $( ÿ)G4+3E$3+I[<;8;C_bTV4(4% þý!1 * x^ð <œWj^GJ":Oqú£:,4:r3aSŒ„•ÁÁ’’ˆ‰§ª’§ª¶¿»¾¿¤˜¹²¸»tšŠ¡†¹»¸¨µ²®¯­ž~‰M+,=lyl#!0htŠ«²Ë趦¶Ù»¥®®–†o¶ƒc†RZ›¤¥››¡£ž’~iPAuwtfc‹–m»¹›£……³w[lfUe5;qiUhwsmkaU=%é ÿ ìóÖâ+!9:9Q>APTTF??[rrkkzPø2>48+-PA/>MPIB:(þ#ó) ;Þ÷úü ,?q_ûàÇÙ°¡¾ëÝÎàÚËËÎãðø"åÚéïïèõÜðåÜíì$ 0D-3G,2+2ZZg¢{`o&07CFL4=d~v[U[4C114AF& ýî    úO45<CJ)NI.!$2:D>3I:(1+:10) ÷ýüEI†œ_H‚Onw,C~u„{ˆAY[]Ud€ÿªš•œ§‹»¡¡§ª°³³¶½´ºÒÆ®®±®‹•§êã¹µ½Ú»¡ªÊ××â ¥„DN4_‰¹P4*"ƒ¦¿–©ëÅ´¹ÎÔÄÇ÷“s{°‰l€Ya‘¡©³²£¨¦ ˜}ocjtu›Á´‹ll‹”¢™™~„¨¢cTrNE?QuZP_skecd]L9?úöê($êô--*;HK[PMSXzMTNE6NWatdhi?&75%1MG>EKH?N55&#'++ ,èÅÏÐ5 ì÷Ǥ“­È¿¼ÑÔ×ÎËÎÖÐôñʾ»ÓÜåúéù ÷ôèý$-22,HTf„slJ;CILRC@gsl[ICC=7+.78@&)2.%1 +9<@1-qj9R5 ![<.:%((+:+-,ôñ ã  +R÷Çò¦O”œFkqFipRd…ENEKj‡šð¥¦¦«ª›²°³¶¹¹¹¶³Ç´´ØÉ«±´¨ÂµøÒ”®­Î¾«¸ÚãÝÕ§œŠ€™TRr¢|‡=h„˜y˜èªÀø©ÚÒÍÈÀ¢zr£“|‡iv™¤ª¶¹¦«¬¦ž~usss£Ô†g]yŸ¤·™“É¢x¢iQ]EB<KocM_pkecg`UBTúæô 7$0% 9'!ÿAZcgVbYYtMcN6-6?XthiY))92:F>8JEB9D,ÿ#>,) ý1'-! ÷òúèËÃå üù)ûôàý²”ÂÂÎéõéÚÔÑÒÜÙÍÙßµÖßñû÷õîÿìîõ3- %4>CIFGR‚me^hcTNE]TN?5LXLC[=FCF(:22G@7$] ôêÚñT1")/MYC\w1AE/FF+(/6N'-'."'&øññ +Øýìu¨QÁçÔZ@Btwu4j#]KNFQ:RM•Æzae‰œ¨š…‹ÂÚÔÎÅÅÈÈßͻǻ¸Í͵¬½±Ð»Ž»¯¡¿ÑÕÞÕÍÖ¿‰_s_`t‰ÉíŠ>HOWy÷äÈçßçÔÌÒÀ‘w}Š…€‚›§¢¢©²¯´µ¯¤³«¥ik‰¥•wrTD§ö–™½œ‡–{ic30B69`~Vhyqnopi[HT".×Ýî7BFA0NñýíëêfxXn›PSSJ]9!!$-R*6hqS</2BJ2AUa8//2&&#5&#!6 ïûåùîðÝË5EAÏú@í̸¦±¥°¿ÑæûéàÔÓóáäÛØÿùÞɼÔüúÜùöòüö $! 8@4Tdeqm_\hZuboh_YSP\S_nO@CIX7UF:>M;5CF8öôèñï ;G4,2ETPIw’+ >0;" .2Y 5&##/"-ßéõÔ'N7g1[sLQ5;CRRGWPduƒó{L,˜ÞǶŠÁ ¡«ËÅÂÔËÎ×àìçÛØáÉêçÆÈÚã¼ÐÈÞè»ÇÐÌÇÅÆÂŽ¥).Gƒ“ÌŭᆅuZ " ú ïéö×¢‡`[_Vs’±¢›™Ÿ´º¸²ªªÉÒšW]r}†va^_S°±™´¥™“±™xQZQ3$<Kco_q‚zw~vlUNB=òÈÑÎò=T)3Ký÷ääêQW7†Â;JS8!09QKHRAMziEVzwD/OW/)2"/2# ##'*ofûø13Öôú)-ÚÄØðè»´¥–›êòà¿ÈàÑÈ¿Â ÖÐÙßÖñâëòüçÏù  2&69 ,Ddcyirdna^m€\hPMhbeMGML==C@[:::/GP11J)#íü-"G61‚~.iW  1o%"AD/A8>28(Q5 åòçëïðõ(PKFQA9Uf.hVas]aÃ¥1ÓÖîѪ´àÅ´Ô¶ÎÔòàÈÔìðçÞêüöÒíÌïÝÇçå²ÕÒà¼ÑÒ) q48k}™% ôöÛ–u¦Ö0'ûø È·—bucj¦§¸´°¦Ÿº½ÄÄÈÅÌØ©bcew€—a‚j¨¨·½À««`iNWE?T{xkbdntr|u^C7$¦¬¾ú1]D]EúèåêùH6CVD@VP9<B'3<OFYGXUD˜‰PLKB2(ð,55555/&*I) 96âñúâÏÕì˵ È«™¡Æ°àÚïïÔÅËåÝÈìõæøæøÿÛÿÒÌéÿÿö÷÷ .2#)nmxOcqo`_m}_Y_h_bMJPOOIF@L414>8:"D#&8ÿð÷ù#3 " gš`2 &;F*"D +/#/,//2/' ôÐ×ÑÒ×Øà3OH6:RJ2A^a+BO\Yk|œ™Á—£Á·¦Àª£¯¿îãÅì+à˼ÝÛêùáÛÉüóÆó%ÕùìÈÙÙÃ×ÉÑ»´©x_c/W–§ä ÚïýO)Ïë0æÿ‡€¬ëü#þõã­’`}³´­­®°¬´½ÍÖàÚÒØ»€ttw€˜ŒYl“œu–««––œu„x<<fZoVS^ntx‚~gUI0ýñ`LD<úññùú ?F8,)@DY-úôEWXRXDV_OŒ›…C35, ù#2/,&#>Gn34:-õúúáäýüçñçÅÖÑÍêÛ¶¿¼ÃÆÂïãæø˶ÅîåååßÙôýôúííÚèñõíÛÞàú…-!!qnYcfjob_n€‰^^d[FI::COXOFC.+%(#8C#*  2)x_û 7'ND47..11".1+îÜÓÕÛÉÝþ;+")Gab[TSPl]A]n’œ±Ÿ Á º´¤£¨°ª•‚²¶¹ÂÔ ãιÑÕàéïòÚàòÔ"ÎßèýÔ£¤­gK)t’&'þÌ“¤+¿dàå«ßÀÈÿë &Õ¥«¿‘‰ˆ ¥µ¸¹¾»´ÃÜèøøêêÖ«¤‰urŸ‡{{{uŠŸ®®Ÿ±®xŠrNuKiJGUkq~…j`UD¯Îâñî  & ñúúù??F2)2@heú !6BXKJ^\V8NP:Eq@#  ,)§ø0F#0ÿø÷ê ÷ó‰uÅçåÌ·ÚÌÁÀº©ËÚìãÎ×ÔÑËËÅÝãìøã ïôæùïñþõóôìßâ÷ìþ*2-hVBpg`qdan‚jp^RLRXLR[LCCCC"-7'ï+õïöñ%Gôé þ '.!.#4+1%(=U1(ÙÖúå÷ 0IA>^mekcS[^yUTuœ‘¢ÅÛ­·¦¦­´ÇÁº¨¥œ•§²°¿°ÝÎÎ×éìôýúúññ4õÛüìç?0—ge—Y0  øå_¥4éÅóRøÊý06/úïåæ×æ&˺墠›Ÿ¥ÔÑÏÌÉÇÒèñþ å¾µ—yŒŸŠ¢™_¥œŠ«±±«·®i„Š„uucfYSXekuxd]US3åÐÈÜúæ &!<! ÛëÛüQK@YP/:)b0B3<dŠkY8;ÕDSŸaF, ü'&ùð,  4#öïåîéÿ þåƹòøôÇÍÂÖÁÉÉÓìÔѶÎÑÑ˽ÆØóÿíöóöããçñøúâÝâÊ  26*2*`M?lecqdan‚[v[IFag^ajJ;;AA )&+0*ÿ& öíáß!ÿ2ö(:<??"/ =".Ca1 ü×ÚÜ 55*Q/.RRahPOa|UYz¡¨¿Â¿Æ…¸¨ª°½Á¦£ ž££¤ÈÅ¿Èãûôýúäkì Í©ÖsUSM"ÿÿ{çCÓá;øÞ'Vý׬.èÝ  'ÕÀû°¯ªª°àÛÕÎÇÎÕéòþ çÁ¸š‚|}¤•«˜n˜ƒ€ªª°°ªº®fŠ„~rlfb[Xcfqzu^UUT9öÜÏàå.58 ÷ö-0<g_,9&M=C<Ekƒ\DAY³BKwQú)#óê/ÿô* íåÔÜ 1 ö罫çýÛÝÏúÏÊÀ×ñÈ˯ÓÎÈÅÈÃÃÒíööáÛÿëåÖëûõíëÎMm$2_ú; oihhhtŒVbV\^aOOmOLC@>;/,,,)&"&&## !,.(-3ð% )#)5D,,,F^0.5!øåå÷âõ BEL;Y 5RUgv“–šÆŸ·Àº¨¨®±Ÿ•š¯µ°‰ ž˜°´ºÉØííáüÕéñýþüëÝÌÌËäôèÙûîšy`•B"X/´Áõ »¹ =8ø)4FM-ó:/S#æìé ìÒű½¾ÜÝýÀËÝæ÷ öíÕ¥™Šo‡Æ´†£mvy‹¬•„„rTVZsgdjmnoojnV*&ÞÕù1O=,æ$%/2]J2Q36E<ET{]QBAXDMlY #55óêöùöüðùçùìú ý÷Ĭ¬ý×âÙòÚÊæëÁ××˺¸ÖÏÍÓÜÕêçðÛêääíúýõý ôÞÓçÑR~[;pò"'.i]tqtwnSSb}maRR[@::CGB--36-$+ &&#  áé„"((%::. );52A2 ó )7$û÷ ù÷ôô* J]Vuk(#C‚Žš¢´Ð½ š¦©¸Á ‡§’ž‘‹ˆ˜¡¬ÄÓîîÙâåìéãäØÒÞîåûÆå¾¥±¶m±~AK]S…ÙâÀ›˜Ù ,ãsF)jmB*?6Ü;)nü#þ$ ظßÄ¡ÑÛËÂÂÔæéîÿ  üíɱœ`{É­£ôµˆ…ˆ¦šˆ“¢™„ffoY]mpmmsw{|~a,$?øñúŽ7  "?@;(5N+MVcB*-06<ExfTH>7PPEP&5 #/& üöíðêü ö)ÕÒöÞÛôßßÓÄë6ÓïòôïíÍà÷ÓæѳÃÁÐÉÇÍÖÉÃÏêÒÕäêêâíéÚéñÇâ´ä¹ÏV"*,2  ]StŒeh\\Ythd^R:7=@:7-'096-$& #,øû÷æ<¨%.41@47+4::1(øÕý/@#úñö÷÷ý1+bcY|Q7|… –¥Ê·»—…Ž¬¬¯¯£‹¡›“xw|‹¡­ÅÎÚéÅéÅËÎÕÒÌÖþ×úñýèÞ¼¥”¢|jM(7Ud¬Ñ ˧›Ýè Æm@#gjEFC á H7þ+óΪÚÅËÕÇÄËÝïïî óíáßlŠÌ§ÂÜÄ©ŽŽ¯ ˆ~‡Ÿ–Šll{Šhifkkjgotyƒ†g2*K îú3! ''1B?@8FP`ESbW3-3*!'HufBHD.G>$6;D üááíç ùççØØùýÜÙ¾µÍÙªòõëìðÖéçæÓµÊÉÊÄÂÈÑÉÃÌêÕØÛáðêöûìïñÐî«ðÌæ $/  hVnƒb\Dn\_Y>=X[C::4+(*??9*'$  &)ñãû ")+4(&.":: òíôþþ#& 7ñ ÿèô,.lX]€9Fgd‚™«µ™¬››ªË§¡˜ž›š¨°.ðÔ¶˜§ÇÐÄ£ÙÓë²²¶ÆÈÄÈÀ½®¢ÓëûÌž‘ˆ ù*+G\–•ÞîäÔ±ÎEôÒÚêäQf@Z$ÿ"/6\n/1³àæ½²°ÂÀ¶ÍÝõ÷ü óêÛϺ~ŸÀǼ´·¥oi‡„~„––~œ¥–ŒŠTJ\^^iqy„lB9?*ì5)-'+U[IPx*(:_r{eVNKKK<NEK3KG(?A85& ÿ& öáüêüüP)áÒá ðÿíÞçÛÒÉÞÏáèßÜÜÙÎãìäÑÙÓÍÒľ¼ÂËÛäÛöêäííêïõ".ÏÙß™âäüÏ%!;+$-ˆenk__GMPA/GO::[4%(%<Q'! # öö#æáçár0þ"%(( ICŽsþ åýêý  ÷øö -%"6Yhg.G²jjy„Ž¸È³›¹§¤˜’ª»°§ÅÐÖ°´µ¡·•Å¿( ‹ø¶Ãâùß÷øàÅÌäÉЀfì÷üÖ:QGOW`b|Àìè¹Ï=3 L W˜Am)>òáË›”ºÉƹÅûàëþü#ÿóáØÃ¥·çÀú:Ù©£‘jŽj‹•œ¥™±½´™¡´N>_^^ow–Š`KBH* àïõ5ýñ.š¹k2BLAIz“k§ox“B0303</1 <)/2,üü/öÒÞíùùüÿóðöëßÖÁÓÐÇúãáêßçóìÂàëÑÄÊñÞÍÐã¿éÞØçÛÏØÞðöÙâÖϱ¯âõü$ÿ3$!-v\he\\SJG>;@F@@O@11.&6H' $ ÿöù&)êüçí x3*<5+%(.%%22 )M­’#(ñéîãôýñî! 14,*TYL>2G—svoi—îȳ˜ªª§¤§©ª§³Ó0ÅÉÇ ÉóùSêð},øåñõõ'éÒïÛÓ´yh:öê1Z[]\h„z¥ÅìòæÝÜÓ (:H%A )TœŒ{Œ"@X  Úäµx•ª«‹ÅõøæÜ  ÿóáÆ·¥ÒºÙéÄ £¾v‹as›œœ“´º¥§±O@aaakx‡fJBH*Ýìß= ƒ¡cH[M=}“‹n›liŠNx?'$$*,:-# &5/#&8üö#ðÕØíêäÞðÿööíêíèèëÙÜßÍè×àéÝÝãÑÑìâÎÂÎöèÓÌÜÇâÞçöçÕêóíæåî   á·Á  þþ +<??kvSPYSVJA>A1+IL1F7:7-8)ÿ öþÿó),,ù ä2 ."1"+7:7"ûõ:^X+úìâé%.$ùëû=RD0ZM.Z\>j—‘‚¢¥ ©ƒŠ¥±œ¢¥®´¤¦”¿×¼ïØRàÔÎéé.Cf;8õ®z¡­ŸžO4:bJ|¦ÄÉÞÚ›˜›¹§ªÚäí êÑéÖùŠ‘T\-> è圥•®„²ªÉÝ Íÿ öíá~™À²‘žªYw_}““–“lŸ®¨­¥[Osyme{~x€yPEN/ ÜæD1ýri ðEz"w‚zzc9i]`H6ôý1 #* &) ÿðçÞ52 ØÏíöêäØØÛåÍâßÖÙñÓÍÏÇÓÜÔÒÑÈÐìýïéêÖÜÆÐâб½áØÌÛðääõîüÎêêîäý!/;=IV?xŽGD_S;DG8#(+@F@1%%"7òéàüäó 0!  òò(  äíóêÕçùîñôëÔ  ÛÜâîøÏýNE>QTeh^_fO>—…œŸ£»¨–«œ‡–“ŸÉÚÂ’§±äFfÓ·ÒíÏÞÛðhCÿøÌƘu~×½ª~&2U¸½ÇœØýùÜ'ç†Yq{›¿ÿëßÎÝÅÎÜéßq†îå÷ºØô¿©Ÿ“Êñ炱ôá üüá‡~±Ð›|š¦Žv…myr¨ŸŠœ–™ma…”hu{s{KM`>æîß,ô4Æ«1Np}:\oqt]*<EKQ<ý' ;2 ,5/8SA ðí /GÞÿùùçÛØÞ ÷ èÙÄÙÇÙ×°°ÊÕÔØõ÷åâãïöñÓÛÐèÓáÏÒØÕäÒÌäêûîäÞÞ ýä>[aasDDeY;85,#)47@U4%%"# ðóùçÏö+8b æø% ûéæÔÚæãóùâñôÔ ÑÖèôõÆxlDY_ncWw}OG…‚y®º ˆ™‡·®·®«´ÉáÚ¼¹ÌÕ(' ȸîÜñ¬ÇÊè$Ò¶¿Üº™‘·óÐÅ„<îù¸Øû Å´ÕõÆ•ewŠ›‘•µš’Ñ•®Óå´¹û&ßÔ¶¬aáñÙèɵÿèv•ïöóóðÛ“uŠÍ¥“–œ¢{„r¢œŠŸœ{z“uh ˆonvwƒtHSiH#íòâ#î Så/)9ldhUJZhz]0'0<u`!*6# )&! ,82)DG)ùó),M)öüööíááäôêÛÏÌÏÀÞË»¬»ÆÅÈì÷èëîôëäÊè×ãÚÏÆÉÉÀáÒÕáÚò èåϽú*'ýõç )?jQ5S_k_;85/("FC=J49"")$üôø ûÚÛ Îȹ2íþî " ÷4ç÷ڹп×Ñ, õðñåòïó/Jb€V_Ž_Jahwn¥“ˆ““g¼ÙááÅÕÏÇëA#ØôÔæßýèÚÏñϬ—[[ˆŸ±¥ãI%}ëÞ_î/ˢоէ˜ˆ« ¢šŒ“€æøÓ¯u²üîì»È²ºÂЯáéîïò/˜“²Ääéúüýÿ,ÿß¿¤ˆªå¥¶µtnŒ£žž˜ŒŒt†›žd“”i‡loŸ‹—…R\hM>äëËئ~¨Ri†fZdFJnhWX:-*'\eUP;+@4D'%&1=[9è æø  ×ÓƺÁºÂʠ÷»ÄÇÄÄ××ÎÐþèÍÒÙÎÅÑÝßÜÖÙÙÐâèâäÛÙñéâ±Ä # H747r0.UCRO:1.4B+6( "+.ñÿüíäDn  ùý ðããàòÜâCöðäçõ ðÁËçúì3$ÿû  ÿFXYƒ}uŠvf‚vv›zz`Wbuˆ©ÅÏÌÑâÛÕÍêüíÝâÕÙÿ÷8Âp`unk§Ò¿Qò12,ÎBuÞι’¥„ÉÔËÖüâѳÒâšÒô®ô£¿Åó Ú¤š~Š·ÌÕµÐÚ8'å,Z>¸qªŸý êð 2,óÇ€¸š¼¾†Sž·žlk°¡hq}†km|.`oŽž~‡}_iqT]üø&3ŒÊ£KmkkT<%Sb\X>LÔC /ZwhaC1":"1!.9,79?/a:< õû ø×ǸÉËຨ¬Ì­ªÑãÝ×ãàïøûÍåçÊÍ×Ô×··ÀÒØíóÞÕÞÛäçÛ®ÀäÞå#KRS *=!DeŸ'(aCRU=1.:K'-.5üø * ÞóÞØAm ùöéð õþ aÿí="ÛÂú'õæ-÷ùû " &CRO1}ÁVN}}_}ul\rŽÁ½ðáÔèíäÔäíÀß÷  !ÿ×–c[hqœ§ò~ÀçöÆvoê˵¯¶ÚÑ浿³¼¹½¾‰ÕôšÄàîûóþ™tµº‡…‘®ÀÀÐü%ܶÏö˜tº—Ñ Óä 5830 Ü‹|¨‘­¬wh¡·‹fb¶žqqqnbF…=HN‘x~weoh<E?5¥úÑNgYG6S_JU?Oà:,TznX:%@%1d.+5)6?J3@:"H  þò  þÏÁ³ÃÅ̧«»§ž×ïãÔÝÚãèä·äçÆÍåÖÖäÛÒÞáüöØÏÛÞçÞÒ·Éíäç+R_+KCqƒº'0P2DJ>AADDI420(þóêÙÍ ýƒ÷ûõéý) ÿ4)1 ò@8] þ4dÿß>K2 òàãÝøôìñö1GA,4ƒfB'/An›õiZiLDgw”Œu€‡©Ä·ººËß÷ðãßâýê½ôùéîïÿÊŒixDQ“y“þï!ÄRj™HAxê00ú !RBw ÿÁàÚۺߜ›ôÝâ0æÏø«Á²­sm~˜Ûê ³³Åa¹ïËœ¶”Äãæ#:D6%¶ž»—‰\h˜®²„ƒž¡ƒ€†z\Yu€*Tcdqtqwxnko‰HH+AJ½|ùæ¶!. úñDG):<Uo,CciS:.C+ @s "/ 3KP9m;ìõBB  þ¾º½ºª’•™¡±´äçÛÒÒÆÆÓÜ»ÍÌÇÅïÙéÒÌÏíùóçÕØêêÞÆÆÒÌäáö  úú[–»«ñ(HE9QQ<QWH/+#.(ûäØÊPdÃpØêõûîú,)%(ø!3#¢d4½‹-_RX/ÿöÒßçÆ©»¿ûëëñ8UVDG@NV2I÷"4Tv`]KNVy_w‘’Ç»ÛäóëÎÏàøú1ðÓt¨™Öv!}€llu õ¾ÉðÝ]oDVR@,s`Ìéù YFj#VøñåÏ1ûZ ñ*8þ½¡º¬·ƒµ¨††kĺ¹K#Ó©©à Šh¨º¿ÿ 1DD=Ȥ٬’‘}¶·²˜§’†e‰Œw}up6H?Vfo|€{khf\NN $$6$¨c]ôøAS)üNb*  6FUta7  þ.'4#A2KoeQUJR<""  Õ×ìÔ®œ™o´ÒÄÙèÍÄÐÜÙåéòÕÍÑ¿ïÖûäÒÃÛäÕÏØêùöÒ´ÃÆÏðáå þ:? 2lrŠL<'$-0HB6K8-81"ôãì NMôÊ (ú2=^>"@;/þ# D2<aOðIiZW> O%ø ½è¯¥ÃÐîúßæþ'L[`cZkar]+*-:5$A`‘y^P€z®Ê¸õßÿÒô ÿëÕŸq~C2p\‹~nlÊ#¶ä§_BGDevzVlƒµÉÖéþ0@"F? 'Xd[QPl{]j"çѢȸÀþýÁt¦ÅÚ#9Fe ™³¼«y‹£µÐþ1PJ+ÍåÓÁ¡Ž}zªØ¹“°Î¤§­’Œ‰nW_THSP^j‰–†STqWB ù-*ô!;Dh&9V':^5LR+ :26>R‡uP7/.7þ3B+ òøûÏÒ½½§§ÌïâßâýâîëÜÜé ôÞÙÄÚèê×êÞ·ÕêíÛÞùðäÀ´º´ÛÛüî#ú'N¤ÎV¤©®@@"7CFC41+#( ýö6RDSn\VM/$ û/O%Þ½:.<%- 5=0O—]mu?5%\7. üéçÔÑßÛÐÑúO@)=:\arž]†K\!,.óô#-?W^XRe¦·»Í×êÿòÊ«ÿ‰¿æêà— &\uSˆƒ3a§“½±%[ótdy, 114CBzŒ­ºÅÛ'R‚Žp"LsX^v—‹‘‚\W–Láha ص¿U|RóÃŽéøvy+ž|ãÔÙ Þìöî&=9J3Æ.Ö€…}h’™¡“­Ô¿Â¤’•¤wmwwwdXS–ŸƒbuƒT9 øíÁ+'!D6*+55V:0?-$.;:UG@("+ %" 684rreX&::‚Ž-  ûÉÞÉãðÅÎÏÕáßÙâôßèÖÐëÜñèææÑàëèÚÌÌÃÒÛáääêáØýÀÏêá   -CmÀì^¢Êø!*<0!*-  DU‚P~U/. *Th”p50M65FC4C6J;;j0F>C5;z,Ú1ÖÝ-ÚÜÚäÛÜîü5@N[Wb‡Éÿ¼šaEaQ-=1N<<m—›¥ÇúïíöéßæÑþûößâW~@bÕçÏK|¾R;¡ú Â,©a>CWA ë]kk|¥Ìæ ~v‹m¥l–~š«©kŒ3;–Ÿh\‘nîí£‘J õ¿ÁÙOR5(n<E)Òž§åPæöëZ0Ûä$Řâb¤x}“¡¿°ªÈ­³¶u}—”}tyqbi{“žz{ƒN9ýãl—ž‹{BOPD6?:>MP.F!O&( /C=L^L:(."G<,4E<#&@—R(òþ þþß믱ËÑ̽µäßÙîëåëßñ3ûôëÝ×Ýßâß×ÒØêíêÞíêÛÕÒÆÃÃÌÞÒÿ BT’êt®ÛùNB'9<6!*'%#1#&2'-5\j,#b*F;05(%-cª:aŠ}ZR%ZeZmsQqbÄxNOA0%ûØÁú "YÕ¼æÖÔü#ÿ*Xk•ðùèàÑ´‘™W-*MpHWf>9Wdeo¬¸ËóüìÙ·É.ai €}íõ¤Ã|b8ãÓå¸À¹ØÞ긥”iYbU.)>+E¤œ¶½¹°ºï0Rzª”®¯O²ªœ°±V 2¡‹“Y}÷[4Ìä"2B-?^ded€7BKþ÷ÎÏ£Ð5ßÄèô8NÐ$Óž¬×k›i§~‰¶ÈÂѹËÎt=w€nnˆtrno‡’hfeBE@ñQgb{¾ÓuTYYTcX;SD7!4x`92FLOF7IO=1+.:*IJ62.EQ\7/F%:! ïûæøõáêÇÏÅÉØË»óëåîôô 3òðíèÝÖÑÊÉÞØíðêííêáÛÛϽ·Éêä <KcËR™ÁÜG8DD5/)5,!,4,,2$.<H(LC7ÿ4>-@*$7gšI¥Y—ú‹qGYVWQQy‘'|@R`*->3çÃÚÎ $óÔàÿèÒË /3{Œ¼#²ŒŠjŒŽVI0]•cflE=C3,G¢¥ÔëýðÎÙæ=—±TwѺËÇNSq7 óÒ`]ÙÙß®}•f[JO42OS9Zo½º›ruàÝD“L’•@T¦§À½¾h  ˆ}‚O-»À}^ÖÛ H37j\}ej^ Ò͹ÜGÓ¸Û @7÷L*ãyª¢Jˆjæs‚»ÛÛ͸ÐÜ}1aklqtp€Šy‡\e]BJIÔðK^Qã‰f]=W‚j8G;Cø ^uW'=@.4FC:(17==0E3/8'8CKb"1$ôñÙôôùí«ÝíÂãàÊöîåë÷ ñ éðòòÚÓÍÄÃÛÏáêáóëèâáÞÒ½±Ìöó6ETªæFi‘·,!:@1%+IC.E A)E DA$-Œ0EM!jfx[gc…ŽŽ‰k}Ú±¦C”^23*H82.ÛÛóéùàðæìãû++&OIfs•©±¢’  ‡––vjx‹ˆ’sZSV_µß%ïUðÖ9”»dºêÝà~&1Á•„©±ˆ‹„f6ayŽ‚jnWx–¦œ‹Êè⪢¢ÊÓÇÏÜß<‡®c§z²&'llŽ´lB´rx[þûüV‰Ÿilj 3*Þß›®óÀ¨£êî UH”’¯—„ ½êáÑzÁ×ññöà§t_k†‰††€tzŽª™ŒzZE5óðx«]z™¬Ëqzwk}_8>Y:@Z…[ +=,L>eS;>2,/2#-%)1C"  (ûææ  ëÞÐÊèëâîèÜðÞÕØöüêêóýü×ÄåÖÓãíéàïòìëäêÚ½´¨·¼ß÷ëýçöý[˜«Þe{f'%F714 "1*%$22#JCµ™f0/9Š *>J3L77+HR?Ìa8^t‹x@ûO2-!#ïüáãØåæçÓøï$.(þgO~‡—˜†•‰ –Ÿ›‚˜©¶©©››‹{¬ÙËåÐ?Gü¶pt!f¶Þ«–hSookeqmˆ‰tnZmndX«ÍñûèÚàüãëÚÝAOYaNj`trSQ7BsjGOl\ öþûbrlx†H¸îUâ»ÎÝ_#³Úë-8þóã›»¸hˆòðáî茯Üêóÿö˜k††q€qhq«À­sD2Cï^XMœ¡¤¸tt¤•nD;A1CRxgL/+D2SMqM;A;82.14$9I**/;<@m"  % ýýúøôîìéÔÍÙñîÖâÜÐæÏÉÕù   ñóþEñâëÑðààìòïåÖÙ̹¹••ÀäíÛù÷îó/91ž&&åBLG2/5  8D51YSD(qIvO5 K?ÿ]=:FjL'K%GasmH' +)!   é áæ÷åËÑÙ÷îplŽ†œ«³­¤——‰±Éƒ‹•ž¡–œˆ°Á²¦Â´ãó F[ ùÏE±{‹@;§Š^E˜¨VSƒ½Ç¸³™t¶ÒÁ§Õ E;_HO?$##=gjoOa\`E0(%B<Ep‹` íðùì_roŽ†z7ÿ¶¿"îªÚéù#¸Öä#(Ô÷¿}Ë»“o”õæíÕŸÉ÷öÿüÏ•t‰kMeYq}ƒŠ¹ÅªlTSo6 îO>G«Ë¹¶wq‰³°‰bSA+7{yVYIkzFGMe,8DA>2(/;)*4+'(40F”%é þúñùüö÷õæÛÖâîâ¸ÙßÊÈÏØíùü  ÿõðúA÷áñ×ðßÙÓèñÜÜß¾¹¼ž›ÉÞêØùùéì%!$¨àá¦gn;/)),GGAa$E6&(7"D.>m8ô)6/E<0U2/ 9T7W&;Aåú1$B-<# öïüüðô åýáè/“¢Ì¤„’›¦©¤Œ‘—’œ¥’Ž}wXTl¯¾¾¢‚f›Æ  æÿÔ ÿ²•¿˜²Û†eTP;^œÁ«„zŒ *úÍΪïBJTpZ%G… –}llrWbcagDs‹hŒnnP\>T./A)O,/züÊÍáËá'7RzzyQ  ñ¹Âñà ÒÙö  Ý­ºÊ¿è¡}Š×ßÂèD¨w­ ýóùé¾’hJAVYtnyŒ´ “—‹§Ný-q•žÒåÄ‚€§ªzztP2Ep‰LR\¸¯GPA\SSJJG5$,1*BR-##)(L ûôýïî÷ ûëÏÔòûæ¼àãÎÉÒØäççóáÞç çÁ´ÃñòëöóØáíÕÏϱœ¨««ÂËèßýñ- EšfynLW"+@=+LCG=: /  #÷ó )·Y(-Rh*2=M5n)>6!ûT? ÿRüùåöR5ð5idŸ…{’š ¡Ÿ†Œy…¿±„’|vˆvŒÀyŽ‹ÎΙËîòÖ´¹š£ÃI*CV…Goï6 “wrcvVHF?PfÆÓÑÝ@,FXURS]†gµ’¡ibuPp‡Qwi|XFEkKr††\>S*D%CÉ»ÓÝû;öVrRÓÅÃfY&ðÞÙßΘ¶%ó |¬Ç°Ü+ŸÁ‚ Ûã ߧ€eYntbq€‹–™†HOh"4Y›Èʽ¯‘ˆ€Œ­­zek8,TV…enUYM`G;h¤€VJDAHTSQTW*0*37@.(õøãìõïîÝéÿóóÿíÌGÌØÛáØíüùçðæïêÜáÖÕ÷ìêö÷ÖËÛôš¨Ùµ÷çøæé(0 ÚÒõlŽ[dNt@E&/#2.J,%7) øôåí ù r8''6@)>-8D>t,9*%   *Y,ù^# &ñ rcWL;wu™sx¤£Ÿ—’”ƒ…—·®™ž‚q”•¦m«÷7îáî,ܲ¬^\|4z@hUsÀê{‰‹eNbG1%Cƒ³ÊÏÎèOUg]ebm•mS©Žy‚„NFI]€wvCL<,bq‘lBH46M&#R.òÕÇÛó=B(Ý<HýóÇÇÏ,%WH/êÏËëÈ“Ù(+?Àsj’®¬â5[ÉÊCòØë÷¤nb_nk_tvw‰›¢‹]Rm6$Zª»Æ¾Éæ©›°¹}bh82<_‹\bpSDHPG\ŒƒGYbY0SME?=)-+ %(   ûïâèò÷÷þãîùüíäðáíØÐäçØäóùêðôòêÅÊâåìîäð÷ßÚÞ¯£›³ßÍðé  þ':6ÒÏZrTVFq-/  &;ÿ!C=+"ÿÑËí%0 ö)3(K7.-1-&5WF0+  þ,E$8/2 ÑíùäÇ7«:/ QJqšt’ºªˆâ£¯~±½§š†ª¬­µž’É•º¬ÕÏëÓ9$G–¹EQzŸW¤qkXyqr¡îêÿ<]YQPhIPcWü<ysNfO%<‡ZlŒ{ý9üHvª”U0O;•g8(AGÍåígT 7\éèÚÛî2EheA)äÒ³¾å½)>hŒ¤Š–v}²ñSÁÈ¿Ôí­qƒ‰kVYnmn˜¤À™UD3B–º$ìéãȆ€‰ƒ}VY8J/…’s|_?Z‰NY__wwVVS*BB7*%''0ôãò  ïÜÒÏÚòøõôùúåÊñî¾ÐÐÛäíáçóÿöðêãØž©ëëë×ÌÐÓ×ÒÓÒ®Ô4ò ñ?6DI2ïãì8;7RPJTçöÿp%K|S'ýûá j&! ú$"IXm ÷   =CB þVK*$// ") öÚSyHóOh¥¼}…­œ–™¥£ƒ²Ê½½«˜¬¿À–Ïîx¯»ÚÚüþùÅÞQH"HSCggKviB]vsÒÙßØ&ò (%þå-_tDWQHJ<@/&=K3 ~²¬s21gLL(BQŠR2Wvˆb4å.aHôòà Hmé îü$@I=纕ÄÜÌþ:=>7ÅÛ»¡‹°ó1däÃÇàùýú¿ª­­tbSMhh|™¢–\D<kw >f@"Õ¹­¡†V†¤kP\AS_ƒ©¯bEh KSkh_SeeM13BN@:-'  òõ.ûæâ¼ÁÔëñøúþïàøìÎÑà¼ôÒäðÿöóöäÖÔ®­ÍÐÓÁÑÌľ»ÉÐçÑÝ&)$&  ø5UC@PW_>û÷çáöÿÿðB:R2) ëöõ2 Q5&."09Uô úRL6 þA'<!$)ÿüíÝK((Fqª¶°œ’–¤ˆ’¬»Ô½œ¡©ÇÉ°å‰Úêñááßç 4Ù»>M!+BmŸ›ptxNr•®ùØ%ýÎ÷þ .3ú@WrkTSo#;&ÿ!96W$hƨ=!?aNW-<DtwJ=UvN& OmY ñõ¶æEaßéêB/7B ¹‚ºßà "11×áÊ¡‹¡ñãÞÐ×è ú¼¡§¤}nS8QTw¡³¡KP=wrÖ*Fû½§›†nSŒ§_PbGP_€ª¤lGXv`S_t_>hk_w4EI4+4(*ûïõîÇÒëúüýúîÜôëÍÙâÐâØêóùóóùäÑ㜻ÛÇçÖݽ½Èé÷ãîî# ?  6/GFEGD7N<äåéLùüä%BQB"þ"î  þï)P    (ú(þ5$ ,#íáù*þ# ˆjZ_{²ÀÎ楓 © ¨”°«Ìº§µíÍγ¦´™[ë%Йƒ ?_Ql¯²Î/³ÊÁîõFSï*!ííÏóHEr']‹{Dç."m32/"%8Wbu{JGVhyr£‚R^Q3PTdwwPAgq ×Ýì%±1KHÕöþúmŒNIÚŸ›·óØä N]'>П¬«ñ%#ðüÚÓá÷ô°©•}ZfN,oi{¤§qbZi^ZÛ߶±µšT`„oiouWcŽqhxy\JU‹mLi`Yol_rR83$2:'1! 2êÿùööíÏÕæöö ò øãõòÚß÷ñèããåøàâètÍÍÍææÌȱÌÕðüCí!ú-$ 79(hRFJD::D;×ãè8/,+YuSƒþÿ* 9aÚÕèøIÛùüù õ ø þí #ü 2?~vt)_g£Òºž·½²®²ºÍÙ¬¶·½ÆǼí­µó2ÊÐ{xošUš \ܬÏBhúõ ¼œ1 ,9( =ISl¥F øH0ímVi885KRikz_8Pz‰5_®•__hVYk&B5¾nSKeRFö-7#àFaíý)!‰`W$2èØÃ’ˆ¦ÕìÚø#>Ï=½â"4/±Ù÷ÜÄž•¨®G9::kjw˜žaqwxqx¥¯ÈÛ›•luOg‘‹‹yvpOIQSblmSFGZQaudxke_N:0;$*3",9#öäÞÛÈËÅÂÓØúýÊèëåõÿëöý!éïÔΈÐÏÓïõäèÃåçöð ãØ ò %û .=$7@?4EO=Úè×è.+78qUb;Ë $$þúãè   þõööýý þõû øþí,  /éö C|y€T—Š¨Ü»˜¾Ä­°¯¥¾Å¢´¾ÉÈÇǽ{cŸû)áÐJID·_\"æÐ×%b+øåñ9úÐ=ÿ/çò / 1Rd·e,IQP"vXM%'42\gc;‰ƒJDunVYe_eq8,!§\h`T;7(<OB5Úý(ûóî5÷=82èíóÄ®»ÐñÞ BêÔæàù(15ÿ™Çâðо›¹½®M*=Ohjw•[nw„ƒl¯°­ºŠwUto|‘vš|vgF51D_fgPFD`QIlrs]_hK1-9'#-")<,ÿùÛ##Û¿¹»ÏÖéúÍîô÷ ÷áöÿ% îþ÷Þœº¶Ùò÷âãÍñéõæèÖÜëòøò .1"+=?4BI: ÏÒ þ$ÒA= ' üøû$#ýÿ/!Èäò- û  üø àÚ ü ÿ&M&"4 üÿùßá =–­îØÂÖÇš©¯ºÒʵ»¹ÙÀÈÌÁ¸ÌÒ®xw4ó“‡o9:#sZHVó7FW{Qw<5‹hF''l-ûªõíêùÿãÿ%^M€dNXoXj:‚YWW™r-  (4I@4IC[U^‹dR47%6tSP>Us]IG0ì3ð d&ôá!êä4?GBèáð54 QÄÁ N  õ°ƒš¥ºØáà ͑e0Hnlu€ˆ’pru‡••¸ÏÎv…gzŠš—pv”m^L1 1D_laPOA6<]mgWRZe]=&+"$-5&ÿ)&íÔÊÎÑÖÖ×ã÷îïþé èßÜõþý$ض¶ÇÒñóÚÕäÛöÕñæìì  ïìæ92/=.:@H:@G5:*üÕæËÑì=æàÐ÷ûõ òØÕ øºï÷òÛ ”  VJ)øõû×òòõ ûü# )1) 1+óô14Ix‹ —“ªÀ¦©®©¶È­’³°À±¸ÊÝgDÞó¸«C üLF;~’é(B˜oEMQ2rM7  :•äÐÔ¶ÈåþûTK6(è]e…uSiihm16 1 ãïû":R[GPznwª¹Vw}5,MiPvŽ”|‚CCEè(?q8/\//vj;OÈòð)2ø(ÅÅõõI*Ò¥{¨´Ãäï籨d28[r~Œˆ–s–Œq`ûIŠÞ¶ZGpµ”Ž|RC7"UVexdV[DGGDZi[laHRU&2üÿöêÜõŶâú  ÷÷ñèéáçû?7/[úǦ½ÂôñÈøÔ½Öïõêãûïõ×ãõQ#8OFQCgf<1%ñ øööóõÿöãûëîÕÂÎÓÊÅÌÿñ++ó7ûøõþûòä, &ø&#ü#X–Ÿƒ’“Ÿ¨š ÐÀÒr”¥É›È°¿ïÕ_C:^OÒÃ" ñäôQl°1MT'xp'694@26%/ ×ýÚÝ$#;Bw3ô $U^w{G,Qš}UT=cr*BNrx{“dI+[mRsv^\U7KG/8Y‹¦ªž•I<<1Dš: au}U Tp\­”a&ïÆøø$&6õ°ûU>,=2/ÏÇÁ©£ÇòõÙ¦|JDQGbx€²Ûtoab9@™M™”šŽsjU4487VÝðdJCJ?Q?YefO`Rfa30÷ 0‰TD ÿØôw$ÜÖøú î÷ýåúýâÁÏâHWœ ”ϸÐÏÊä"íçÖÐÏÙëêéúûûú 2"(^Æ—6%C )üýûþü ûìï÷õÚÈÅÔǾ¹Ä þ$!"û ÷ òïééìõä ÿø& ù $,3Q—œt€–§®·¨Ì¼Îy­œ¾§àÚÑÆÀ 7:FÕ¦  $<Œ±çfyk#uk$!*EHIW7ä% û ôÄð#83 *v ô06QfEfbBMfiZBHUbK-EoŠuxZJ2GS>VYJJb-fJ2A_„®Ê½žSEiMN›Ug‡„%ðTxvœHìºó÷$?æ¢)k[RGA3îÁËγ¦¯Ôô áÀqIR_Sbcz¸ü¡€rM[¿B7äyZ]¡—‹|j|::+VãóaMFJ<C<\bWLcQ`pL;å"-,Õœw, Þÿä'q¹ï%ïõþÙ÷ßñôß¾â÷èìý-UW[#×Åâ×Íå ïïãÕÎÏõõÕ ò õ"%*XÛ©?1@1DJ óòñòôùòîîðöòËÐâëÐÔϯ ÿ%þ %þ( øø éÝé ùÿ ü ÿD00K[r”i¹ªžã îËÀîέ¹¾¥¶¥‰x ¬éWu|®/ëEq»8jbPbwi^fIWM€ŠŽh. $ôÙÞåüãòýp^s|rT>//~À«‡ZNKp'  3KNBjntSA>AGMEbDE\6T˜¬º®¦tpih_yCLAYo*45QŠ^[Z7¿àìêæÛç_`\[)èéÔÂ̼Ƚ£´öüûØÉw3Gzz€vs‘ØgqerzÒ°œyTueaXU[L%%@7C-V,F;:;C@FB?D?U@F@@> %*qÒÕ¤D&´¢ê'ÖßãìæÓÇÈ¿ÊØÕùíðÒÆÉßîÙÉ®Ÿ˜Äýïú–™¿Äàýîô÷îØÐBìâùïûþ4).("70:HIA"4A)" üìæìêêíïøöáÏÏÍÒõæË?*ý    ûìûõããø ó ó #öðø&!3D–”‹‹ªËŠ«Þäÿäó´›áÁʪ¢ œÊ¾‘¼üdë,T#²ºrOch,+R‡¥Ä—_ 0($!Ö×Ëâ+ >f`OkJVR3ÿ Nm[A.×ì <r•GJ2\ž‰ev`T~„B3<TKV_HJOU  ‡“v…sIdUT3*L¥…=2Dfloi: ù ùÖQjB&ؾÎéÕÐà !ÜÇéóæÉŒVNbah|¹Õ„TJ„£î¸~liGT^aRU=Ud[.I?terFGFDX[^P3<!1,( TžQ ,ÿÉÞÞÿÄòîôÕÅÉÌ®ºÚÚàÝæÑÈÎßÛ½œ£¨èÐÒÖ…¸¸ÐÙåüýõæàáMÒÞÛ þ ïò þþ"I5)%%6I3JG 0:2 ïèïäáçõþêɽ»Ìøæ¿6èýìø  66 úõûïøòàÚéûéþé"( ÿõûü)K™©”¨³½š¤ñDðåÕŠ|öвʞ›Ì5rþ¦˜{–m ÐTy±R‰ÓñgZ[Lôq„Èή…4;æ%(&Ðàèâ$úKfFGqUb[7crY67×þQsE‡<_\w±lt`fƒqA/8SHV_]9YNrŠ‘“ €‡mNdOL<í?Œ«}bcjTY]V@7C ##ÿÊðHV9àÍÝòÚÕÝ*+×°ÜëòÎjXRqtw¼Æ„QN¬ÉÙV<PlKEOR66KktX+ER~P]OSSR_bgïð6ö  eœ.ÿðð½öðùÓâúæñÏß×Ô¹ÅãÔÔà×ÚÕÕÔо‚£¾G<=×õê£È¬¸ãýüõããæÈïÞûéïà×%‰* ,,64,KG(7áí ìÝìïøìéîøÃÿí ,%ö Úþ  øû÷÷êäáãÎéãÝæ æìû [‘‘»‘ˆ²‚dsˆdŽµµÐЦ«øËŠµ©µN3µŒnms‘ú$xéHX³‚iU;.%%P^yÑîÄpP+4 âÌÁþ   íöïÝ4Y'F)2KŠa+w‚|a!,8Sv[\HSFI#1=HGELgdKSWd—|j\thfbeL2Pjl‚\K'"/#&%%)FÖ RAÓâÿþáì>0ÎåÌïã¸]"SG_…š—l^\åèà{Ÿm 7DUSb#(BDP]<v›š¹–p_ef]KñýëñÖêùù   #(ðåíùùÕðöÏâû àÔã×ÑÚ׿¾ÄêÍÔÔΪ¬ŒµÒ÷÷åú÷# ÛüóðóðÝæáòú øûþ ãòò8!2<J4P=ý!&ãéÕäÚäõ×× ààû ʾù   H&úþûäÞåÿàÛÝÔÔÖàØïæãõ  õïþõòì  |£Ž—jj‚jhz}¹‰}„ˆs˜ž™Á¦éÏPú„:ûÈçó‡ï_<D=71û3@L,F"„fÿüoxÚ‹¦ÂÇäåÛÎí BY.,Q+SN0$-mqL)CvTY—jfh5FJ^UG5A@<MIFadTMWLm®zD}qBYkk8("k?]•zZCäÿù((%"#@/ !*"Þº·ÛÝçÔÊ­ÆÉÝܵpW@/8-xpLP@SåÂÿrl“@)X;5_2!>Vure¡˜Ý•utw`Båëâ ,&øõþóÈÓÕäÿäóçúÅÚ×éøÂàòé:RÅÖÃÍËÈ¿ÊȪÍëÝÜÞàòZžTÈÝÛÿêÚíéðîø û íæèâÿ!&,=3@ ñÿûåÖæÑÚ×Î ä¾Ö   þ•c ïóñ÷èâð÷ßåÚÒÏÔÝçøïïþïìõõõõ ö| ……gjsdXrŠß¯•„s°¤›¹Ô è=üát‹T ÝóùxÈk9CV:#><3=08JC'EFÝ}©éäøÞçõ$R\2FzAaT6GZ^C<RdZe«Š`[/XdsgYPPD=e[RaaNJWFX‰eAnbEYkqG$F—fq’sT=ìòþ+(%" (,  ûÆ´·êïùÔö¢´ÒûÀ¸ÀaHP +)m^RU9;¡Äªàqe6=;R2JP+'J_ru• ž§†~xu€iO+77.ûûé+%ôìõðíäîëú ÊèýÙ ÝÔìïã¼ÎãïñÁàÍÒÊÇÂÄâÑšÊîèÕÖá&‡ŠJ"®ÜÓþóðÝêçòû(öÔÓ!#606ñ ðûìäòËÅìæàþìÕþöýý ÛaxIHìêÜíÿüöåìëéÛÕÑ×äïãæõòïòòæøõõ"ê g‚jp…mjBJ{—l…ž¬ÏÙÓåÞýÂÜ ö¢oE+âæåç?VÃL<q€YA%4&å(þåáæâõîÍw–¦ÍÖØØ8ï¤ARAJ.Ot0KM_e]bUgOSg+‹œ—|v`9asYPAJh_;Tm[jpfJTOC0CIEfh_ekS7VŠ…vI<82ÿ%1+( ï¾¾Ù$äàúóÌ÷>îÈÓëxL- FQDmnMROn˜¶£_$y±v>8%-\hlx¿Â¨‚˜„q_`_^RO[O+." ðÒäøýí;bÛêüá þþéÑÎ×ì!"ìßÒÌÊÓØǵ×й¿îçþêþíî1äñóÛäÚ×û ø XyM4+2) "<õùü%PùàÑõãéûõòöüóÖçÙñä "3å0KÁÆ÷ýÒÞÛñúìÏõþéàéõïþõïÚïì"&N‘paˆ:=s‰kP‘‚¬Ï»ùñãëà¿¿éZ˸¥È¬IgìùÞñý²Žù°ýÈÜÐñÈäÞɤ§˜›v‰©ÖZ\ȳ˜ê!84Û^vr90QZtnS2;,+VMR@SK$DJVPJSeS@nXp{hKI[ktwhq_wzbY*WpfK?:Dá 3%@"ëõ Ðé4&Ü$åü -ø•Q)`L<Y ’Q”ÊæÄ™G*C7ê M1Nhquehv\q^wmLOrbJVVJV>J2#5þòÚ¶ÏÔòûàæòì×àòïõ éû   6÷þâÐÃÈîѵ¹Àéìðßß[H-çëéòäêðóöýþ  1ì  e°cSD( ,!3# ïê(ÞÚàøÝãàãçÞîÿÞîéùèÔðÓö/ÃÒøéàøÔéóöêéøìéøûþ õï  ãûõ(,Q‹^UŽ[Uvd„ph›¦«ÁÖÌÊÐÑßævʺµ³³b‚núؾó<߈ת4 ïÍå­Ô´À¹¯šŽžˆ‡š·bp—¶»-9 jwoB/^tzŠh  )V7%b_j^e]BZY_\Y,_kXIe[vuqWLOix|ht‰nkkG3RkgZU5Ýù0M'îÚø üµæ42 ø-Ìõÿ##û–I#(†bQf°¡Ux³Ó£Ÿm%,&ôØ D"Q5/NhVUIcS|U:L`SGSP>GVG8.4þïÚÁäæõõàéìãÝûïïõ æõ - ôîßÀ¶Ñ¿‹³²¸éï ëê =:0ëðþØ  òéêäð÷1 *32eG2#þÝìéÚÚÔíìÝ×¼ËÔ úÓÓÐÛûFøÛÉä;Óî±ÑÜúéïæãðãõòò þþõò þþ1>QvCCš‚yˆ¯{‡¤°»¾ÁÈ\ÈÆÓèáß´¼9¸q?1\íÞæ$¥Ã &25×áý‰q{{“…ÃܯËcbQDSÙɱ¶ÞõF‡‡McruY‚hD3'%Xc<Ek|˜•YS|zsgnthpgIMMjˆ…uwu^Lg€‡fx‹b__*.KrsWE êÔý&58+-Äûþò›Ûúý ë·Øô Û!Kk*”M(/)ùÞ|pš‹FHV›OuöïÛó,,"WDJZ;K#B<beb%GEWcTH]iZBD,.ÿûæÔÚ öäÛíóíêïïõûþøûþþñòñþþÓ©–ŽÀÁÜýðú÷ýø÷1úÎÞÚÔíòæÞèðùâò@gpL+ ,S9 5& íîæûýäþêððÏÚàÎÚÝãøïäÚ/+ þÜÈœ¬ŸŸÃî ¶ãÎÛÓÐÆÉòðòïþþÚà  1";Edmyš¸¯—Ç’ž§•ž³ËÅéöýÒÔÍÓbW8kPXÂcBS0ëÇîl{• ü  ÜUqz«­wÿ±ª-Nw±ÎµÊ×Ï Eoff]g~f}jP%ZG6_(]l‡ŠH@nqoimqzs^;AM”‘nuvdcmpel:nwZA$3c_(BôöÉC[19íñõþ ùºËæÅãô¯ÂÊêù ØËFw¡TŽD%mE˜âªVK=0=4‡r?6ê /PL]\S6&AoTLP2\Yntet‰;h;=1)ôæÕÕöùíØØçêÞøþûøûþÿ÷Úî÷òã”q‚Í÷âøæöûúõßÛõÒÏÝãàèðõù1L4I4'21  %&ûýøúîåâ óïéÎæãããûÕó )ŵ‰š˜¤Å죺çÏÝâÚÉÆÝþçûøø  þæì 12?^” —¾µˆ¬ž¥¨¨®®º®æø0îíØÛPky¹­`‹ph2ÑÎå¢à  #CÂml}t£©}”©¸Š<c¢Ç¥²Âº#TKQfT_kjTR+#B]ABM*rxˆ‡umnpqxwtƒjDJVˆš—¢woydd^[ec[nzuJ3CGïÇYsF6/ñûóìóä´Èéàéúå¾Ñå%óüØÔ-[’›Gv2NLsµ¡RD;5,H†¡Y:éöñ>YOK\M*>+4AQ{rUFbZciZfl0T>17  òéØÉÕãæÑ×àûþéê þû ûìïÿúæèëòø›…Êûþêö  ë¶ÚÝÞÞ××Ûßðû!%.( @4þ$)/ %(ìñßîàæÎqæõïÀ)Ï÷Äþ!âÐ*¡‰¥¥ªÊÐÁÀº³ß éòùêââëì$ôëõ"$&$%1>|y‡’¯¸s´™¨ˆ¼Ô‰®¢ÓÔРÆ0;„¸ìò¬—lP ò¹÷î)ŠäÝæö@¹SOu–¡›Šu‚1 B:Í¿zD—ÞßÊ÷Fþ G(6dI:/P]WBNq† €t‚=gs„~}ƒxIVy¤¬±”twXeQIrlzwh¨>%õN‡+1U û33SJ"C-!ëæ외Òýÿé>Y+ 0þ€¬FÓ6&OªhQYOJG8c±ôÛ·MäÙ+NOEE5@EC<]`Rb\[USTb\VASD%O;>÷ýèèåÓºáé÷Ýáÿ<< äÊÑðâãÇÛá»È£‰}µê -åž·ìéÕÜÕõÞü*$)! %'åîm0'O mþÒííä. ù ÝÎòÜÉõEþñ5>D3×ÂÃǹ³»Ç½ÈËÇ?( ûðóÒúú ôô%  ',6CJpp„’ÁŸ²——µ¨›žš¡ôû ¦ù no„^¤Ç˜Sù×éæ÷þva^x±èÁèö+íå‹?Áߘ…Š~D?U[Ž»»uq¡Ê±ò†²ê,, 'QT`cWHas\D;@VZ{|{Š‚XlKv‚•š£Qe…¥«°“ouhu_L`WmbJ]5,+qQX)Ü VV:mi3Źȑš³·ëVe\je`8 0=%SG©kg/).;EUI6U{ÔykÒ3óëo E^roQ:2?ZccCJPDB@=23GPPMdXCa2÷ëñîåæùßæñòíòã-½“ üìçëõåÌܶ°€–¾ÜÝÎ(-ñ䯧¯âãÆɺÒ/!,9%÷!øþôûûøZl?õ; ,K=0& ÕÕøàØä ÷8a9"ÚÄËʼ¾Ä½Î×Ó 36 ûíêØ ëúý-F  *-;AFGXa‡¥‹x£¥–»˜‡­›±þø©ùrz”u—–ZÕ6ûéÅàôÿ÷x‹K ŸŸ³šÆÒê-Ö´mJÛ憕‹g^e`x¨Æqg½íÕ~ÒüA^SfNC:t•b8)<iW~ƒ‚‹‰Ui[‹–›Ÿ——Šbq¨¬°“qwpk\N`ZqteQ;9@p{HP ìë(*baXZN­ÂÆ¢¢²ÁÕòBth:DK+,": A& Šdn)2;5==d]:X›”{½% û/ERzt8T_T6W]=\aDACC>?GMM;LF7J' ôë÷ñîêùÙçòïûùì×*TðæíäïýàËÄœ²Ö›Å*$+ ú ã ª­ßÔÉçÀÉ7;'29%ëò $ IV5úóüP\_]|ûÿØîïçéÚñ<J\gòç÷ÌÍÅÜâßØÑãíêßÙîæìòòìãÿ ÷ <L$2ME?BKzzŠ‡–—¬˜Ÿ¬œŸœ¢Æ¯Îô÷ÃÙ/T‚©Î}9Ç.éû#\j6ĶæÄ”£¡Ûæ´vks½ä ‡…p{|“}°­·§Ä>$ #ѱ& õ*d[1=LVWLZK70=XEu{uu‰Ifu‡˜©¡¥³{oˆ™¢²°­˜‰}i^\Zlr‰”©rSglbÛÏ+PA&RX?-êúØıÄåÜüS3 J^7",#T0ö×2;*&,2QrimZ/=‘U‡~ñpV6XTC‰ƒg{a39WrOaW\adqi\SPMRO@5ôîôîèáíÖùûøïɹ"O@(÷ýßÞæïïãÙÙÔ·œ±e³²Äò 4ûñèì* ø±¬½ËÚÀüù ø×Æ/$+úþø ÿ4:"íö=íéî Û×î-ÄåÇîÛ4j#åy"ÜÕßûÿìøðéòùòÓæïïêù ú ÷ &9;+(MxTi¬Ï¢“ež›ÁÈΠ³ÝBS ’‹!*XXÐtxÄ‹S÷ C$5Qay_Jy¡°Â¤°ndX¤zɲ…jz«…Œ€·¯%%;$/ðÉ$Ùî6v‚9[wn6PHWU79XG/`)GYˆ”ª¡¦®Œ«¶®¸´¨œœŠ]{yogmŽc^UW\S9Í#øòø($%ðôºÁ¸èÊ¯Ì -\\?T=D!™ 4?æE%%(-ÔÛ§8ôCÅñè‰se?ŠCQ{Ñ°”–i4=pÒFfZ^eh_WPS\>:7îâëúýâÙðùåóãÚÑÕéíÕùñâåéìßØÙ±¢«¸íæÃãòïú íâÕ¸µ©Ù™ÅÛ;Ò´³Úäõêú 1ñïè %$<ùèÆæ#ûâÐâÐçÖðòùR† ÞçÉÜàÛÌÎáäñù ýüøìõíëñõç úð÷  Üôý .@lÏxr[d}n¨l]oŽ€{ϸ¬^ÄÂììhµ[6ÓòÓ„£™·/?¾uû"2;\VbhŒ›žÎÔ—Pg…·±Ë•…O|f—X>9F Ê3Q]8E$X+;>=)ZtvbC?TBD@7[N='1egg ¢©´¶¯œ¢¿ÀÃÁ¶®«°œ€}xy|mf‡‹[d(þ# îÍ éÄŸßÊÄÁÊê.* XdWR#%2DD^øú¿S'¥V¿öÙf=KNYÅ¡Z9„˜¿¤°¨–}‘{vpfjjkii_TVbrZ\\nn(+  ôîñîîüÛà×°ÏãØûõûøôùäÜ˼°~…—“·ÈáÓæãëßíñí£µ‘­•Æº¨ÈÎç,2*4ýÙ -Z;Ds@( åɹä+ÝÓíÌÆãô   OSôÖÀÓàÅËÍÓêô üñûôýûñëäñûä%ý9 Üú! 9‡zÉ°›RqZS˜`f‡Œz‡Õ¦‘|®¤ºýkµ7ÅÐ}€oô!¹dLÝ.'3@X^§çáÛ¯˜š°–Ó—WZˆmŽŠqVC²Ñ <c@<Cð >9BOEelkQ+3a4'1:T‚fF#C\dvŸ£¨±²°£ª¾ÃÉÁ¹´«± •„ˆ~|~o\†~Žpo9ü ,=7Ó òÇ‘±ÓϵÊó54/[[OM0k7 íéÙ¥O 3zno×¹ufn©{^T…“–­¥Ò­±®’qq„oyd_x~b]_eiZ_Y__1+ ôñúúÿàèà¹ÏÔÍïîû ûîòôøóñØÏ·›‡Œ•ÈÒÐç ç#ÖæÿÆÕËšxª˜ÀØ®´ÈËÒ ;3;,9Iôô*-'0g ATƒJ>äèÿÞéçäãñòÀÝÍ^…XͨõìÔÑÎæ¼ÝàÞúóçêñøôþñåðâó *)„Üú  3G\BJÔA2>T{Œ‡‰Œ•ŠŸ£…{~fŠÝßúò$ø²YZ"&3-þá%&whJ)`Ž¬’Ý:±Àþþ̤˜n1‘̪“¦ªª¤¬Ãú  2d£¦ ;,R]Mr[U+)/))Eqnv4+\YgˆŸ¦®¯­µ»¿ÅÏÍÁ¸±°¥ž‘—Šy{ok˜†‚veEÿ+H?! ÷íÁ•Ì¢º¼»ÆæXhvgYJîÔöíÛÞÆ—D%1~§Œ¤¤œ©†ZRQµíÃÛ´{‘ÐÎTL¤nn”zrgcahlniZ`\VPD:% ó úôúúô÷÷àâ׼̿¿ÉÈüâËñ÷òåæûçòÝ·¼¹¾ÊÜôáô øî÷ú»¿ø»ª€Ž­Àçáϼ¼´ø#!&-9oFC7\-RV,.41ÛÜƾ±«ÔÖäðÔ·Û8=Z‘øåªÊÏýÌÏÙæÙú ïåðüõý÷ðò !ÿîâýý÷÷ 'HGV<P'I@]Wlt{wk•ÁÇ€qRjE@×Ô«äò%Õ]?p2õPe9kaœj_d‹¤§·¼¡ª¥}v³Ÿ·Œƒx»Ìͳ±™š 7$ âô³µóíReNUR<"@C/LQ\€ag##o]l}ƒšš¥¬®©ÈǸÄØÕÇÀ·±ª¦žš‰mlfl¹§‰ykZü!Ari'ܶ"=L)ϵȸ»³±¯¸MqpbW0ëÞÛí碧‚X/;NC3VlpƒHF3`–Ë¿ž´¬Ð³ûòÀ€y~S\gddbllcWfSbb;+ãä ôôýåÈdz°Æ¼Ôçò'ñé ïíÞäâÕÅŸ–ÆÈñýéîÞèøüëùïôÒÃœ ¦²ÎÛÉÛÏÔàá 'PTF¥ØjuXFqEH(L>}͈=áâ²½›­çÀÎúÚæèÖÎGFôÔ÷Š¾ÏÍÇÑâÆö#20ìÝëýÿòì!ö! ÿÒðöíê4NB7G0\2l¤on‰¤™w’B&fI/VR˧¸ã°ÜµP8; õ$‹ú^òHq[€vž‹àƃ›©uz¥­© œÁ“™³½±¶¨Â*<* ÿËÌ ÏÄÜçPgUER8$QLI[Z\^o:<[t‰—œ §©©ÊÌ»ÊÝ×Èø²«¥Ÿš‡jice¼°’vh$ RnhÞÆ(FU‹³ÇÐIJ¤£ªAhdZQ%éÒ Ì‰¹€V/284 ü *P3 )[À0u¼³Žº°éÆŸ†kzDLauv_ll_WiNek>% %Øß ñô ãľ§§Â¾ÝÝì ââ÷ñÐÙÉÀÚ¢–ÕÓ÷÷ãîÓ×ÙÜéàóöÎÅÛÊ·£›ÙæÂÉãõû% JO(oœM:D8OIi%7.»ú(æÛżïæãÔµÜÛÑÒàåéÈåÆÀŸ½Éöáóê úúûñðö ð5G;-öÛäöçö#DI9H"77u_•²š¯ï°rilbEt´ÒƸÁ¦J¾‘ ðÁÆÁçôW6-25#mšŸ®zgæ®r…Ÿƒw€”¢ÖäÆš¡¸Ä¿ºëÜ4='*" ³Ð­ìåÐú)+@E5.6[o}p…X›¤²gxn“–¦©¶É×åéöíȼƵ£›‡…|rlbœ‹m`pxF)?O>NH öµÆ=F°±óҸīËù[m_cS å^).Ðx€n2 ù  õ†óXm ³À®³Ñ°¡•¡•eYDwS]{HMYSUY]TP  ö ô÷ôåþöìÕËÍËÛùôôÜÜßñíéæѶ°ŒÅêõãï×Úæõõéìïæàææ×ÂÔÙ×¾ÅÝ÷ñ34446:MJ9CzbBSZBJKLXC;ËÀ´öíä,ÏÀ°Ñ·ºí3ÉçÐÆÃØðäíùöïôñéñüöð#Û÷ûáðùêÿÿ1(-Kú;“•žŸƒl {ƒ–xoeYk• xŠ[DGZC¤×ß¼ÙüøZ*&DBl©Æ®}• Œ^IW|—›… Àøå¿°u^æͧèìüü<9"RD ÝöúÔ³Ùo_R?QDI^dfaZmO•—–––q“–¦©«ÃÕïöòåËÅIJŸ—•…‚vf`Vudc‚X6?D=R0÷îè.=(ø" »¬ËÓ³¡À#g@ûÅD6ú}iu0 1%&;0÷ù8–ù¹úóÔíA ©°¤††žžnwŒž_KW-A\\bc]J> ÿ'èâîëßäêÿùê³ÅÔpýãÜôìèßñéìã˹ÎüøòÝõã³ÝïèçöùçÞàÖÌ××Ôéò FC=63L;8Kc\ble`lVH+.G¹¼ÒÛØ >;ÒòÏÔ±» ÐðÕ·Ïäáóöùëýõåðü÷öîñ  0ñøáóùç ,,8; %<®~}¨´™|—{“k^dšƒcl^TeW3^•á³¼æë'!/MBw§É¸„¡£Pcnp‡ ¦‚»éÑ·¡i]Üøú !ø 9+ôñ¸¨/*c`RjV[vbXYcgN”‹~Šž˜|‘–¦©¦ÀÓïôîÙÊŽ®œ—”‚sicTu|acm1-Q*3V4+ Ü@MA4é#ú¥™ÄÔéËÅÎã8=Öô:1-ó«{{.+5*Trc @š÷°îä±ëWˆ‘—‘šš‘v‚zmjy66O^fcZB6ôâèúëÍ×ìæàêÒØÿ êòùëãúòìâóåÖÙÐУÍðööáüðÛÀáðëíçäÿñàâºÎèßõ)..199I2GtT5T~nefA644F_Åæ û"æ÷áÁÇìûñäÞ®ØÕöäóäüñùþúôãâáêôùíöüÿÿüíüêêù ##  .1 V`b€}ê¢wƒP?>…òÌa[pRpxY-ù§½îñÛùþ@RL\~ƒ¤ª•vRe—·ª•¢Ÿ¡þ ì·js¯»Ðç!%) Ú´ÑűÙê±ËäD-SKVF`ULmkinn79“Ž{Œ’‰‹‘–¨¬¢·ÈÞæÝ»»¼¬ªš‘Žyyy{{Zx“cSK,Rx!Uvb›GñI[t2çÏöÚÌÚNEXÕóR!@F9!,×M;4B5fy¯[0T}ª³¦Öé—qŠ·¨ŸŠ¢Ÿ‡‡Ws~“ŸP@[L\\VB9  éàé õà½ÅžÎÕËÉ×ÔÏÎìëåìúúòôåÜèåèÊÊßâúë$&ööóÙôìÀÔéü"1;(-9HKOLRw¢_il_Y`JHX[[øìøÀ³ÏóíöêžÉäÀºæÿ+ÛºáÏÉáöçäóý÷îàÓáöôóû ×ìþ ûáÃäùÿðïö. õ97eihtƒ€M#/P_`¼“r@x‡Uc‰EüÙ¯ÊÓØÒÞð-G K•ô“id/j‚¹¶¬¸ÐÖ ê Äs6²ÊÈôîÛû+,ÁÀÌñüÖ²äùHz`c2ZxZ_fqkU'2?uO£…œŸ¥ ¤µ¨¯¯½ÙÊÆ¿®ª¡¤Ÿª–spy„xQ–¥|fj\<{i_‚‚ˆ‰dcXTaDÎÌðøÎÔ%05L!0MEBY& :/eÇA'HI:9k”CÈ~i9)ô;k˜ºÔ¤paUvyvŽ|š‹É™iy^OIZfToy74  ôÙÊÇýýâ¯ÔÉ´²¹áÕáÂÂÏíãïãÕíö ÿöðÏáîààX7+ì+%ò%)íØÌÞßÝ#&`8[Fgc`oinw{`VVœMEdF¿æÝâêîëÙÈÃ̺ºÔ½ËáäêíêáðóííóõúúñãßÞêúûãò ûþïóáù  ùêáö 7ëÈø.XncZW:;Dn“×`BQz{ž“ûâ¹ÊÕÕÒÞñ#ð6nAØ|ƒY:cz¹¼´ÀÛë÷éŽVMÀÍÀ íïîû1@ÏßóÿÐÇñüAxdK4bqikl[`fU#Jzf¦ŒŽ›¢¤²¨²±¼Ò¿Â»³«£œž¥™ysyuM~‡mdn]QuKVŽ“Š€glZL`7ÌÒðæï Q(W3IiC>M47GûÐtYEKDG†›³ú¾xB/ý8tÊÄ~t~_p^Fgs… ‘‘j–‡omO+:HK_gX.+ ôëåååëßо×ÏËÍÅêÔÕÔÿÈÒá èñãÛíí/áÉóä û I:=õþ(ïòöÞÛÀ¨åùo;SLymTlrWpet`80“A-[R@žõðå÷ÍèÖ'Ðß­“³Ã·ØÓçåôíÞÌÉçÿÿíéëìýýìîääöùóÿäêíööðüöùðØíðêæìþð%1jA95M­˜•ÍÌk^`j¤›kh,ëáëâÓÖÛÒËÚ òâóP°¦Ê´”YuoƒŒ¨ÔÏÜåþ÷Æn`X´#ô%ν )Kìû2âúþô?I5(Z`Y•gC[^aAÿ$ok†¥—ƒˆ‰””¡£ ²´·±¥¡ Ÿž ‹–›˜‰vxl\KHatnTiZ*`™–~pde^NFóÓßÞÎìT„VVt7Mz_J5öç8ןœ…>JfpNŒµjdC0 îð<9ˆ~h\J_qw•›’o(BF.?JADK4%?- ÿããõãÈÔàåÝãõæêÞÌ×Õ×Òîÿîâêâ·êóöÿÞ+é"="1" 74Ú­ôîÙq0fƒkJIŠlXX„wŠ80-A9LU^PïæÑ¿¿ËÂ×£ž°¾ÍòøñÜ ÛÕØÏóðÞõëÝýãåðüîèüùÿÿöùùíäóüùöíãìé ê 1.L"GQiužŒ„ÂÑs6SœŽ`1õÎÅÙßÒöÿÜÆÖöíW©Õ’¿Œ68]Zde™á¿Àž²ªzq£®Þ2â>ÿñ êíëÅ×ûï1  Zlmuz.IIUfR7fGbƒ‹•š{‚Œš•–¢±®›™‹†…€ˆ”ŠŒmxuzBEvkS\::?}r|wFPLîäèâØ.‡ekpE=@%üóÃí˜Z¿xCL<Nq~…“œ|.=='"$(pŠ\ewtwª›¡q_tneIUN '?.îßâ îííÚÝäàÝåÈåÞóØ×ÚÒÞ éF7þàÕçÿ#ü5/", JGÝJ,ó·¿èè:K3Sruqv‹¦'JYi2Kx&!^.@,ïòÿØ¥¥Æ·¢Æ°›ÕÇÐëß ëüÞçäÃäáÕóÝýÚâíùèßþûû õóüíðöçííèóóÞÜë ò7)-=I.DK„Š§¤¯¶³s=Y‡PNLþéÖîðØåÈÑòìj§’{HRVlx}ƒ¬Ø¹Ç襣ŒœêìóÐúóø-êÄÚ( ø ,oQ…“R4CL^fCVNVq‰–‚|‰š“–®«”›—“‹†€‹”‡†yj{{x?HvSAy%+-vxsOD-ûæåñß÷!5AiŽjxf)/ÿðÉ–Ø›™@¼±L^?Sl|ld‹Çi3VV0 üü0%7guvYenht§¡°qSknkF[9õ éÖÙý ÷êøó×ÞïÐàïãêÞ"íñéÞÃÛü ,5ü,êÌÌáù ù)J45DPãG8,ÿ°»ïÖýëL\ZSŠ{w’–uvŽ0Si\}¨D<L7=)#Aíãã½°Ç»«ÓƱäàåÆú[ùß¹ÐÀŠÛÒÔ³Þ¸ÏáÝàéëßñ ýô!ô íÊÄÖñýåÙëó òîô×ûå4 Jqa'Y^½±£ÊÁ™†0Ifa-n! ìæ å4j|æáÓ¬Û߬˜) _Š´ËÑÁžŽiˆ‡m 2ö'Ú¹²:1(2+þ0B")D/5lS½Õ5()1Sy`A``\{w}‹‰’¢–Š¢ŸŠ˜¥˜ª¡r”™ˆŽ…ifolBEb@VD9r_m«ˆVõØðÎÎï4,ó¥%vEîüü!-§• 8f<fÀûqIWM?]a›x[»—K"8ú>>yc>aKIJVa¡¯›Y%?.E30 0ÿ÷ôí½ç 39!ôôñïìæòõé×üýüÔ×Âíïø÷éòÐìØÚááF8#à å mU„ãÌѳ©Ïç ï>\[†S³ž¡oQ?KQ6EH:Ztk;#&1åä¼áŤÀÓß½Ï.ÃäÖ—ÙÕíÜÌ·«Œ™ÉÈûÇÊÁÊçÚéåßæõûûõ þþøÕßÄÄâôÜô9'$'úI6a0!O{ˆ£¼™­£’‹wmLuX%Ú c‘Zž™nIÅ«ÄÇí¿Zmdtpž§§ÖÀŽ‘^ƒ|£ÖIjâÓ‹¤Ê UE#-+I505* %( a]`Qx|(>:3C[Eqo`jXdl‘••ˆŸŸqŠŸ“…€ˆ––‡|gdjjOUgFM/6OsSijaŽV%ÝÒÏíKG;ôê¸ºß #öây˜þ“¦ÖW6S¼¼dJVKGy˜µ›²ÄZ\m3ó^_PQH=8XsˆŒ•{YW50# ú   ñèöÕø [þþøìéòþþïÚôöÕØçõà.ⵡÉÓÎÁöéê¢^ü*_â‹K àµ@K  †Óï× tÝk_VVZPAYke}J88JD=Ѽɺ»ÊâزÍñ;ÎåÜyñååÿÛØ°¥’‘ª³ÝµÐ»»êàòëÜÜþþþûõ ïìÆèǾÜßîñ !##ñ6. )mŒ¯¿¨« —–¨L`%÷ñ2eh³r>\ÝʧË~ÒŒ·£”´·ã¼š£c…„m¿Ê”ŒþØ¡ÇÒáaK ()B3/,) #bRWsV9T0CP1#}lWdFgru‘’Œ“ƒœŸ_xžrˆŒ‘‘„xsddgj[ajOh37IU5t|dv:9ñÚÒ7iOAþéàµÁÕÒAZjÔŸ ¬êÐl׊OPOGIy˜¸¦»šUŠ³q*&ÿ9>U_Y964Adv‰”Ÿ†YP2)÷  ñèøäÿ .˧ìïõéøþøèòò  ÙÄÊêòêÛǾ°öåÜÇÿU.*6£Œíg4ñun!zËå°ûƒ¹°\\\VQ_Sn‰†wA2>SNK¿Á´éåêÜÿáþøÂÚË(;¹wïéÙÛ»ºÏαßʦθµÜóþõéìú÷ôýú÷ë÷×ÆåÖÓèÍÄ3,&$å M]a~ŒÏ¸ÙÁ· “xyXSè ÷0I`‚¨êâÃáå -³¢˜½Ëåij®}?GÇ3 1ŽTú×ÞÜáè[K)1/   ,. Ú72þ9C :9J$]a igNJ_}j‚†Œ“‰“‡bc†h_„†ƒ}uopmmmjsyp[D8CLQh’e=/m6'Hee,610ò @7åäˆ}‡oWPv”gukM9DUW§‚Un¤±ÅAPHb_(#5k}xŠ˜¦­…K712  ÿ÷ý"ûóíü-' ûøÔìøúñìûìÒ×ÂéJ5`3ЛåþîŽæûú!.-  °ÌÔ¥zQZX(' Dkff™]Z`ZTB4;5;SYJPPJDKc›”®Åó ï×æ'ÿ {èÖýÙÑÔÙ髹¨¬©À¼¼ÊâçÚæòéìéþþàþæÑÚÕçóÿùóó 0ßößÜ çVfWd§¡µè¶†h_Sc[9ã  #—»©è%ñÞðõüÀ9tU‹^e²ÑÖÒÕÇÉ?] Ý81êÚ(&G?5@83!JQû!ó [0S?{… ía}jG¡newpz•–’‡“zbmbbxqoiosyyvj‚…vd5bd]el}ƒˆ=F76H„z|h1DZ‘…:+&2^J&¯ÁwhŽ@\UgWE~I/76BloVU’šÑ»¤>J#^^RGOm€„“yw†|sUJDúþîü÷ %$($!íâí/    çóöê×ò 00å.GoNCeìü(OœZ2V|ÉD|òO'lP "4ÿ :Q1O4IUIC@FYM;DMGSSGDEZõ7ðÿ*îåûÿ">4'HA ÷Ôæ×ÊíçµÎÀ–™w¢½ÆàÓÊÒÌÃÂãûïûøø׫¤æ %%"7ëñ==SS[¬È»ÈÌ‘“¢eTK0ìûi-)d`OJâðÞöKd£¦ºª¼âê*pó¥.\|0ôìå×&&((IHA=;9ó½Ý!ôó(@VNPE8slV,ewZ}nntš’†“ƒƒesywkm|ˆvvsvypssm^SnlU9)Rƒ}evƒ[hzVƒ…u•€MSI ô<=çÕ¶c]{•ª¬‰¡nwhÂ~`N|Š•hZ}¨~®«Ün)$;<*H{rpŽ™©‘ŽhiaTJG   ò($$é* #íóÿöíÏçöçÛðÃñG6%% -`:6]=4(5R^4Klfn6<Cí®ÍªMi1õ5I[D->XZTE<?<BTQYeP>AkbD;nKcJÏ¡ðäùAH'ì÷ÑãáÊëéËÄ·•ƒYˆ´ÉðÑÊÐÊÁ³Ôøõìæת«ê&5),;òù G$$FomVœ¯¯´¸˜‘š©YTK' öœNmu(Üÿé "ö 8_›ÓÀ¹ÇfÇÄSZtMßÎãæ""'-QK8<@@ÿÍÒ  Ûâáê3LhQK%<+vw^ò;iƒOtpnx ’}~~~stssmu‘—r…ˆyvv[LRh{N2vˆe_“ ‚oto…e”ƒCMAæÍ'"驨§Z^œ¨¼Ï§{§{‚wõ’nkœ °˜qÞöŸÒå •ô#0/Ngkƒ˜–ž†hgldHC ý!('!ü "".íôýñÙâå ïåÛ†»#íøj›7$>W9G:1,@d"Z*,aQ[0’ó™Å¾$?ì0I<J35INQ<03BBEQ\bSDG€qJ;eARþöÔÀG9úâ¥×Q@ÞÉÚÑÞÔ»ØÒȼ½¨eŠ‹²ÍðÉÎÊ»»¿ªÑà˹¼ÑËä   *0N/éìëú '1@WMf¡«}ŠoVŽË~de_=% ïD_/ÊËÑÓíü:H::>ÀTœ’é×& %Öî÷"ø,93DTN59@ðè8áúHàÌ öH6[NbD'Um`Pñï8±q,y‹^‚€‰–Špx~xovtrsz’”Ž„•  |y[XX^edfZE‹˜|s€y{kqŽhh“œ‹l ÷àȱ’›Üª–ÑÔÚÀ}=”~Ãܤ¢Â›Óè¿‚‘®ÖÄ›aKW65Mw‘‹†‡œ”‘yjmƒyL=(#-46%-!ú3+: -ÛoñÛýþöîùHŸ£°Ö×Q&@]hCþúç ZymF<ŒcNh„Lb77@>3!M`=@7%1FC4L5#&\nnbnb;MOøÉÝÀéòÒ ×Ü="ëÇçÈÉ¡ÏÔñßô°°§³ßÖ™ÀÑIJ±«ÀÆ´«ÒØÕø9. IdavgFB@Ozs‰›‹_‚`sTYUÆ*û:Kô×ßÉâá"`u}JfAãííÀ¨Èß÷ûõ+<&.KHA?=,!á¨Ù ílPUR`A1||t‡6@#g<D…¦Žmz€“dr{rd^rƒƒ˜ž§ ‘|jg…‘‚e_}^xlJ^~–ɨ`|¦ˆl|tg EüÕÕÁ´«7b ‰åú·z|©O¿ø|ää¡âøèÐÝÒ«;3GXt‡il•¡›ž‘„«“Ÿxy…ŽUIF(!(-6(6'ú)z42/&)/"ìî÷ëßÇëÐÏëÒèúEpcHç<["N_B=ð:=ú7|†”fAz5,OVB>FG,;Qa;1SLE9KZKBBH@/)S\V_YbwÂÓÕÑÕöð÷Þ¸ëÏì!#4æó—´‰ÔçÿëȬŸ­Ç¤ªÉÆ›½Ï¿­°¨¨½½´íðØÿ##ÿ&"'(;DrOu<<(TOrŠ‹n‰]]FnCNWóçõH,ý'ÎMýËÜíýØ&=k<uh×öÞËÖî—«á&îýö'6FDD=:"úÿà+û¢åüpHZTS<9‚{opb'-V…š†Š~v“ct~vdTr‰‰— —¤ªšˆ|dv‘‹kz—Y|@$Su“¾§”NN (^gM1ùúî‹xnŽËÃztd…¢ç8ÆîËÈíÑʵÏ~*yy•†ª¤™§¡ª‰“––®–¥{|ZOO&'31*9*ý X+þ 0A(êîýô$âÖÐÕþ)Pn.-“¡é Ws”:<éBÿ>Ssðà1/(3+d5DR2Hcmh=H106HQT?BQ==.=JGYhDSwù,øã¾ÊâçòçíçÝþáóé ¥¬²ÒÞíá亼”¢½Å²ß²ÅÁ²š’¨«ÉÞÿäçüö û %(Hž–[nŒÌMQ3-…­¹º¦’_91D:=3÷áí öúûüö9O‡cXZœœº¡Jzô×ÛWFTÁÇ$##4DVXV7üÛï1/׸ø#þMZV5s‘ˆhB[!‚Ž…|s‹qsvloXW^ˆ‘tƒŽ‹rjjm^^‘‚kn}¢ uD\‡¬’‰qs|qkS#7, ÿÛõææ'öAŠn²¬…S‚oPtw‹œÐÚ¹ÉÅ©›ŒhE’¹¼–¥“¥«¡šˆ{o„¢·®™·¡wIBE://2$!" +,%   ýåêõøåßý&.)ebhB8fVH‡v‹`-þ D)/D#øð#0 ;/#,2A\P;ADJGD5A\ƒj7;VI:JfhkGT+ÙÊèçÔØíâýÐðçÏÅÃÌéìÃÕØÒä±­ˆŸ±ï½Äļ»©Œ¤˜Îæ×ïì",&(Hnkf“‡‡w–du`d•§¨ŒldJ?J÷áð)4ïë÷ðÂþúÞêî–”]8dV¢·­­¬|oÏMX?6&(ïºÕ0LJ=*43#ÍÜ×òÿ¡¨ÜíÆ `x=KuRw{njì ‡Ž‹—xoTUy•g_stII^mYe…‹xvssmpvjj†˜¡¥{5c‹wtkgjz}ƒt;+ÀºÜåÖ¶¼"øu^mRRŽ…iv‰\e`ƒûÕÙáˤw`nšº¼¼ÌÌÇÀ³¹‘~u““–lk;=-6)&-*!%+@=1`4.""! þÿ÷åíøú÷/'B3OE ý®‹<4637%)J #8M)2+J )72228;MGMqPMADMS\\MCFJ\C1G`n½˜\ ÓÐáÝÛÜÄàä¸ ûȲ³ÕèîÐâÚÔÿ¼­{‘–ÎÏÓ°½É̬¡¤•ÎæûÎì # (&5&<TP?mež½Íœ{|–¨·‰WPAGQñúëÜ%L<ÿàíïÌñåÞêú ™0S‰e“´®ºÙ„wvX3"ÝÀþú'DB;1:2$ÉÜÜÞß‘¨ÁèëÔÎ i|<Mqh‹sri`"ïu—²wvNX•tlsyQOUdnt” Œˆ|mj…ypj•³µ™‚c)þCzegjheyy‚u/ 칺çÁ¬¥¤îïÂetŽeZ—jtŽƒ„†w•ÚÓ쾬—‹‹’Ž«ª¹ËÔ½Á´«—Š{‡„xnS8d?B",) .*!%+7=:l+ òðöøõý   1cu 9:-'"vs=LK 8 D//JG/.A;)%("D9BK?9*-9QSPDGPMVVMIXA5:7P]k€ŽzJÈÕãÝÕìÓÊóÓïÁóÍÆÃÀ¢µåîË´¹Ñ«ž’¯ÈÈÅ·¸¼ÈË×Èûû@=:ø#;=F(ÿ>GKuj쥜‹ou~©Áæ‡w[AA!ýC# Oa ôäÎÉʺö9<%E‰ˆ”½È±Î…i>.úHE9Gí®"ø':L810ìÿÞ|‚ÂÚ¯°õ7VxŸXl[_Zø4^rvˆ„„S€’‘ž{]p|jj€}…—’”…py”vsRƒ°¬oR<(LnFMqyrt\M&þùëŲ̈wÞûΰ¾¿§oy‰IDlk}h©§Œ«¬²à«’ÓçÀŠƒx™šµÕ­Šosci‡{{‡†tJ”T]CA8 %!"ÿ"! ÿ æéìøûýÿQ„Z"(+%6:r:2;ý! & &&,è:*08MG;>AGMVGJMSPMS>GhUUDAIFMWeVLNTܹù´ÚïÖáêúܱĪ£ºÅâÄß×ÂÛª¶ªŽåÂó³µÌºòì.4^(6FV;0ú_|O\T­Æº¨†‡u†¶¼f^B@F/Ç ÷gIüK@ÛÚÉ´Èð5k,†{gÏѨttxö<Dý" -H&P Ü  64! +4 üõ)Ù¢™Çɤ¡Ð 6‘›œDMƒEIÓ=jU(R™wmy—©œ½xOp¯©Î‚b5C|˜šˆy‹ŽI=gŒ¤…‡©r&^ˆbYgmKHbL:%&éÑ£˜ äI7÷ÉêÒ¹†ad|7IXy˜¦wlº0íßåæØƽ»”¶×¬‹¯®®™Š{NS_\RE?:>, ($+4#.1+%"  ìÝäïøôõ.!K   <F_Z.¹+ý 2ê >#)D/ ûÔè,BB8SUX:1:UI7@>GSDMV\\D+dVkU=J`_/L@[íÝÞÆìýÿÿúôǪ­ª¼¿ÙÒáÏÆØ«¹‘£šÜ¿½¦²¯ííÙõ7ï+4 L"kS2LkVRG·ƒfs’œŠ)&C@G- Öú„|OCIBQÉ õ³¼í*AV5G€``ØÒ˜B •µ&8SeC&Q5JÙõ43*. # ÞÔ·ŸÍ½¡°èHŽŠQGMefQèO|L:^„z|‹¸“c[L‹©Æ‹\AU‹””|vLLy•zqŠ¬x52ZjV^^EKD1+(Ö›¦íÑòûù먜”`UBK\‚“‰hÊ-öÙÓÒÓ¯­¿—í¾£³´®™{~oQ]_SC6678/ -*!&..%ïÙìòõúû..+Rn$†#B ä ; &5,2,*%ýô7STDIaa:(+F=:F;DV_qJq}b1[SnU=P]V8]FOðÚô ãÖæÙßù Þߵ̽½Î²ÂçÒ®ÃÆ´Åœ¨´º»©ÁÊç ô$*3'*33-&!–¢€n ˜5&’º«‘V|„ZXhD!0,! ý 6zk2:PTi/èÔôòÆ´êRHÚ8h–¤ªgMW«¼å <K>[Vh?"íîÚ (:û=ð ÖðóỼæ…À¸·Ø %Qxmÿ~‡?S ×ø#V=izƒyw††‰u[Ca¤…jˆsjq}Ž ‡…Ž^[agmh’¡Ÿ‘Zÿ0=FKQLLW39Aå䟢ûBL-$2î ¨e]kf¾ï-öÛ(úðø$ ú(vKÐó&Ù‰e†¤Ÿ{rQNN]xkJ+'*1,2 033"/.+ûüúüÿùúûÕì÷«[*5'7"65ü^à0 b>M8&\1/)&)IgsvmADGJM,)8;:G/DPVJD;7FJeO=_Q>V<6HáîèÚ óùöÅÚ³ÙÏÉ͵ÉØÒ´½®®¼¯·®¨º´Ô¨Î59F %+%4 $);_k#l4 J»óžË¥“j[WDøñàë 7s”YT;E#äìØÏÏÿ+G\f‚SY˜ ôè×á‚]I—M)öþ 1ñð.)ù×ßí·¾ø’ƒ¬Øåïû.JP dƒa)óø,dVokV¥£`WZk€\Sl‚Lpp—‰ŒŽprjdjjspa=8YeWCW5AZd<:CE5: þãªÖä×ðY?ÿBMjñÔèîbPAS Da\vvöêòôýûö1ÓËò žwp~xZE?<?NiieM4-0.,,!'3:=54.ÿöúûâòý&)b"*÷(` üÉîÜ"&>; 2,t>&/!G•‚Y†œ“TSMJA8222#:VJ††Y\YD.CDGC=SQGbj‚y óåèìèù÷ ÈÓÅøÏìÖÉÉ»×Ùè×Î¥§³·ÌÁ¼¶£Ü°Æ" $$*-0.& BMbhk;«O"wîÆ´YH; èîÝñ!s…s5B'@T•æìʺÏAVfŽmzem¥ú÷ú ABOˆ3#, ûôñ(5 ÑÙñ¶“Ù —²Ûî÷õ +0-CL/ü(>ykcY;‚Q`l~•tS_uRggmqnmOPUagpsm^IeJOE:YU^\@.$ ìà˶ØïõD ó >DN͵ÛçÊXTIU)VMWlk2  êò%äà×Á»Œ\P€uT<6?EWoYMD1'$./&!.4541 ù ûúðë  !.6V +ä: ü  è4>2 2 ,8?‡•ÂÿØNXLL=1+71(=b\›’JMMJCFA8:=GTVb€ öçÝÔýîäÚÙâñ>'ß#ÁáêÎÇÔµÕé­¶¢£ÃÉǼ¯ªË¼®Îê÷! $-88 !@Hof]a†G3êcȉ÷Óò›{9&)ñÿåý"_YVL*ñ NfôÊ¿Ç»¦¾¶éÝ’“BBv„{W+ÄÄÁîQIMO}†.FP3îåÙýÄ  $óÍ°Ôб걫Èéõ%)-*$Þä(+M^K[<WF<¯žsœŽJ•g?g–µUR^Ziszkn}J=„¬“ŽnOp\ ,-ØÛúþà­ÎëÐ:(æ ù30ÞèûáÀ¹Ã–±RgfWKªY#H-Ú,å˜)Ël<?GRT99`cWdUÿ#>2+4+.-û!âââèø$..* K6r3$#õ(0+þø/$  ýöüOOñßñ%zHM[-2+.CdIb†OEE0MJ>524FCFZRRÇôõíâÜùþÞåäûÚÝÝ×ÈËÑÏϯÛÒ±¹Ð¢©ª¡›ËÖò ÕÎ#&#)/)$','"=]?í/X)$÷5††F6=O 'C£p€€";R@¾ßìÃÈ¿£ã쌨unsT«òØóÖ 2D8‹©’¹Ø¥(ÙìöìíçǬÉPßÌÄéòÄãñΰ§˜Ôéõ %&/'9% ;>9 *1C:?CM=aWOy¦ x&kd$p”Vld]msxqZ^¢‚UIˆ©«¾¼ªSsi  Þ±¸ÞìÚ³Êù ðþþ;ñðþ("öÌÑóàÅÈøñ(sT C>ñöÖ»¸ÆÔÈœcP„eQJdZKKEZNBEpD +(7"îÙÍÊÐö '.!#M9òû    " ÿû þCC¯œxN†VOO4)"-"9HNnSJƒ\MJAVP;,&SVƒwIIOµâéöëîåþÞåóãÔÝXÝÅÔàÖï°Ì·Ì´ÃÚž«³˜‰¶ÜõýÝÚ# #5;& &#DY=!D>Y$'ý-uCMr1$(Pý ,F[vv{-BF"¶ÙéÍÒÎùût“x†—H¾Ò2\‹q’ ‘¨È–Æìôäܺ°°É$eÀ½ÊçéÙ÷ﶕÈàï "%&)!9.)$T¹%K?THUXv`+X ‘cSU'a…_laTghoolu{PHsx•¢±°¢QUM üɾÇÏÚÔ×"ù þ ù'.ÛØðÝ»¿ªÐýgKùGbåêÆ“¡°Î±’MMnxnypcZi``NBE`/ ùð#!"+û  åÐÖÍÍÖö !E#,WDU û  ""#,ÿ  41”Êî˜i[C+&"6:O`RpB6J:7FSPMA85SbŒ‰ADJ=é èâú&*üÑãÔ.ãÎìò寖³°ºÉѲ·àª}†¾û ì×# DD##g|_"m‹78E¶ MéGt8 í$5bv„y{  ûÝÖ5IÛÅÈþN¥®¡Š‰Ž}rª®Ë,µÂμ²^BI!)åî èÓǵÚ@RúäÕçÀÑì ìàÝÔ¿Èï((2'CD> AÀÉC`fKc ‹g34gc1Cr`4=MW[WX<<3->mK$PÙ²§”‚9  ú ùó-%(1KëáîÝæâ ³½Ø³õ ¹£Óø *|ŒHßÄ¿©–†•˜±oqYzž‹€{~x``cZ6ÿ  (((øøõõúôôîëâèîýøTdW&#7"94%(þ "(%%8A" ^%=++v[I:di_4 +;ksr—á‚ZID;5QGMVbbPkhtJHH¢òú÷ÎÚ5ãòݶÈÈÝÚÑ’Šðì¸ÒÊ¥­¢øΕŒî ñ ñ $KB ü& M>&4H€0/Û)'T;­ù3`ƒbdme¡c,ÿάšçj¹˹¿õc½ÅÏ¿—V¹°ëêØÓ¿\M!!`4úÿõÁ®¯Éôa°6 ó2åâ ´Aýõ×Ý Å¹þ%+>ð <7ï "/êÁ?^…v|EHl©d@-I^/]s~driA&.†h`‘wgJ/ % ":0- #2SMM~®É)÷úÏc´è¼I‰àV»iT/5éÑøÜÁ˜`{Ѥp‚ƒ…¨´…–xx{fic<)  "gL%7 úîîôíêIÙ3&H-&  ' þ 7+JG1! ¬ +"FU4@(F;E75<"@PWo¥„I_IVQVƒbbeeetkbMZRFñ×ÿÜ÷åæøäÄÉËãÚÝÑÝÅ¡´³ØÅ”Ÿˆc°À¿›h›ë ý ÷  3*?û&2Ž-…pB5/#4?No8 Ma{›¸ÐÔݤÃí÷íϼ C‰‡€nŠ¾Êâöþ-Uj5&ÑÔôíÁ–p Ç 3(%‹Ü þ³¹é¿Å=:úÜþ×ÃÞçûw`’?em:LRZUq(*7p§xˆrj›ŠD  x§²ƒ<+åúóWW`M$' 3=LL9‚˜fDòÖyÏÒ:ïùW^JJ{óÒâ°¹ä󃓟¸Ç¨¨£™™¨”„~~xuZ``N9#&  "4:7:!   ÷èâ÷çààüø ô"‹µ1%!    "",,$!#7(@O177"(@!!%5Jb]DY\G>SqJGqeqkhhVQNfð ÝüèëØû çÇÀÚÔÚLãÑÚ¶¬¥¾É³•‡lkÍɹ’S¤åû ÿ %(ÿñÞ%#3Q€gO]ŠXKC)ü %8‡t-BP #;s{‹¨ØÜ·À´äëÚż4’™˜ivÌÕÛ×÷!$%#.°âÇ·­€“nˆ°Îïíò 9ž‰Ù¹ËÑÂÎþ3"íùë²þàºßóP¥èT}SVz@JA:9+jÅ«£‡®£j<%*oh÷ëåÒ(w\T0,;NIKQ^3qžd)'ù¾…x!2tckGmŒCàÅøã´ªÌؤ´ÀÈŵªš“£†ˆux~ulQKH9. #  "14( úñÓî÷ýüøØ õ ÷%¯åC $ û+=1))'4%:O("("(4 !CRI1ImhPDPeJJqhw\he_SbeçîéÏîåÛææÃÓÛ××ãòŧ°³ÒÔìÀ¥¢`Be¿Õ¹¤ƒøßéÿóùèäù¤òØPg:iX RR4R9#i62><!*2|‘ Ž¾<«À¯ÅÝÌ÷ε¹å[ˆ•§¯‡F˜:ö!,3|O1,'ÚÔÊu`T†z›Üåéñ %¤ƒûõª¼’ÑÅªé  «»ÙγÒÏÊ  …¢5òýz€E™ˆEFvˆadv}±ÄÀÇÑ×Õ†\8FMYa%&/2Ga‚M5:ŠƒwV?ù.5ÅÙ)*ûHhmlR`fdÆÑꢬÈj¶ãðѳ›ˆ…|vss€‡–Š{`QE6. # .("7".0úñâèܲåúýÕá.A ìì $(( õû (R@ &7 %+44)*+  .:DeS;>\khS\_n_tqYJ\bpõÝÌñâùÎËÌÖÃËàòªÂËÈŹȵ™‡|9(Yƒ ƒq›Úßï!ÿöÿÝê‰TjC[PWy|W`OC;S`õÿ-;D1&t%0;å˲ÍÕB$ç¿ÈÙÖû#j‡Œ™Í—ëI,8!8- BK4這œ‰GI\Œ°¶Ë'ë ~~lœ¤•ƒ’˜¹ÈÈé ó«Çæ¹ÌÍ4û iV%÷ê홃Oj‚ˆFc”µ’´‘“»¡¯—•%,.(]~pTKgjXZZ?(<nb\XVFü'#²Êø0soymZRK90ëéåð{R~˜°©´Ã¹‘ŠŠ…ŒŠ„c`Z?%&,/)&;":" ëåÍÍßлÍßÍÕïöÛüç(4   + +&, %+(%øþ 1'ý ,LFO_VPbkbSJYtw˜znn_RN]îúÑÙôßÒÔÜÖ«ÍÚôÂâܹÙĘ̀¤š‚KE˜«†m­Ôàò!ôëþ*ûõ+ 7Y_FaH…soLn:(8\<#ãååGS:&-° bHÙÖÁÐà+A;þ·Èãë3‚¢ž¬Ç*í).ý-*87)<øøŠ¸œ€QGn–§œÂ"ô#hz€s}gy†ª¿ÀÂñÒ½ÕҽР-$ô' ðñAX\/Nmy]Vˆ·šÃup£Ÿ›¤°ÊR8.*6?n{~—SebJfq^6E^JEWtˆ2óßõŽè<K mejWRd9#ô1þñêÌ¢gls‚Ž£¡te‘‘”šˆ‡~{{Z`]<)/2.+C%=9*- ùèåÍÌÝõÓåúô÷¾ÛÒí "!! î÷0*(0  öççêü KC%ñ2|a1DMke_VS^jpjˆqˆdaOj4ÚÎÎÑìÝàã̬ÂØÖÔØÒϲ˜šx¦`r™˜Šˆ•Ü»ü 9òÍÂÑÇäõ $1Ua0vQ¹–…“r7>:>^rºÉ*çM@Rn_”R<ú'/) +!DBëÊ #(™wÁ¶l‘ÞVW6P#ÿ*<-81$NÙÆÈ}‚seTMD˜ïæõ  ª{ˆŒdll\~‰®þ$üÌ÷þëñ)ùíï GK0iPãê/ ÷)e\1n‘¢¦š€|¼¡‹QJGg›†Ž¶¹•ca…yvOJaO]eV5QI Åâ˶Ã-DEx€wP=IC""þѳ¼ßȬ˜­’‹f{y‡˜œš§œ†o`Z<<90(!#0CG1<1 # & ãêÔéÒÔ-ûõïïòûíÍï);##ÛÎáüöü8Dö /( "÷ÖÇë '//;8&>22AMMkŒƒbeUvx|y°ÌxkaFéìàãé××Î×éÞÙÔÒÓ×ÿ'óÒ™g‰ žJq‰›Á®››°¯§ãçú㪙ŸÆÁ±æ5(WŒÌYŽz§Œ~W5dtT";ú¾ÇüÑ#öY``':wEB]LO$ÞØóùôMÄØá3ʧü{4;t:X5&‹—ÛÝ€˜[VBBNbs…ÏwoßϦsqt«ºÍÓ(,  > õ3523)QxCH$#7V2nJ00Up\A00zrc…•‘‹¸©„¬©V,]‘>:+FayX?n•; ‘{°ÖÆrÜx¥µXH9H*! ßžžˆ²°ª˜¾É·¦·Âº ¹·}rH69'<EB. -DR/<7    ðÿûùéêöÝãýûùöõöìËó."=Xéíùöçðöÿ þ)2÷ßô  $EPMJž}JMVJhk_\tqŒwtgˆ‹mmt—e{rg[IàòãÔûà˳¶ÝêëÑÆÏéöûê¹f”´ŒTWš®·¾Ã¿§²®Å««µ”¦»Óͽï? ¬ÓH¡¢woZJhuUë»ÉõÜõ! ‚beN3JV„KQ]r@ñßæú$]»äÛÅ­ÜfdùItæB(-§‚Õè„xq€fE@C5FTNUµqurÁ~p}˼ÑòÛé./1B*Q‰:C>ýH«+Y<ù"5gV5k`9,+* ;IKiˆ–²Û†^††A^v_02I_^\J3fVÿŸ|cÕÔ·˜3W‚‰¢Q^9, + ß¼ÈyƒÐ¹›˜ÊÖ¼°¿Å°›¸¥i`?<BKWT<ù)9;D2$"   úþò÷ñéöõìÔîðø þõüøâ5#5#;> ùçÿùõöø)2ô' ;GJSª†VGMJhk_bthwqky‚g\e’w…«\OLÔæÝÝã×㼶ÈÌÇÅÏÛï"öº‘…ÑΑw|ˆÆ¥¹ÑÏ•²­Šœª©ÕíÖÙùô7P*5ãó\ˆt€€…jjrKûôØ«¿!äÌõï)#-$."=è"<-?=1Ôÿ =&J|‡pP1©¿ÈâIIøÝ1ÐIïâævy­‘b?eWQ9SOUxzÛ°Ù°Ÿ‚Œ¿Æ¹ÝHd_aoº»$JW9.AE8KcH. bƒxtr|mcS"ìXsV@K"ik€§ªc?3*3*JTwkDLkÛAÐÛÞ®hƦ°w6QZcK+;l.)&(þûîéìͼͳ•¼Á”†¡ª¤’­µx`]ZWWWKB'û70*7'æýþýÚÕææÚÊÓWifèçóû ûÿ(";&z5;bn(&#82(&ÿ   ú9<!/;SA&_DMe28PehnŒk\qhksf\YqmÑhX^ÚÝæÝÔÑÚÝ˶áèìçáÔçãçÆŽ”ŸHx­wbƒ½½¹ÊÞ¢¶‹‡’ÃËÄÕϱÇù÷Üæ†&I–å¦tˆ„ž²Šl„fWéßí¼³ßçæ)(=ñ]Týÿ]~NdRò¶ãü":VTH§¤Æù ÚÂHGî&ò T^4ÕîÇž‚‘¼¯­›qFq’ʬեf¢¿x­èÚóê!Zq~“rRWGM+%8#üèÐþÔàFž©Á®œŠF!U:›•©€ )Gwd7D¨{ŠX 8:=6,5#:J&¼c€lµÃÖÏõ*e-.3*,5ñò úïì  Ù¡˜­²¸›•¹Å¹¼²iW?KHB93$(+%4- äìýñðßÝÚÁ­Ôäožcýñéðÿ%( +)::":O1þ )&G\8A|2#ööøíðþëëë<0?6N)8D>MYA\ežMGMhbDA\ƒSmnuN;eq¡ÏVL£ÑÔæÚȿ׿¹ÈÕÜÝÞÖÎíëÕº—±‹o•lfeÍÀ¿Ñã «ŒŠˆ«­¯ÌÌ£¯Øô ñLÿ#Ðœn˜°›y[fKNúÜÝÆËýÿ    I(úE? QN3’€í¥Õô.Cfie}¼Ä+úÆ.?ª ñ!QF%"áУ‚|z—¡ž•sR0†¡™¿Ÿ©n˜¡ršñõòö>6Z\`{k~”¥Y= öøÖ·ÕÍí?Ž–ÁǼ‚ANC…¯¸¹‰õ1QOe™ud#&  #AeP³TÃù!Læ"v;*0S# ,ñúñ÷òúõò÷ïÜ¿¹¿¾®¨£¥§«£˜‡h`KHHB96*$!*11,!ùèßíáéÁÛ  AD#ÜÚÔ½Ø( ""F[4#/ &5P5,2) ööþë¥ÛH9KZ28;GMJVVt\MDSPA;S}YmdhZS:Ï Ž_UmÎÎÝàÑÂ×¼¿×ÒÊËÏÐÔðú½Œ‚x¿w\}ƒˆ³Â¯¶Ö®«¥¯„‹—¸ÄÜúA:ûÙÙÔó\ew›»š€DH9LÍ´Öÿ>ýýä ?6PgI1&T)),ÞæL2èM[j“ªÎÕüç½ô[Qú ÝôC÷ãÞ–q:lµ—ucd¦½¿õ×°†‚ˆi‡Ÿ,0ke_SS`ss·\ ãâ×ÚãÔë÷ÑÂÚBi[t~ŽY_JC.Pe¨Ï¡ $&/1R)5HÕ´Åž°¸»ÆÌ«ƒW“¢æø-/øX:,( Az8-ðÿèû ÜËÐÔÈ­¾™®µ–‰“ˆ€xel`?E???<:;==88û üìâäëÜéWAçX­+æÖÎÏÚÊì*ûæ )1R^% /852VMJ ûèñiŸTf]<$82GJ>5SYS\YVPJSDP}…jX_sttœÅž‚£ˆÚÔÚàìòàøïËçÙÎÌÐÚÕÓÆob‹†Ä§’~|Ä´‰—ÊкÀÅÁµÏÇÆÛÊÞ¶¾àßÍÐ$Œ•¿ž^'0*#æãíù$5 #þ>:BY52]IR82/FîëLk’nXZ¿«Ûú?Q~PøÞ½¼tv‘«–•¥°‹~ªÄÞÒÇqq†h—Õ/8‘“WC@&OVl]ŽQþ× ÒÎÝóÓ¼¹é=GöÛøphV\E)5Ÿ¡a+Cl=Lp1<Q  !'ùņz›— ¯™fv‡™ç!E3Øð5ëÒ0h.úðáäåÜéèײzn‹“™£¥§‘†]JQQB?HB?97;2('* ø÷ÔÈõ< ñ)u“tˆìæÖÉáâêâÛðþôí/kMA>2,ó))  DAçù"þâÊ62xZ`BSPYVSekkJASwqqkeh€•bd{nae_\—µ¯mÑÈÚÔãïÝããÚÞÙÈÀÃËÏ­½r`mc|›“mu¦°¥‘°âÜ·µ»Ó¬¹ãÓˤìÄéàØÒ,+‘w‰¹”|eHE=>, # iyrSM d[8L799ä÷ÿï,eušÖ•±Øi¥äÿ(U1c‚[h*ñù¨¥tp‹·º³§¹¨ž²ÏçÜ»td†jÐødj>GJ8R_]Œ‰u×’Êíó õÌíþ "ûîïýù@DhWB%%`to-(A ßôû"#$<6ÿÉ¡Œ˜ˆˆƒdzn£Éê@éêúòÑîé6"KùâßÖÊÜÝéÜȬ†wts—¡¤›˜Œ}pK<9BE9KE?3.1A=!ýéâÚê B&$<[is]ãÛçÛàó" îóäèøÿLz>5;/#  >@,ü#üçï"þèÜ` oTE;VYPPShekMJVeetehhtƒkgzl^Uqw²”gËÖ×Ô¶ÑÓµâ»ÕÖÍÆÍ迶¤Ž‰˜”ˆ‘ŸyˆxŸ«øÆÎʾ¬±çÕ÷õøæú ñÿèßå;Br¡º“›†”Œyˆœ_i, %Ñé:QðHbj—¤ŒN8/3aJ¼íþ%f˜Ž¡Â·©Á_†ÇfÈ (*" øõ7÷Ń–“µ¬±ÃÆÌ»»‘ƒ²ã ‰Ykp´Ûמ¹ºÛ*nqtusiM<ÞÁ¹(+:hTç×öÊÉãèØüÍì0(=+ø"ûáêÁ÷éEfgE÷Ȫ˜…‰’–Û$ÿÌÏǺ´¶/­¥w‰˜ùùïø¬ÆÇô®‡ŠÁ†‘›µŽsag_M=5))/;/& .ôBÛßÔÝ)I(8)1 @`1 üò÷F äÿ(CY(%":I9ðÛßæ$("!&$,#ÿù +Iysv15>JY_JkVGg»s| Uvvajjpjjmah}ztwyÙÖÑËÈÅǵÜÔò²²¯yš¦—Ž•ƒ”²ÃŸŸžÄ×ÛàÔÛëïÞòìöûû ýøô˪"üo~‡‘Ž}v§yw“†p ' öøCOðÿ“„…Y/TZdkB÷¾Èì0HY~¦¸#ù€Œ¢ºô×íÝ5#=€| îßÑ™”va´ÁÉÕϽ–°Ðñ` VŦcMAhŒ¥¹Ë%HDKklCC.[AâíZly‰~1ñøÅ£§àÒðÉÞù , ßíòÏÕæÝïÕÙÃý E"Œ†]cêåÊÈš„®¿ÄóAI¿Ä˜‹©—”«½Ë!HAÅghU‚{†Œªº²”” ²—‹¸¢¤°•h_;DDA/2855/2,V^k·Ýåï3-*!0:A6ü  j—%+"@.CC1 +44$  ÿèõý  ü 0?ÿêõü,eŒÑ;LGM\YSze\eI[Ov|‚‚ydmŒMD^UGx…xxwƲÎÂàÍÐÑÚËü˸”šÐÙ©¸»¤ƒ¡¬¸Ã®Ÿ­ÃôÏäÔðìúôãïùþ *ãßï +(8Z’ÔÅv˜zz›”›‡Ÿ3' »â;ö7Oì€fM5& W…›]=!ºÊ¼Î W†[(»µ\_Tj™™ï^"ˆÓ…É£˜¯·ƒ{Ž¯Ò°¿¹ÉåÙÓ&VõmBG>k‘‰´Ý H->ÿ-Jd\r$M\FbRI{™§;à×ÊÄÎÔõò=ûéÒØбª¶”§ÏW&twt—¯˜SÙê Ýî» QS‰Jݼº´’xr`irŠ|mªw´£gCHVbqŽœš—‘”£µ¬‰‹X:@UF@4GGA& üïäóñüú¶ÙäÝþ363'"#úùüò ?B3E!'BFIC4.+($ úÿ  ÿ!'6ýîùöùü5}Œ˜#PP>¿È˜ûªbhU^pLXymmy…y^8AHv‹|{t¾«Î¿éÜÊÚ׼ߵÁ— ôÄ»£ƒ°¬²º·¥¶ºñÞ×ÔùøúñÍÖùü æ =CVu†­’€­‰†‘¥¯¤„¦> Äî%R4:ú ‰*),ò ?Rl63¨µØáø6hg»§• L_ud‡¢µý  ñ‡Õˆ±ˆ¶Ï±‰„ˆ¦Õª½¼×æÔÒÿ¾|_;MGw|‰·¹‹ûK,*8Xl3E@py^n®¸’% 9DÖ½Àç >>5 ÃÄ¿§œ®¤Åê$Zvp˜«¶»uÞïäÐ*FeGB!߯Ÿ¥§zycVRUMP„u§ p<Jnzƒuy|vsy‘ŽŠsjL@CaI@4JG8 ÿöóûðïÙ»ÎÜÒú 066'%õùÿý *0ZNlE?9IF@==." '   ,*ùÿûÿü>kJ;,hGPãƒì¤\_myyO[g^d||n\8cˆ…xzsËÃÔ¿ñôžÕÏ´ÈÁÁ¾¸£ÁÁ©”•­§©·ÒÃÑ·áüºÕÒÑ  ùí÷ÔíþHotxTœÑ®¡™­²£Ž@ ÙôP1Q3ëê 7ìêc*X^úÛǪ³ÔBwœ¼¥—žYOy‡œ®»7Nô#Ù¨¡™Ê–ªÁ§ªÌÈÔÑÉÊÎß3Ò€SSA_†œ¿¿,"1(&=VfNZ!›„LƒÑͤt]¤‰V&ìò œˆ¿œ›–„¢³ÙÖáñæ1o¬xN \èçð»Ìß– 78'2äÅÆ°’lXfNd\… ¥ƒ§”‹Žxygp|ˆdjFciK]olK939/) && ü+ ݳ¹ÎÙýý*3!-7ÿ ý-($.%=1OXX[baL.4:@@.  óú)ï'N3KE,ek_enzkw†‹‚R|^U^jMO[²¯”svmj‚zp¿Õ¸ßî´Ì´º­¾¦¬”¾©v…‰Å³¾¾«½Æ¶ÈÂãøÚæïèôþùùïûø÷"ý-or$xq‹·ÆÁ¿¯¶–±yGóëÒïni˜[ïå/û÷`§ÐÛÕÄÊÊå8‹ƒ¹{nw®«Ÿx½ÜKööÆÍ¥jª¢‘Ÿ¤œ¢ÇÆÁÈÏÙðóõèömmb•†€p}¢È³´í2)cjPR!lWXd…’LX‰™}ˆJ9CøøΩœŒ¤¸Ó  9‚ˆj™|…Õµ‚…{gä ''.=`fI÷â’Ÿ·«mrgp^Œ˜Ÿ›¤¬®±®•~|syˆ…|vpodd^UO7..:&) +ûûÞÑãý99'")$##&068A>Gwn\>>2228888/70 àæçÜÖêêíYSYMDGPJ_Pzne\ebspgaa^aaae]`djjpfl~~€‚»Ë¾ÍÔ޺IJʯ½‹£¯—¦¦‚s‰¿¼»¯±ºÂ¶®½çûÔþùÿùþ'øè( &bgþXvŒ±ÉÍϬ³´Æ‰JüëóQ‚¤]õüÄ O€ŽÔ% ÓÊÝßÍí)‹˜jГ‹­Í‡‡p™Òê êìÀÁ«j~z¡œž¤¡¼ÐºÄÚëËÅÊmelª¡§|ƒœ¹À±À  î^vNwûõEWb )PqCSynve3ENxi»­Ôš§Ëì +fM#,»ˆ„µ±‘rulÔHGRZjgN5¸™³«yƒ|a†‘›†›¬Ÿ­¹˜‚pvysy||y|hSGG/&&,&# %ûþäãïþ !!  ü5!#/6&8;D_SM>$!0B60?'!$0' ÿÿ ççäÙÖêöíÿ#,VVMMMPU>MGt}b\_Ypj[[ajjjghlvX|uebz{~€ÔÖÓÈÅÀÀ¾¯Í¦±ˆ ¬—‘»»s‰§Å¯¨ØÀ¹պ¹Ôçü2ðõø ôÚ"¿x¨–±ÃóÓÈɦiF!ŒA6Õµ û1( b0g` ÕàùôØúKluÞš|~ˆ‡‹‚“öó¼Òßù[ƒ¿Qq‰’¢Æ³£œÓðA®¢I?”Š¤˜¼ˆw{¼½¬’Þ +QK ÇŸDLõñþ8r‰[~wmeeGY§Æ¬tqt_z>³»znŠÕ×g¯¹·Ãß"þÚëÂéCHH7+"jü)·Ãº–ž­šrwq€›€‘¬º˜¤˜‹pys[jppfTA258 )&ùÿ2;/ ïÐÊëõ0?g#$&=;,& #G296-!6*''üG>üöúúú;AJMSDMV_be_}h€qtn\^XL[g|yvpnFOafeeUI\quwÙÍ¿ËϺ»Ê¯©™¢µ¬ —£ ‹›¼© Æí±¹Æ¯ÓÛæÙ& ïõôñîïö êöÛÚÛÁÑWŒ«®¦ÅôÅsd•\NcP=öý»–¾UX4RH8V7¯yhõæÃÕïö;|ŠÄ¦­jŽnž°¡±»¦ÑäÉ+*+qV‹ü"Íëﱌ  ÷¡ƒ\RI~°›°‘ƒ~¤“žÂæñò"$ûð í¡ÓëиÇX ü`z…³¹µ¬µ»²µŽ‘Ž^M¤g¯¶€cPnžÈÈãÃãîeVC'8D+@øýò÷öÙ©¼­Å¹”­²©¥tqp”šˆjagUI4-685,) ÿ #25 &ýÝÐä!!ßÜCI',>$\ >/,#QE*0-**!  4,4küùü5WTNQNZQQ]nhbãhkt}kPLOXjp‚|vmhgptaeehYklnÐÂÍ͵”µÎ®™šÃ®™“˜ž˜}‰¸¨¥Â稶ϯÍÕçóòü÷èáâíåðìÜâ»áþI†’¤¯¦ þÄgžÓjJP:ù×ú ´Ôd]7em(Q÷+šwköÌá '†TŠÖšeœvª¾ž¾âÆ û8¸3<&LhT‡åîÀì ûÿýÛ—9qauŽƒ³˜ˆ™Õëë2 èç? ðŸ½ÚÀÙÇã9@/n_c”}Œ¿¿”—_PŒ[ç.ž±|’ŸTYÁq°}¨¸ª±¿Yto<4þø !ûÈßÏÙ¾ µÇ²¥œ˜’Œ¢¨“]TH914@<B?*$$ ÿ &)&"ÿòàå '$×Î":*5G$¡Ã6·?-0! )QH3 2""+$"ZOü5ÇX '06,5R`WNTKcTNZoYVûkemydFFL_qtƒ}wkeXdjYVjox`hknË¿ÖÎÔË·¾µ©½¼³®«®”š›Œ…¿’ÓàÝÙèÉÕÑÄÇÓç3!*ùöþèìâ÷îF-ÜÙx…¥½£É£¸ñæ§/%þέº÷ K‡]urUñuq7áÏÜÚ67 õV^h¡¸kp‡†–¯ª¼Ì?ÓÃ_2,JnzêòÍðÿÿ>³”< KIgwS‰½y¥¥Àìö4,ëÙæï.æÔ/¡bFK úEf€xŽ†`e•7ò,{—•{„•g^mﳯ{kg°;VkDóþ× òþ3üðíèô_ ÝñÔ¹¿¿¹­­ªžŠŠfLKIIT_ii?  ñ---!!ýÿø÷÷ÿò  ï#,;#6ýf6!3-/û  âã"*ÕÞ"2/)GVPPVSJPSkhhnw\Y]kpV‹NEDayœPflZNNNW`WQTenÔ׸¹È΢»¾¸ÆŒ˜œ™ŠŽy\ƒ˜¤žÒÀ§ð ÉáÔÊÊÖíûü3! ôòM-÷îöèßÒÎÐ0q{Õvƒ_59Ùò¼×åï¼97TŠ™l7O%H”`MîÚ×BF ã BŸµÁ‹r–£­™‹²Úþ“h=+.ˆž§ÓùÈÔðûÙ?R=ÒhNR¶‰ŽÓ¶Þâ¨Éÿãâô"èõâ 'ëñ'RVáÙáIg{pHrxU_G5yZu’£zˆ Ћ·ukgü}qVA5)ùɸÅõõé </Ìí÷ëüþîæÔÈż³¡™–Š…„jar’½Š~$?   *6?6?'! ÷ û  %""2#ÿ&852,2&ù# ú-ãéòLQýÕ±³#/DSGbbkbYAJYbqwwnYVWemYš®]QPa–®¨„|8i6!EEN`Z]cnt×Ú»¼¼Â®Êʦš˜™“‡‘sGƒ§§Ëª¡ÅéùÀáÑÇÊÓêøù Þð5&÷â÷ôßϼíñ=0>1zœß«Ë£o*öýžïàîéä:cŠ™º~A!„¸‘B; ýáØ7H ÚýEœ¦·‹£{B{”³ž•´´¦Z=G. ?%vºùÎçîÃÞçÛêÌî]zaÑ…“O¿­‹¦ªÞôžÌîéÕæàíëÜöøm[ ÕÙèagwJnnJXp5)|Vrrx…mïÐÉ|–ZDRg›+:"+%Å“«¯ÐÇìçÂÙù-$Êîùïâß ÓÚÔÈËÑ¿¹³ž›–“—yu€‡–  EKK33<*$    (( ', ÿ!*!-ú% ÷úîjoؽÊ5DGMD\YbVSMV_Yenne\ZZhml‚~QZ\o£Æä‚WJ 00?]]i}ƒ}ÑβԿ¶ØÜͬ²Ã³Ÿ™–‹‘k}’¯·¨¥ô´ÀÈËÆ»¾ÇÞøü÷(ùÿ&ðü  ý,ãîõ>>n’Õ’wV‰¥Má~% îôÌ )Fl“¥}‡÷Z£4ôåêÚ6Ëñ2`Æ·f…ZH‚„ƒ–]G$-'2lbRƒÒó³½øîßüÖ¨c?·‡©m†ªŽÄûùz§ êÒ¯–’ì6ð àó${QÍǬFsznUR2DRîDObVVV_k ¢¥·¥ufu›“Š{‡Ÿ«¢“„¦–jTœ­ÂìÚÎéøîôõøïãÎѳ³¼¡¤¡•‰Š“–”|yonižÅV,;),0?Q60K*04-%$')%þ%(/ ûòò îî ñø"F#¿±ºý<AJ\J>Y_SJVSPnƒheektffhvzmxx[pw£â¢„w)!*0BH]Zcnqe¿ÈÍÂÈÎÏÓ©Äfð›r]„psz¤¶°´¤ÞðòÌž·ÙÓÊÕýýååäääéï%296ï(/ïqÄJên R´¾, mîÆíRi¢™Ÿl›ª×ÚPØàý×5àû*MK™™‚r‹Ð·‡gÖ· Z0=8#0(L_bº®´×ËÈäË1ê`–|YŒ²èòÉßRyõ¼\Ó°§«¬¯ôÛî$."YÔ¯4úÓ·Öí=Lk>X[o÷ÙÚ@O4\MS1ʮϸ­¥Ÿºïͯ‚Ž|jyµ¼šYsn¦®½ÝàãììçÞÝβ»¿Âž›¤ª•’•„us‡‹‹~nv[FCI(%('*3BEK<'HP:$(+ùè +.1-##òããìæøï* !36'*60ÿÞsÚéÍÆS>P\VkGG_e\Sbhzwtnhckqmkgx†UbVƒ’†k_YhNKNW]NWWQe_MÂËÍÅËνپ²öÈ•„o„aXŒËך¼»®¸Ùéá½ÊÍÓçèãÞÛÛÛØÞì 67!ú-%ü·òsÈæÔT´_.16š#æÂÕÛ B«Ÿ®„~T òî×ÞÖôäfûmrQ´^¯½Ì½¤^†ouJ/%, ÿþ!R[E®¬°ÐÔÈô ¸1=ô“‰gbŒ¯ÊÎäÍUiß›`Áɾž­¼éýðô,))M·–&Ý®àâ ÅIZsÞÕ@L8O<?Ô«Ç´žž§ÅøåÇ‘‚pp|y§¡ˆn€¨·Ú´ÈõûíÆÚÔ¸¸ª§˜›¤ž››ž„{yŠˆ…{qpjXLIF.((009?BH<*$MUI<==-íë"  (++%)&õãéììõ*KW6'' ÿäNæñåå!MGMVS†SGJhkhennkhe_cntjhgrd€UbVƒ‘ye_bpTQNTWQZZTTVPÂÎÍËËÎ¥‘Ž¦®¡›®™Ÿ‘g}¹Â¦Òξ¾³¬´¿½¯ÙñùøüôÓËØÜÞáêÒß+1='ï íð60Çç÷C"Ž@EÎëGö+Üí)WH«¥¨?9ð2>õ «çáØù÷4—fbL¬+ÂÀ²’ÄŒYG^F</)îÕè^]/ƒ¥Ÿ¿Ñ½Ùý*3²µLVDIOYŠ¬fW²Au÷ü⧹Ïßîóáãó$8R~\ûõœä>* ëÆå(/!3 ì åùGMû–•Šˆ£¾Òª¤Œ’t€h>tnE__Ÿ¦³·Ì¿·œ¢°²ÌÉ«¢—€•ž˜•§­§~„ˆ|slwXTE<9?<0$963--966?S$9C3-)<C4%% &,,82ü  (  ýE]E#  ìò   1);VJDPYMMVbz‰bkeeeebht|e]ºÄÚŠUbV‚qjdksf]NHHZ]]QHGA¼¼¾Å¿º—£¬Ë­·¨Ãš‹q’ªÀ·š›ç üÁ´ÇëñçéêîóûèÛù2,=5büÿ鹯!»Ê+åÄÐ+hàÈ\J!6#MhT.6¢½ÌÞ‡7ìî í6%+ûØñ8%ùüôe•«Îõë‘‘û¨C;M28_*ýí co[]ˆ’Ä¡µêÔ×ú ú©˜ŠaG;L…ÑŠ|•”£ö'ÞÉÒâèÖãíéåþ3_u7âýé®´å êÑ ßØÍÊíóÞ×÷ ÷Ñ‹zŠjr‚„ª¢“Ÿ¥–TNrlqetq†¯¼­±¶¼ÇÍÌɾ©‚Š²ž˜•’§¡›‰„{Š¢Žvmfg^Q9!<<'*960*'009K@3HWF@*79$(474"((%)585/ù<9QH*-øòñþ#" 5  ÿ )G>;J5DJMP_n_hzz}€ƒqtpba™[áUbU€€wshalcQKKWWTEZM#¶°µ¿¼¶À¦¯ m·¡´¨ÃšŽ••ˆ¨œˆŽÉåíÐÃÓÜÜíìóôüóñá× Q>9(wìöÔÀ&v«¸>” Æ4ôÌblCe]‰9*W·ÉÌ…7Øðè!ooêñdüù?­õR7½Ÿà–XMP ? óöetXSxÊ–À÷ÏÇêûøÃ’™‘MPj…Åœ³ÄËÐÑÈÀÒɸÈÖç>ˆ¨@âßÚ½–É ôè–º ÍÄ¡¹ÞçÊëס’˜ }{^`p{ϼ¤¹¶˜SMqlo~ot\Ž¥›£¶¼ÍÐÉ´¸©‚¦¤’˜¤•Œ†Œ¥‹ussf_UN9*'?60EEB?<--9H1>HQH@9EC1C+(43 #&&/)ÿUF=1+1ôñìë %2?$& " 88;G;PVSV\bkwwz}ƒ†wqdegoÔðÉUcU€utvnhlcTQQTQN<VJ,®¶Ë§˜›´“’žŠ€®•Œ±¾˜³mjÎzˆ•Œ¾•žâÒ××óÌ  'çñíÔìã # è3x  BID÷¡v§«‡¯Öf™vª”|r û:P—ƒÈôó`{§¨•R äD¥ZLûøÂ'âÛ%a‚¤¥1®€„o`clF4 ïð_XQZOŸª}—$û³¥ºÉÅ¡íë±™•vš©¯Ùé˜tHˆ³ón†ø¶¤œÌòìû O‹ÿÜ,®§Ä´sÄÇ£tŒãõàƧqtt¦·£¥{™šÐÅ€ciKµ§¹îå˜]c^_>C(9S[uœª£v‘”ŽŽ‘šŽ’‘ŽŠ‹ˆ…„}‚ŠxE]ijX6?<9<--**52,;DGY_S?-6?96?6@/ 11- A"%&#-)÷+$;$1:%ìÝÂú $5B[O/,9&DPnS>S_GeeegeŒˆ…€ƒ~‹‚tWvnC‹”{¨¨rr„•gYOSVSLHC]``½É´¨±¼§Ÿ“‡ª¤¡§ºÁŒ€š•Óš ¾Ö©Ä²¸ãáãÚêþü2õ Zþ6HY\|t 1gôÙþbZ}Al¬Zs”—ðCO< Ïï&H’©c ðéÁÜ‘:gSTÒáîP<„ß ð±z±z|„}ŠDYJþ> GGZ^X‘¡j¨«Æöv‡“±´§”»·›¨•]fO›´æ4ÿîÒ—½þ"€[_:‘À·™–›˜†‚«¶³·¶°–}‹¹žƒnjŠ¢¢›^bk¼´ª¶º¹“oÇXRWB;Ueˆ|~„¢rx‘„{{’w{{{lcOcfdjiU<**N9$<<<<&(4==4IU[U?N9?K??<6A5,;="># ##2é-(?L;þîôý"6.hbS/#&,8#)>;>&PYPk}wtsuvt}qsŒ¨”„]ŒÕœkpzš–xŠ„u{{zaTS\{‚{`oyÆÉÀ´±³¹½±“¨¿•¥·´ÐŒƒj‡«œœ±±½™ÀÂϺêñú%óEA(^pp`U_vvzµþñC9G  Ö}w[„>%B?L>F9ï*)>icM>ìØ%M[N$^L?ÉÓ,* =‚’¨ƒ•S@Tƒ›±³Â@|F(QKTZXmŠ‹BQ™´½´¬€‡·Âµs¥³©wXTV˜ ´¡¥¨ÊÀtšÛÛé  ïŒq³¤™­°•£«¹×àÛÂŒv€ÐÁ§¡”·Ÿ®‘_^UPAW°´ÑÆ¥ Žœo@=DRk…pOWxŠ‡––„{yaLZ^UUWWTZd]XTSQI?B<iK-'-06&.@C@LRROLQN'-! "2!;A?øìûôù "]d:#)[_R:>M8)2558bMD_Jh\heb{{{|zi\aˆ³Ãž|“¾‹n†› ‰tqh‰€bqdaY­JUc„‹‡À¹Ã·¨¤¤¢™™­’¢®¨ëÊ¡‰}–´´´“ÀÛ ŠÅÑãÞþ@$è& #ü_S<gq‘V,4JA4ÃóWG;íó+•—{t7#E#.KvUú4kderüb[jPV5V/%@ââ461Ah‹ùª”O@Fq¡¨Ü‰£\uP,J?HSUZz‰„¥r]xÀÒºµ€~’šš{i“¤¥œ€i\m›¨§Œ¶”™l—ÕÒÔý6@õÙ«j€•œ­ª˜™¡Â×Õ¶€s}ÐÐÔÄÉծÎe‹vk/B†¼ÀÅÏ´j‚…XP(IesgFKo‡‡“‡tˆyjor[URQT`mWOCACCBKHcH3!*-317CIIRRRLHOF4 " þü)+!>G30äñû÷(+cg:*( K”nP,5M;)5AVk­Œbh5_V\VV““”””bY\|žÕÐl’¿±˜ž’•}tqknzqh—Žˆf’°SNXq}™´›´±¨¤­–™±¥Š––“âiŠ¢ŸÀÃÉ¥ÏÛÒ£¸Óýç#IF(ì7‘ŸƒTsCMN?4ó½8'lJÞ8w¢‚W"þéÕ0tbKîð!X8{`_M¥LL4T>KÉ ÝÞÏÖ#2Fܾ užlLœ¹‘eT–7"*JK>bmeŒq_Sn°¦¡…‹´¡‰€‰i‘­v‡ª³Í´žØª¡¦r{ÆÆÆÐæýóû¸qzŠz}žÁ¢››‰˜¨„€m¸Íìõ·Òtd§zeQM›¥¡À±µŽozSbJ;VR^IE]~uoifls\h{‚‚ƒsn`afQ5?>62+*EE6*'-6<ELICR[CFIU`C<oK'!0- 2D= :A))/0!*íã  @^1fc=L 5 ñ'XO:72&,5J>SJ†‰}ÅGhJYShpppppYY\em±¢Q¥——‰ƒƒ…gv||sva[§n}\P_‚ˆ‹‘¯”…½¼¨±Ÿž³±Ø„š——šŸ“Ÿ–±É­È§žËÎ×Ô¦Õ¦¼å!663AE5(.*Hzz£Œ‰yJ‡˜TRSph~9(#EMYb:3Ë¿³"/)!Ó'I? |dSn%;J-HS,¾ÃÓä,agöùÖËk“˜Rir_LKºÎå”#2><e{‰zS_€•¤°­¬¦ œ›Œƒw‚’–®³µÓçÊÆÞg‚i|ŸÎÊÉÒìøòÉzXYl†wž²™•§­»»ºœ§­ÃáÛÕÄ»«t~qPE8Yfnrx£Û·¿ž«–r_\\Ycfo„–ufi|pcVrƒ…z}Qcc98;JH7D?!?<*9Z`K^gd7.RICCHFEW60H36 +38('*)èÖó3JQhEH%.PY<!!(.Y>8G2JMkq\be_\tPJ}€~tmtVYq\vsv›­|kuz‰€qeYwVMS\Wltdd§¡‘šŽÃÌ··Ÿ‰Œ¢«™š¹§—šœ~™¤ÔØÈ˪¡ÎÔÝÔ¬ç·ÀÝ (RZ,JJ=#)2 6Ylzzqt¡}’¥t5|T~v‰CUDV>LoV<Ø­µ=  &*âN‘‡#{]@_  Cçá'ÎÓØç,R™ü÷Ϻvœ’z{tr]HŠÜ<//;Y”‘aLmš£©²¶Ÿ¯¬œ€ƒzy‹›™’œ¤£¾Æмê³yd{½´®©ÈÚúò~JQr›†•¯–’›»»ÅÈɼ±Ÿ­øãÕÈÈȈzPQG>Bqof|ϵÀ¦©‘zriPku{~‡xox‰rWg‚ƒ‡yŠ˜W]W@;GJ?%,N0B9*<ioNnp[4.OFCCELIX4IX:"##<49/893/÷7<*AHW7%LO<36! 1eJPVJknzk_\V\_zYMh„‡Šwmn]Zcn{…­|txtlllcir]K02Xmot|ŒŸˆš®•±·´¢¢˜}Q¢¸žÎw_£Ÿ•žïíÓÍÇĸÙåßнÆÚäú<B?P"16/*0?aPlpjp˜©Ôá‹j˜t Ž•Ur(@Qv~]&í(*%ÿQ8ë$ÇDw3   IÕ"ïÁÏÙõ/LcøEzq­¨ª‘}}n‘nÜ),)PX]KT¨¥¢¥¬±®Ÿ–‰na]{¬£“ «ÔÇØ¿øÔU‘¤¨¬¤›Š§»}ŒŸžnNQ‰Œ­mozž²¶ÂÃÄÀãÚ¿ãâÖÏÒܱ‹™loS29Œ–U€~„‚ug€„yRST`oou{~š«ˆ´¶ž…YeiWTHD?'-%53*?E?THNfMIIUU1:@LOUL=%C@+ /85 ( "+/#"-2)5'¨oC[6BEMGD5#!2/,@S>GS’tVYhzkbw€ee\hipyvmh~uNT}Œ††‰Š‚tw{lW`c]WNLxj0Mk}…ƒÎ§¤·±œ¨«Ÿ¤›r™”‘Ç›† Ò¡­ÏìÖÖÙÍÐñôÓÊææçû8/&_5,BqL@55joyáï7?㱚¬•yŠµ²¨o…f|h~†zôìBo¼;¡övÕpZ\yvA<7ïÔãØúSÙ0iÖz§¯}‡|ei‹z|Í3†AJ6+WFR`cf‡Ÿ®··¯¹®¤¤ªŽvZky|¬´ÑÒòêÓ¯°Ìͳ†•’ŽŸ©zqrŠ”i<__z^cq•¡°ÒÊ»½ÈÈÂÇÏÍÉÆ»·¨£œ¥œƒbHAQ]s’}p…y‘ocdo‰x]c`f{‡ŸºÿùãŸfY]FQH2A (VEKNTWE`cW\UUUC=CF=4BH<u`N-ÿü  /b#)D5-C=);6*,''ddKD#q>/Ghkwkkhq‰hkez ˜}sstfZVn©˜žŠwxiXYofc„o'!<!)NQ†ªŠ”˜ª±÷º¨½¡œÈxe„¦¸¹¬–¶ƒž§É»Óíäºëôßâç *"'"VV@OˆU.Vg© "}y¶™Â˜ƒšsuyx“{[‰u‹c~“§2ñýHq¹b¿ðçLŒz…ˆxlU,&[V%ÙÏçï_# öÉw†ÐÈ‚‘™}€ww¶¨CAJ)HOlyoi‡‚š¦¥—±±±®©£ˆaoag‰¨±äǯÔõØØÀ  ߺ•ŒŒšž˜œ‹n’p?YMRqns‘¡²ÞÕÀæËÅÕçÇÍƽ­µ¯¨µ¬sI;bug:mXul”hWXy¶Ÿpkee}‰‰ƒ{ëTò±|ksAPJ-A (X\_YYYDPVYLIX^I%7CIH6HEŸxB0! !þ ãÞ>³%(D!<-98<J@*&4B.*;6-9jgSA’G&bnhqk__n†Œtkewĵ…qtzNB]¿£ª•{nU@I•g‚Rþþ7Hugh~s›«Ÿ·P ®È¡‘«®¤“x™œ¸{š|”‚„pŽÍíÑÅðíÚßH%SXjEP;<d>o¥v?*â">µ¨zitfwˆ„h‡‚œ ŠVø¶ö=h|ÔŠ /‘ÌØ®‘†j5& D0*M9' nÒÕ¿½‚~³ÄÅ´™”‰e{etpa?'FAaY—ƒcy~šŒ¤¡Â¶²¯¬© ”vgbck‡ŸÏÐÀä(ôŹzmúÄÊ•€{hjg[Sq¥.0V<u°—¸°Ï¶¹ÞÐÐÈëø½Æ¢Ì§¡“ µ§®±‘NFXa$+H]]T`lil¦ºodf«ŽÒÙÖŽûQ ÂnXg?AFN]G85CXf]`ZTTZ`i]]THE*ENHEYIa©dO7 .[@# "ª8.";> KU:M3E+6-/'KX_A#,/2Ah\eznajm‹mvssã¿bh_bttnˆ†nosd_nym@""Cdjvzztj…{ŸŠ6®Ù2¥¤¨‹ŠŽ|žªž¢˜ŽŽ…xXy¢ÐÀ«ÔàÖû9)¬na—-/5brÇДQègs°BŠ0eƒyrƒn…ž›}[;æ¬û 3 6‘ª¸”€w`O;$øbD3?-6$rPEŒŸ˜„½éÛ¶‘ƒ³¤ƒk–m)/dYd_Yls–~²®¬¦¦£¦£”vHMbjiw˜œš¶ íðóööæÕͤutMm‚o—Á/)*q”ºƒ– º´¼ÂÙÕ&?¹°™‡§¥¡ ¨¥±¹¤|UIG2C<K`„rcr{x{~ÂܧŸÇ«ƒvr¥~z_cW*r_INE;58FXKf]ixic]WfcQ?6`Q?ZÒzUjL1"4".Y, 7C€\6ì_1<5>5]dC/9]O7H'-:PG;8)>_ŒwtwbgjpyXmvjhtPƒ€ewt_jqh|sg½¡_†M@%%ìO^I{…zašŒ›tÔö¾½·§¢‰²‰×‹²Ž “†|”’J[ŸââǹÛÜ40{7|'ýø,oª'.)G¢‘3á:=?l.TYz-m—‰„k}hr’Štieh)ÁÞ ÿù'¤§ª‡zv`XDðô ;AB$3!$P'!r¡ž‚¥ËžŽ’Э’i…”p#&ùÿPJILYis™„•Ž°©¦£ £©©—TYlplq{}„Ÿ†òíüÔÔÞÏή©ˆz€Ag…q·Ï?&b}¤{•ž±ÉÉÂÑÿÊ3ë´‡¤¨«¨¥¦±µ¦‰maR9J?NcŠxfr{ˆ~Ž×Ÿ¡ˆvmNrRT0@:‚qOH<325@KKf`o~i`WNc`N<3TK<`ÞoTlB60HcÈ…  ...znW~C7./88TdmMTTUC?%<H:PSAA8Jh¤‰ƒw^eekheS_bhq}k‰†k€}bgnsŽyg„žbh0!-* 6?NjvX‘Œ¶›Ü¶u®±ž¬Ÿ¨Ž†›ô”’‘œž”‘‰·new†­°ÖßËÔòÙSjþF%†.8DO¡µbÃÈØ5äÄÓJ=\„„qzYqpoqƒwr}‰9ÙÔÔî÷×Í<r¾¿¹›‰m9 )/?-* &J'"U|]QAuž¶­–}\qV'Qü%" 7`kv|™„‡£ šš—£ £mlipuƒŠ’–¨²ÒÏùʹɸ˨ƒ>Dhdù `,&R^t›±©«ïݳ§ŸÌéñ„\otŠ ££§§Ÿœ…uhPGMTcluxxrill›Œ°~ƒŒjhxXj0VV4Z\UNWNMMFEc]lro{ri`TQH?9$BKKH2>88/##/JXB û =<X.F÷'"%*DIS?NC.9(" QEE4AP>Me\b}kkqaZTZB3BfTW•wƒYSw•˜€vyoptFhnE(3$33BB[hTdYu¦§Œ¥º‡ÆÛ°š½¿–´Ã¹›“¦ƒš‹•“­˜†€ÈÂÓ¹Ø/zbùö>ADF:+BJâÓ¦ÒÿšvfOPMXscPZ‰tq‚ÈvhW ⵟÁð¿ÝÜŸß“¨®®–dzvM  !ù--0< ýO3•Qûaœ¡¦”ƒ–S,h]9)5ABJco…‘gp——”£ šŽˆ‚|jjq†–Ÿ™‰´½¬Ô¢½Ï¿¨¦Qa^œ.÷x&BZ_„„¥íÒº`>_¦®²Š~* bŠ–«« “Žo}xezuWfrlcB?r|…wiXkqeV\oxsmFe`RstjffWƒ€^xl`‡cc{u±{oHEWf~9'6A7 //&üüÿ6D;-&.<  IJRjbT*+($.F1ù<!")Yee}z\}hheAQ`E--<TWNkP\JSwƒ†t[\Y[qv?3B3'$39-*/\peŽ”sku~±Â´¥Âº”°½´›—‚‘š–£—°»¸ûc6§Áî;Aep<;Aߦ¸‚¬Íp]J;^kL`r[u†ƒtn~²‰e-êÕ„¼(óû·]­¤Ô½ÃŸ™‚†k: >Wýýë  ,1"ÿgsõv‘«¨‹z‘‚sPPG& /2<\n~Žš—”¦š‘ˆsssmkw‚zŒŽ‰•·À©Î¥ ÒᵫƒWRŽÐ¹r(#>J;D{Raw´¨Žx`nį®“6G_{š™œŸ›–twts€ufcf`H'<UY]TIJOUYDcdinq`KANmhU`leƒ€dmli“]Z„®„cB?NWc<-0>1 ,,#"6Cb8#.M71*-/4++CMU[MBE4+:(ü<$+/YehtkYe_hkLKQ?*'6KQWYMSV_q}€nYga[diS++ 'E09E3Z7KBU`_s—ˆWn|‡–™±œ¹§–¡¦¢•u“˜¸…‘ «‘œ¶²¦°Ñ÷ÌA\UîC)ü=\A/ÎÎ_ZU^€ŒnSLN>L9EgrlTbŸ³~±®Mh«Üçê"Ýe¹ÝÖç«©ÁcHB>â/âúñ-+ 0@âd.dqg›Ÿ˜š§¥t‰>.b9øÊÞ !Gz†}†—‘……‘‘šš‚ijpg`‰…—€…`x«·ª±x\±¬·¾³š•u=jzf)$)3>*x ¤­»y€¶£œK8bij—–“xhlz„Z?6<0!,2fgaUOTW[SGOW_plctqtyso]xHElrolZKKNE<9'436<60-BE6:74;CTeh\G>)1@B'KpvVUIA<E ôß*!CGSbkbGMAV__F4(1"+IOI(DAq}bhkbSme\ZX9+KE<0$?<W${}xsq„o:Xz–«¥«šÆ±ž•’Ž‚¢˜”Á—±£¬§Ÿ°ÂijÛñŒ ùóáö)5j%ÿ`B*(GCYSc)Q•GLM[;m~u}—Ÿ­{œ‚@‘Ç-E¡5U«» ±…ƒ€K@üë»ð÷÷âú>PACh¬^ * 7St’˜¢’ŒŽ=#>A6$ýåðþ 'WkkbŽ|vˆŽ”…~uadichafZNQ€š¨Ï‰fl„‰¥¦Œrlwwn=<</  Gu°ý™‰« ëÁ’¥–žxSYjc^o|v]]w‡~uN9*$0'!+*$"#&AStHPG.%-#,sž‰UTc_hhm‚o6E?Q?H-Qio]oc3630@?WTHH0BB<C@:AHQLL_pV)8HB3Jw\VX^_]]@@3÷ãï!0OPVnn_GGDJA#06?'0NN'.>Jeh\\\\\SVYRO9*ùü-Eo*0K™c-YjRpŽž;Z~†´­µÁïŤ”Œ’|–†»¬§¨•©²¤³¼Æ£ÑØ  ¸Ó×**m 4 %/KEbMF$?ƒG[\dAgu“‘“£„›‚u”ÍEm¨¨V .y–w|khYlW!F èÄØð ñîâ"LULMcª\$(S’¤¥ •¡™šW4)2 ÷øõô*<ho…‘‘|ˆˆ‹‹xxmjiPhR„xv]wŽ£»Œx{‡¥¡„ect}qWHD?D;,Oy‚“—–§Â©è¼ewª„[gujJThj]T^€cKB-*3*$3.!Q[NiNF4& -#$bƒtONZfqhUxl<QKZKT6cioWrlT3*9L4TN?B9?BB=:7AHQC@PhW)6-3PVDX^g\T]IO9é¼Ô396OMYwnbSG>>,6KK-$-<<0@>YSP\\\_bSUS@:7üø F@^(+:mR'JOaddtJ?o|w‚¶¥«õÍŸ©ožª‘ªžÀÒ½»±¥Á¥´Õ/«ÙÑúùC8ÜÍ¿ &EvÀ0«0RŽT¤—I40;_Œ6ETZ~­È†°r•‘ˆ¿‡H R’v€Ñäç5r€sG>qWþÌä¸ëìUI\SD]Z/U½¼Šª°œ“‰«fBBèû!÷úûWw|‚“–­Žv£{~t~‚kINy“`{sšs^dvw€wnkKHclYu`QQQ\\K\\j{~c—ø|—˜I…:47?\fXDJ>MD?JU_69EDMGeY7@D>,f]G+#$‚“a{th3HrTcNOkStÓv€‹nteJVHLC1C56ARU9??2:CE<HQ?!6 þÚî$`IHYpwWeF7OYð»Ðõ5/LBHgRH?UXV1CR<0E+1J9*EH`ff`T+6B$(775]ZSzzeLG%lfC‘°uv œ‰Ž°²£¬³¥³ˆ†©­Ï¦ˆ—£„©Éæßâ÷ùù;õ¹·þ* /Nƒcs/;,&wj ?>v.23I=Fdr„–r]kMÅœ»Éš¹~vžˆzmˆÑAïâ,ˆ™¯FŒ{5%éýåèÍÍ)%5M>PM>V}t)#Ôç]z‚„”‘“€qZ-îäÜ÷  !hŽ—x“~¶¢šy’³Š{kgm_7>D\kvlYVGGHNNKKEQuur‡{ofc`ZK>E]r{™Ÿ„´YMƒªA),JA88PSnh_J;H3AMVw]fmA__5&;M> 66BMKNi¢âæugåwV`cfd[2_ezŒ¾—†|…’dPHUJ+)(BM?65>@>4;88B?2 2ã'Ý `YC@S^KVC';þå÷SM;:=Qh^I8&: 4M\G**0\S) @::CFFB4<B'òMWwtqv_}“²ƒ34-…¨©¡ys‚ˆy™˜®½Š‚p|«¤“™–±«ƒžª£«Åýàð4áðñ1_¢‰º[5,/6TEW%/J-+!8evu°Ô• uuÒåÆ·¬Z²ž›w4«}M«i¹Çä„eIljISò¸åØ2&>G>ntú;nWudki|ª—„˜š{‡]/ó $HB!ßâ0D`“±ùÚ¢“™o‡n³oT„Š—ƒpwJ>L`enVMKHKKWQZl]‡Š~fcTNBJWZKTc~r~{vZWTxxWTflfW]iforiZ`fs|ŽÎšXjlc96TNB3BZZN<8…“‡eTj‘€qfo`7FMqtebÓÙ‰‘‘w4*6^fW45@62?B5AFG:52;BN2/ L>J<+G]j'ö÷ 6*B4)606:(ûó>PV<5SJ,ú%I=FIF?RH!ôÜÊ× J_•Œnssƒœ†…iIN|‹ÑˆˆšŒ€¨ž«¸Ž‘Žˆ¯¬Ž—Š•’‚‡Å¯¨¼îóÝ5i5ÿ ô÷øƯ=O7<0%-?/cC$3;bso•¸Š–f“ºûÖª„ÜÓ?⪴{/“me¯Ò̽ajZ¼—dkû¶֥ë 5JG)ÿež>A\b€{nbrª–ƒ–œˆ‘ oD!]Q6îî3>Qw§Ô¦–‡È”l‘]M‚„—}tMGafnte_]QNQ`QTi]{{{ZTE?<O`]BKQloxqZff`ruruxuccuciorol‚…‹ Úéµp^WrK3KHB?BOUXSRt‹uWi…yŒ‰`cT4FJk€}zÐÓ†ˆ}^$3\ZI0>@+)EN;DFC@82DEN/8#'ëþJ@9 ;S_ èë,**1"=. ú)##1(þ ÿ8A>9$>A2&C[ ILLC:O? ÷èÜß(D\•†qnyŽy•¢Œ|EE{v}«˜©™”±§˜’ž™—Ž{“‘²°†¹ºª¼ÒÏÔÛý ïÍÚeRðÖþ÷Džez* k/#' t7ì 7MA[lyueypm›n”š´à„^8/öV iF¾4½¦»KI^°%8LþÛ«ÅÔõ ý+OUL=(^ºrˆiNQ’ŽŠŒ‘Ð -så 0?KQ0GQ]¢œ^{f×…‚bXWƒ’¯ïõh>AXfnekwrWKKW?Eo~i`li?6''0BV_DV€hn}w…£pysŽŽ‹|”‘dFUsgdjvq‰‡³u•^Rd[1=IOA[bgecRXdZg^ŽnV969Odz}ƒzt[-@‚LET`O=+8#+8EEGJI:L>8PN3 A;7*ìø GbPêÚã!F066SG$úW@ ÿ4,<92A8%:@C.+IIC.(ëîÙ4Fg—‚‹|v‚…Ñ´† ]ZN‚•l«¡¥¡’žƒyz›”¨¢¢œ…Š±¿¦«Ý˜½ÛÔ䯆öù(–©X íð  '3//&:QF% î GJB;LY_dcqu™ªê©¢Ð`5•P›ß¹‚Ÿdy”VøC*׫ $0'`Z'!F‰´ÒÁŒ†€ Ÿ—‹–ŒçÀ.?e N-6)‘¸€8EOQ±Ón@Mt–¥´„_DGUTetk\N39<BHQl~‡roKBKKBEYVYqnet}zmvˆ‹sˆ‘‘‹vX[gvspjdj‚ui¢ÌmhSIF^…‚aaadbgvkhowYNL^vmtkE?'O[wz}}}…Ž’mVKI\W*;*!",<BPMI17;GDBQ,2P5"4FI?!#  âñ)T6H–47 êñ #3)"3-D€qP71(O:%%ßÙÜNIRr†’ƒ˜§†vˆ³–˜—‡„mkx®Ã³›—‰‘|„ˆœ‚»¡™š‹‹œ´¹”×í«ÌÔÊŒ\×ñ H¿ÜØø<öã÷ëç #DC4XTýñ>9>ATKJX`pj™¯øο­ñi;GË‘—Ýɪr–etTg‚Kò,¦I=ã¢æ6NZ$:^£«¬‘ ²'Zv•––Ó†¸ÁL úýúý'B2£¾z&,60¬ÈbJT]…„aloSADRQYhhJE3'0BKQf~„{ZB]cZZymjvm||yvs…‚‹‹v…yy‚da^jssspjmo‡xl…†_ZH04^……ddddbbmalxwY?OoyjtqQN3LRhw†€z|mkIWRJOI:  0-#36MMC8=AGA<W58S>-$IB:($ úéô$,G3‚5+é/7C-222/5eYLC/;I%1 ôÐÙß$r[[—‘ˆ Ä›’¤³ž‘Š‘vim}ûûÓ¢¥}ž•®¶¥™ª•˜¨ÀÆÏœ¼®ÃÌ×-÷ÇÒæ=1¹ïàÅ(aäÿçë%)+ Ýú-6'/#7E-0BhXruŠ©ÃÅã°VÖeǯ†“×’{euvwg ~GOWé·ªËê-öùü JjWŠ·ŽÄŒA}nk|—’k8 ú!6DQTC;p3>hA_XUpp„VMVPPJJJLN>A8DTQ'9``QBfcuroTWNZ‡~u{Š™„xry…““Š‡‡„{`cllir~ui‡z„–™‡|‰~cTNBKZrolfaadYn~NlƒŒjmˆteZo`ypwƒ€e\dUPOYWN=:7*-2#úEEGG=DXY\SNWDDPMG>6;?  êÊâÞÛóG5%-!$-*)$2Ia‹¿SG;.1&&."=JDD-IL     ôßúNg|~‡’‰ˆ™½¶Ä•ŽœŽ~I„—¡Éĸ¶ª§ƒz€‰†°—¸¾¡©œ“”™”¥º·¿°ÑËÍþNçêèÖáÃËüÝþñÚû   óöì!.3-9BN-9dN?|z ,Öîå·ax29t¡§¹ùlLVx„}#«Ø”<% ¼³Ò¾Ã &#&RZx~‰—©‹kH0JdCyUpPô÷H-?R@F\J&5%9gtmocG?PbXbbYINPYDPZZ<BW]K9rfr]ofZ]o~rlu‡~xuvjœrlliifilouf›‘pˆšqufcR`c]`x{uof`dvidjmqt]ma‚eY]{o|a€}qeb[dY[IOL3:C?>>B9 )KEJ;=DFJSSQKGDGPI:*+*û÷àí+#ó=)HÖÌý>UE^oŠhOD;&þDM,@7=;;;?U+øì×Ó÷ô E…£~Œ˜—±­¸¸‹’‹¨‹oa“©ÅâòÀ¹¶·§}—–ŸŸ‹¥»¢¤›t« ³s·¨£¸ÞÑÅÇã6kúåÏÑÊóé÷Ñ×ñè÷ ýÛúÿùÚ4Cs529?l11XNN•n}‡B^×Ú»5 5Î%‚…‹¾p•_h{_;ûxM¹©Ò»Ìÿ#  #Xlw`G‘©¾T03AIsŽPöúôë33JULNrT   MYXi<QG8Yaii]GJblZMTT<<HWH<{{Zrifu„oupsˆ…||vrc‡ŠŠ yXR_da^luo„uf¡¸ˆ—©z{ccZY][LX~ztf^g|rcdjfTVvaw\Y`{lpIztnon[gYRBMM4;N?9B\T-B9L8@A4;GKHHGDDNI5$äÕÞÒðü. !R1BöÚ÷-l“kgr‡lR))ì÷3? 0*>2285F(òêðòñõ ûCpnˆ‰¡ª¯®ç“ƒ uz‹¡ÉÂܨ­–¬©›°¥š”¡¶—¨‹£¨¨›•¯“­¤°Øéà×ûñI@Pì÷ïõþèÒöÏÑÚåà#çêü "^-A/1Yo`;Tg–`=sAj°Ü¥ˆTpPX¸²g…‚hjgQô'þóÊ©½àËÇð  kqtke}Œ_nuFõ2;óãÒ!3 ]p8;|r<!&8>T`aMl^7bGbVMSPVYbYWQE?BHHKG<ZHuQ<Tcx«…sms|XUyŠ‚‹Š‚t~XQX`\eƒ‚o”‘wˆ‡|pgLXCLX=@7;LBioo–šl{fTQ`i````]c`]ZZRzwb__SS\_____bMGMP/>JMMYP\PKKKHHTEHWHUHäåêÛACru+áñý3<RY_HSö çÿúãä#&TO`WlcòÝfj6 äÁ±ã¶¾äñìÞ9F˜mZršÈ¶ž³ž¡‰HB-~ÌÅìÒÇÓ˜™¾©Ë˜–‹‚ƒŒ¯¢‘”–Ÿ‰©©®­°²çżÔòèýëñìØÓååõïÈîæìÝÑêÞØæ7$B&%*4>H?K›†P~\Œ„‚L™Z9„‰AáLª¡‚l[^uj^DBQc\ü!Ý’Êä±åä #, )Abq€hhY@g.&ÒðêïÖ¾îÛýçîJA7Q*-,/PbMGDJRYVPVbheb_\ZTTTBQWH2$<*<-?]y|s^gF=X~~|xsnkd`WQM_ƒˆ‡yŒyfg[dF7=@~r[WFI[m„„U“~~r`KQWKQ`]WHB?931bnhk\\\bihhhhbAJb8DPSPMSSPPQQTWZr`cl]<1 ÓÙC2!1.-"0*-C.4C$2ðÒ½ÌÓÝæ)/\ÎÛÀixü¨FûùÙÁ«²¼µÉÞàÆæ—f[ZZ]¦¨ž¢­”kkh†­£¿»ÇÌ™ª¸µÔ•¤”‹}vœ¸”|Š¥¡¡©¦°§¿Íç¼°Ó÷æÙìÑÙßìçáäëñîÊåÐݹÂçáä 8õ:,NMTŒ~<nMu„“fY[:Ÿnס®~co„mR/_>A@줬дíú$8A#%(OdŽdšKkR4êÌÕµ] èñÊè÷úâÑâ476ñ1,&DVJ>ASV`>;Mhnhe\UQKQWTcfQ6/<*E*09NX]ircoTEKpxuomhhig^HDVzsyzxŽ|py=:FLk_TYKT\baQ=‡xo]cHKTNQW]]QNKEC5eqknY_beihhhhbAJb8PVVJGMPMPWWWWWfQTZH6 áó3N80,+û;BG6*4ÝÿáÌÉÐÝá#:ÜÏclr¾ªz4ïåÚÌÁ¾¸ÖôõŸÔÔOaI*M™«§±¿§†††}˜ãÓÚÝœª£²¶­­©¦ž”Šš „Ÿ·º–¥—†¦°Ä§ÐÚÞõõ&ý÷âàßÜÜêýîÓÒÆ:ïÎÈç4ôè×Ï»ÈÙ38mlFK6NL>_û;®Zd‡³¨†5VÔ|}E9]tq[RlFa(#"Ëʲ6!þ <CORLJ>,&5t€­KYo% Û kùóáÕÝ 7ÿç)JF402AFHVkV9KZ`c``]ZTN`olc]H9>9KQT<*-?Q[O‚pvmavodY\eknqx_Yb€yy††y|vaX[daEHFO^ZcdlNuiZ<EWHQflf`cirv_~iiTfli`````cNHNQWWQ?9BBTTccWKEB--09'52(0B, !3ðöA)RY?%ËÞîÑ·ÈÕäÉ´»Ú×^ju)FF4A%Sÿþ ù¸Àèöñôí1En• •†¬…s‚•¶Ë£·ôÝĬŸ’² ¡°‚¦¹¯§·¨Þ¥ØÌ™‘€¾Êžùâ·ìúòô÷FìÅÒïÜÿÃÃæÅÇÓÆäàøæãÎÇÙ!GRZa]L3—™r½šGCMŠw”w$X^ö7K¨dgŸQ53^/? ûäÛâ6D<TQdXCC:UUˆhg_?T;/ôØèíóçÎÔáÌ2=2 ùóí#}yI%*><HYD,NcZB]`cfoi]cirKBNNM??KcN-3?iiifc?cZfB;YkbMewzt’Œwt|rjs€bKv|vyv|dRdxcfdjmyiTW„“ZHfxcixuoc]]`j]‡cWfriccrroZNNZcc]Zc]H?ZKKKTcoQKN09HAEa:!UO. $,/9>Ue/°¹“£œ¥¼º±®½ÊÝã/A',>$ü*%. þêä(%ÕÉÍÌíèìé×ø,‹—p…ˆ›<LˆÑ ¹ÁÐ_åÕ˪¢¾»•™‘¾Å™¾Ã«ÛçÛ½—µ´Í®É’®äÏÉÈ?lõ.J9ѦÕÏó4¸ÚÔÓÅÏäÛõî õãôû  1@HRQIUƒfxT[P?pf]¯ŽkB$ü4Tžccx4DcÄfAôåçðç $A *`Z^RFIC+@ˆjtb7XG5÷àïö öãÑÛãÝ! ýø #hjR<D8?N\<BccZcfilql``foKETPfKEKQB39QY]```]xif9ETbeehttnnnkedupvwRNs|^^dLFOentv|||wr]Wox]NcxNTirrlfciqTufiuoifclol]QHW`fc`ZQNNQHHNfolE<c<<B>E[7"@@..ó>PVJ6SeH+¯¯‰¡“™ª±®¥·ÁÑç/;#6 ø2âáô $ƺÇÏêíððß#b€à}vx—Tp¨ºÛºÃá_ÖÍÁ¢Í”}†Š|Ž¶º ñÔ«šŽ„䛜˜™ƒ‡ïÞÙOöï*î!Ù¯àð©»â íáØçþî  ö<ôìú #/<?@€U¿¬p'5oqTamJ8òâënÈ”–™adLE=%3€ðó ÏAý.CHEN`Z*$WKKypK?YYBüççðüäêàÍ îíñõÿä":7Gb_eG;AYMPPMMP_behqof`]W?<NDN3Tf`fWHBMMP\e_nSJ7:LZnkjicehqkjr|w^fd‚ˆpXUULYM[—v|tdul`QNiicx{xiTKricchZS_w}hkke`eeeeVYYVVSJJSYJA8A{uW3**o„>DJ8/$+CØÿN[^D&'/:ø¾Ž˜¨¨•“¥“¥£­ä%  D)èëÝáóú $󵯻»»©·ÌÆ ZË‘’[]‹¶_Vww§“µ¼³Œ„ŽžŒ]ˆ”¼«´èè°®©£ºá ¢­•¤œžz¡ëžöÛÂâ¼ÆÓåã±óÁÒÿûíÕÞØðòù) ö)6<DAJGJ+.)QGtÓ¦cAFÖ¦² ð·romXˆW<C8)#áääùÿ.†n;64LaXLŽ‘8mswXn`'÷üöÞÐ3 /-Ê8H[OOY20QaQLRU[FLLR]ciifW??B,TQEB?Tfulf]KHN*3#-CFJnigmkbJGOWaah‚i^^[L74+4JC?GEBDK^imllfcoxr~Š{rriZTNPcbY_e_qthhe_ehYJA55>MPA8MG28iW366TE?<8OR?DJ2!)D& "cddeg+:(:7]öÒ«ÈÆž„ŸŸ“”¤±á÷ÿÕñüáÛÛË üþÕÙÍÍ·–®ÍÜëÚå)tqjˆzv„¥c^W¥Ö”°Ã¥˜‹¬³›€©£¼¥«©²¡–  ¥Æ™¼˜°¨§}§ ²ÑÀíèÜÞ·å̼.ÙÇÆóàçÒáÏäü  .429@>5CI."å))89/É”n<=èu¬SðyXOUO"1(÷ ðøØÕóû"bM;31L^RU‚s!\s‰mƒS1&(!ðù $4#):)'ßGS]U[J9@XTSUUURLORUTZlollWQN3_rK<KNiŠ{i]<-0-$B<66=FVpimznhVGFKI=Anf^C:771%4TW]MHC:=Uo|ullio{{ŠxruocZTUPkYYe\twhnh_beD8228JJD;8DG8JqW*03*6?EJXXAK[8&7&'5]hmh^7%?Kiý𺭴˜Ÿ«”ª•ÀáúÕÏÊÚò÷â öèâÞäÜâÏŸ£Üã àìþ2Šdhsml„ICu©Ë—ªÈ¨Ü•Ë©½Ç”¯±ÕÈs”¿ªÄ“ÆÝàȯ™Äº“¸˜Èû:AÔÒîûàõ¨À¿ÛÌ·ÞØÕõ*<L,.b C&]ü M@EY36q‚„ " l~‡6*<*H SZ["0<áãÛØÒäñ-?1NK^mVˆ†@'&\‘󕜖mU))[ 80#-5?BAKMNOOF@ICRE<?NYYke;V\V\†€h\_nJDSPr…|y‹…|msJbA;>GYbe_ehppsz}ƒ˜‘ˆyd[R9<17:@L(4pa–Ž†tnpng_zy€k}Œ\neb€}qbbqbYPMPasyyUg‚mnnW«Õ"VNY*/SP)JD;5VIB3**0*!<6PPi]MA (@OPgLZ?4#u{Y%ü²±êo¯¸®–´‘®ÊÕëÛÜ ™á"ØÐ÷åáëôÕÞÍÇÏ»ÀÑÎú6÷ì]QQ aPHþ/Q`omZœ¨Ÿ|Ó§¥ÇÕܱ¾·©—o¡Ðá¹Ý¤¸ÜÝij×× ¹ó30ØåáÛðíÏÕÏÌÑÞ´ÕÛìö#i R+&+7÷ñìa}aiS™ð>:]E67 )AAn222>[<Ru”W<&ö×Ô´³ØÖÙâý  /XXnŠ‹gRRvˆ˜¢—ÖssJ2)CHBK%OADVxcaUI7<Zl]TNKNRk\\YD\nebzwkhh}qt}e‹‡„{‡‡‰˜zJ;eeeYMpux{~~~‘‹sdCˆ‚Lg]<TE`l«x‘¹•’¡€bMt|ygjpg‹…myvvvss[Um`ilf`]ixiYGÞ§€@º­{쀉\;)/DPSDKT<*-3<B0WfQ]KN*6LLR`e\EŠ¢ GDIŒŒs¦ÇÙ¤˜†§¡‰žÎÃæ湯µÆ C,Aç¢ØðóßÍÖƹ¼çëï 'E4ÞíèÿúW./!fMT^¯¥¸‘×Êñ ]æ¿¥ž•˜©£°º¾ °‘èìÑÇÄÇ&ŠâÑÞßÏã̱ÞðºêÛÕÈ®ÆðùÝ&.;€_" "',?C%áÞ.acYTTsl‡~EbUs7R7++  Umd‚Š“É!ëõóøô»ÇÐ6]_gkab&BZZm ª…u16PdX:fQ@HW]c]`fivl]oluuoW:PkhV;hzqntttqnhn}ƒ_„Š‡–Ÿwƒ›€zƒ€}}~ƒ‰‰Œ†}}€„„{rux¢“]§q•’§†ª­¡°æª’•€†}hwsma[Uys[‘…yd^ddgeoocQKKQKEDMp~ƒ´õ­Ê•t5VD2)>VYWNEEHHWfBK`Tl]EKKfpppoqnWlWK_V?^U~-ñ¹¸¾íÑ¿‘µÃ¹ÕøôÜðáÜÙéBA9$*åßлÙÝ×ÍùScR76?4PPQ!$0*@5*B¥{B‡~Z¶«Õ¦ÿñZ븴  ©¯œ¡´ÈΑ¡ÍÖÍÐÓÁöQÿâæË®âŹҷÀÕÆØÛÏÈ«áðùã5:J\P9ÿ ,C/êë)æFI (P‡‹{WT°;^F^=^gp¬¨¢Ð(Ýø?N[ýâö»ý)$KMYdQY$6<>b]]1Q†{OGu]HQ]]Z]`lxŽ{`rx{~`:JheVJqwqwwzzqk_eqz\|“„–““œŽŒžwqŒ†ƒ†Ž†‰’‰}wzuxxu–ŸlŽ³…ˆ—Ž¦Í©Ž}¤‰‰’q††wysvg^^ šdpjv‹y^jmaOkl`NHHK<<Oxexk¤ÍÇ}‚e5PV;)2MTNHKQTZciW`lNTBE`iunsyrkp`Z$[[[Ji_RúÅÀÑÒáÑÂÇÍÜÀËêçÆêçþ?<?*3ëÿùë;BZUCKN<CRS$*!QjJZÏ™-vi:·º¸%ÿAy ¶ò«Ì£¿Ì³¦æ-‡˜©´ÅÁÚòÒù *ݶÙßá´¿ÏÉ¥ºä®ÒÃËáÉØõû .Rèò ò÷)BN Ý  '1ˆŒ€xfO?zz/Mƒ}Gb|„šQ.…FñCW¡¡WJ0-0(Ó$:CK]iASOA83+5dPragZ‡†ExšQ„k^duqqqqvrx`~Š{XYVAMƒ€nh†ƒƒƒnbebk}h‘½u]‡Ÿ–‡‹|Žjpˆymm“–™œ{ur_js”££¯§”•¡òÔ¤Ô˜¡˜›˜•Œ‰}t‘vpˆyjaXRjpdpˆmypms|ei`NH`]BHWxbib‡¨’’\wh2PAG82,5Y_Ybwqe€HZH]KQfx‡bm…oYX]i3BeQï)ñˆ®œ†äçäù³ÅÒ÷üâû..NE1*8\ƒ;SbDIFL=47yILOjUIYM*'/ù Fy[’–±zk&NOJ·ÛÀþìÊ­­±Í̋Ͻ»ϲ“Ê°¹¸Ø_9úî×ÝÃËǹÈÏÕÞÕÕÛÞ¥ÑÒí çõ,"êð ûñ.ü  ɶ:6<J{ƒ˜° `b^v:ad[@@WQb=Y^,&?H<iˆƒzH-õ=BT;T`?;<_ldZW`g]CN€_H~u{fhnowzypmr{„‡uuri^>SPShhqzwzznhz‰‰ws„ro{{~~urlrx„„Š˜–œœ¥xr‡•°˜›•Œ††Žš¡†þ¼’ž¡•ž•’­­Œžq”jsdsvsss^gvgvmjv…kx{roH39KH‡rremua†‰¢>S,GYVDARX^[asgjvd¡]WQfc]`KJLFHPpE39W?7õÌͼÒÔÉóÏåý¹ÃãæáâòBq}{eAM0÷EloZKE_q€bv†AMPhbS\ew£ õVéªw‹ˆj>m~h®ÏÍ߯´ÔµžôQ¸ˆÁÂkÉÅ©´ª®î¬¦¬Ìô«K ùãíìÉØÉÆÁÞöáÒÞÉÀ¥éÛäÿ ðé&)üÿÿ õ Õ5 ̹RXWF>Š”œ·¬eV@v"@gR==KNf›‰I›O9HT0¤Ÿ’K)êù*OB`v>TJj{rafaYZ_ËuO†oomhhp€€|opu{„‡rxxlX8PVYqkkqƒtw€}w€•ƒ…~ii~xxruyyv‚ˆ‚‹‹…}’–“¨®‡~¹Ó v…—Žˆ…‹ µ^‹ˆšš—›’’¤§˜¤˜w•|mvyyyypyˆvdsdav•orrfcKQKEH]zme‘~dpvs2D5Vb___Yek_hqkqnI§uQZxif]ER^[<MhB-*?+ ìÖÖ´ÅÞ­©±Éô ÛÍï×ÙØí^·‡vk.<1øvšUgpDe‰¥otjLJ>rnWU[yÅ´)>¡op[A]Z<ˆ‡_í¼¯³¹ÀÑÇ õ½²½Ð´urœŸƒÄ ̽ûùØŠãøÂêÁ¿´Å°É·½ÉÀÌÌƺÀÝáäçóÿø#& E%1ä èíêfg#ý;VvŒ:¦¤Ÿ¢œ—Ÿy^švXLF:Pe£ŽpÕè†jWY™äÇʱQ2õòð=[6W„„s]ŸŸÀŽ„tmŒŠ’£‡©Ö€vlkmqsoc|~„‡ŠŠ‡uaewnn€PSb‰qtthb€‰’…‡„{iruilpqq€‰}qql‘‹‚‹‚sy”²¶°Ô°¶ª¡›š’vjj—”‹……’’’˜˜¡›†‰‘yyyagjmpmddjR^a^S?<99<``TZwq¦—ÊÀ‹3"X8;GbVYkkmu{r{~ffun5]6H]‡‡fŠsjm~tJB6ÎÞèõåÜÝöì÷Ñ&4 áT­¨BDPîýE6ld\w‡bpDE9I’…U82]dU^7O7D84+FpUƉ•±²1šÄ²÷Ј³®„|™œ›Å¼³Äê¥õØâ¥Ç±š£ª²ËåÏÀÕÞÉÞÏÞÂÒùóéÛPT@B.ÌÐþ\_vQ@93ac…O«ˆ–¤®¼Á¶›Œ†ƒ†q_JLkdje™µ´Ì²š+fñâ²jM&÷ªÜþv;p· ½§¶®€uo~£³ÞËss}dqy€…‡‡„„ŠrcTXbwqqƒzPGPkntqnnqw€‰”‡“–rour‰†€ƒ‰›Œ•¡¬Šœ®¥™™¨¦°Ñ칪¡•”Ÿ[sˆ²š”©‹ˆ’Œ€‰t€††}|apvp[djsgmm[RagdYHEQio]`l{‹Ž/”gp[z¤eSMDYY_b‚ur„r]Z`MP{``i{~aagcVVE6úÐÁÂËÆÏíä  931='"|€:?­Â¢V00!0QxuŠWˆŒŒ‚rŒtŠ¬_X=7;YŠ„ˆQ:FF åï47Ä¢…‰’œ|“¯Ë§»‘¼Ïè­†¯»«ÅÌÑÃ}œ¸Ö¦±¾ž£¦»ÑþʸÌÆÒäÏáÃÍÿáþþ(9C<@6íöÕïòPA¦mQ9AtWxX¨|uŸ©—‘¯—‚‚‰•€kOEaJb{ ¬Ê°Î=]Ÿ\;9üˆoSG"¿ÓÙÁ1A^Ð>££Ð½’‡ŠŽ”š–í ãsu„a{ƒ‘’ˆˆ…‚‚^I@LMehn†kJDYhkz€€hhnzƒ ™“ro{x—•ŒŒ›¤ª­ª¬ µ»¦¬—””»¶•ÝãѶª©¯lf{«¥¥À™ˆŒz†ht}†yqXjsmampyŠrde\`fr{cQEHKWf{ƒƒqN9šw†s›_em^^aaa†rk’ƒdXVM&°´r‡~l„ul~YY;UZ6À¥²Þä×úìù Sõö43N-9•9ym„fk)63'Kž€€r®…‚ub}Œ·ºÒ>;/<HUšŽ€OASWÿÎÔ 1Ĉ’‡vuv¶ÅÒÀ­·¦Á½ ƒ…±¼ÌÕèÐÕ³œê©š˜®À´¸¤Å¿ÂÄÃØæÝÊ×Õæùç $&0dYe#ôñ  ýÎMŒ]BD4lŸ‰Îž‘¡€—²‚©º‡vi}VQk™¥©Á?Ó³qX|Ý¥±lÑÚÖòëGŽÂª‡¦uµ£‘‚Xd‚”—£Æ®{iok‚‡«‰‰ƒ€€}YS_\_uxu{„iTN{{{„‡xNHi~‹„i~©Â¤ž€€‰’¡ªÇì°¡›§§ª¶ÅËÎ˼¤²¶³.õ†§¤_žž†w†zz}}|~cW?3TruxsiWPE9QYdqB33-'?cuŠ’œ¨™Š„~xvœJx{bikdfRh_TS5).G¨ßŽš»—‚sŽÔ¨UUM4Hl~鶵ÉßåÇ÷ÓôÖÜïðÞ 8„3'=¯\€‹‘}k@C>a==POewnnzn•€ÅA1Cˆ‚v‘|VF6D2>1JV,…nh~joy¶ÔÀÌÑÉÓÙÀ‘‰ˆ™ ªÖÄϯʑÓÊÇ­ª¨Øñ˜¶ÂÇÏÒØÝßßåÍÞóö t<vE= 4%&Oy'ñ.Y=Rln¥lLP†¡ˆŽ‘Šx‘ƒwN_ƒz€t§¦—mQN` ÷¸²y ×æíãÿ(c`œÌÅ壠‹£‚j|²¾ Š~~Š~P…~±¶ªƒwz}\Veen`ruWlf]c„x~„‡N?c„ˆ®·¢xŠ¨ù¨‹ª›¡ƒ›ž¡ª­Ä ȶþ°ª°³³¶¶È³›¯°˜¤­žž†h‰ƒ‰›’†€zqjiTTE93Ti`A8;C.!5-62E6<H9Wl‘“–•’†‘‘sM7c†e[€ukUHGeeJ;55@Obd‹—Á‘¯µ£š€FHII3F¼Ä°µ±½Ê–„›9*þØÈ"1ú  I.n›r:=ISUyQ=AY^s^m…¸‚©‡k_¡ª€ƒ†‰f[UQ%ýþ6nM&€zk{pr¢¼ÂÃÜÉåß—ˆ’š™š¥ÔÂÙ¢´€×ÙÇ¡­¥Ø̺‰£¾ÇÏÒÌÑÙîñÐØæõö qF·pT!& 7 &"6 î U;L^kƒR>WŒŸƒˆ‹klˆmš¡œˆ„Re‡nbK†_96e<þß¼˜wJêëêí=1|ÁÜ¿™â²¯¦yy£¬š‘wlxuV‘“uœ¹­†z}†_V\Vxi{~`oZQlx{~xxZZ~Ž—½Æ´Š“®ü«•ªžŒ§§§ªª²¾¦¯èµ©£©¬¯µ»¾»¯ šÁ­­­˜ªŒ­¡€†¤Å˜€zwqns]`TH3K]T2& 74&'1E6<H6<Kx‡“ •ŽgA@~‘ykwmUXZZ_P+M_bXmo™u‡„¢·Ò…m;9:F@9|ÄÏ̹ž˜™‹µ@4#Õ74$( "c‚N DY]e[SJUOg^j|‹¦s¯ie\nƒ€‰ƒ_jkh2'BY@4Šžx‹‡×Ñ&ÍÕÌèǬµ¹ –œ»ÆÚ¢ÏÀŸœÂ¡ÍžÎ¼«˜±½ÌÒÔÇÐçÛØÜï 8:C>6\Ož7F/L&B*î8&Q\|pJY—†vn€kz{¤ƒ”Ÿ¦±nLM',=Ug@‘-ø¥°£Õ­w)åíÿÜðý|‡Æ Б|vv‹‹|ˆ†luz‹‡x{qnheewSJSMcx{x~x`Q]rroifo`f¨´´´±Š“¡¶›¤°­ª¤¡¤¹Å¼¤ª°¡’¤¤ž›˜›­ª›§¹ƒ€Œ‰}˜ª‰ÅÝhz‰€weYffZNWKEH57)G<7?55/)>>>>w‚™€eYWeš”€¯¤Žt_8%1'SOSr‚iL›qV›wn§eaJQ[UF!þÿÕÊ·¤¾šr„¿çƒA!3EVVXmY yS* aa\btiE?Uj‘‚s—Á©lu~cZf„doaOYA øþ% €eu‹~¢ÈàêÜÌØÐÐÓ¬°¸™ÍèáÕÿس…³©©±¹¶Åžu•ÉÒËÔÖÓÏÅÂäñ /ú £:Iar(\‚ì›@Z%:-ÔÂæ5U†y7n~oXC]JDUo…˜}‰Š—W86. %[`&˜ìâ,Ávµ¥X( VEïìÙùñÙM`„‹‘ˆs‘”|Žt–¥†…uufG85_etwth\ENx~`iW]uiZllx~„y”‡œºÀÀ¨–ª°¹°¤¹¹³¡’‹”£¬µ—Žgˆ‹Ž‘”—¦‹§•ƒƒ††z’’ƒƒ†w˜’S87BQZZN3$^;8LKFI`vstb>2bzqh¨t²øžNmjl³ „nˆ—‰s_ éàù'ò[xgq\›\eb¶}GeL7/dn@*þÒÚʨǯßä2qr‹D"?]<Np`ru'+6WH&npjˆvd‚Pp…Á² ©|‹š’€e}}hweqapePC@þîãï}}kxŽ…°ÅɴȺ¾»Ÿ©°¾–ŸÛèÜ×ëή‘«Á¶¨¥Ÿ“™°–¢ÉÈÊÐÓÏËÈÅÛñïöòsôSliYsŸRE -!"ÛÄî÷*\u~Lu†m)5NGG^Wj†}z~…eI2!'8@lq-uØË«®º†ØͧoLíááóùWUD\…|jv‘©Žˆ{–Šœ†yluuSG>_bn€†zbJTux]floxrfQZWTl{“œ”™®´´®Ÿ£§¶¶³¼¼¹¤’‘š£¦¦¦ š…‹Ž‘”—£‹‹—‹ž•Œ‰‰€wŒ‰}}€_}}VIZT`]WK?6'%FQOOSd{rqe\Ynƒ}tryÿ ¡}ˆxi¤‰smvw_GÛÙêíGaYf_ƒSkh†V/G++2GNCûÎÒ&ÄÊ¥ãæÔå-rlzTRH:WBY][q[ùý9?<F/zjdj­›{e…‹  šÇ © †|jsvgvd|paqnKBü€~}‡”“¿Îƨ³ÉßÙÞ ­Ê«¶ÌÝäùø݇‹¤´¶Àœ°’È»ÇÍÏËËËÈÄÛY::9)&cL^²Ü[dG6 /Û»çó%Hwglxk~} "BTvjt«¢«£}yx6AUX„Ps»«Â¸¡‘²¶µŽMüÑÉÖ7&é"'Ghvvmjp|‚‚šŸ™x~€jfrŠwqhz†’ž¡wbiol]r„„oi]TZT`r{‡‡yŸ¢¢±áÕ«©­¹Åȹ°ª’‚Šœ¥¢–œ{o{““–œœ¢Š“‚›˜zn}Œzwkkk}†‰’ŠflfWQEQixLG^Wilou|}cZ~x‡~•‘kG[`Ybš£|—Šwt* è™»ú,:>U]KKK<9KK)\’PN"Áª¿±ÆÈüìØñP2?t‰hCWoŒI† h=O02W›|j‚hpt–xƒ¡{œ–·É´wƒ†knete’›—šgJP!ý’“’–š¥¯¹¼½·ãóÇ©Ø£¡µ±Æè÷ßʾÌÅ«±‘²¢›±Ÿ±“•ÅÓÖÁÆÅÈËÍÓíáöö),"@7C(Rjx^mC< зÃÉ!T ·¡~_  =[ytx™œ•}vcD>o«o?C @‹smN”tÀÆara$ÏóÓ7hÒL/T{ysj||¯myŽ~–~~ow|rc~ŒŒ†Œ›¼¡’ƒ‰w„{u~xx„ol{Šlux{ugŸ¥¨Æ᥵¿ÔÑÈѤŒ}Žˆ— ¬»‹m|ŽŽ‘——‘š£—fy€‰Œ‰}eh}qkb_b}nktjZQQcl]9Qm`oJ\}€…v|g[gmv‹…|šÈ‰‹ŒŒ‰Œ‘eoynm ôÏü"161,70K$`–8]ŽZJŸ9ÛļšNYúô _{°otvYy™‡Á­FYe6 1iS_€š³€˜ ŒyŽš©Áį“‡uu`{rˆr„ŒU= óø£§žžœ­ÑÁ»Ïç6ÓäÜ̬—›¬Éã$+óÀÓÏ­¥¥»ƒ«œ¢–›Âßú»ÄÃÅÈÑÖRòéõ!!Hb:4IFZ¯Y??ùÿùáÕ½Çåë4l¹HÕ¡e, ;[p€‹¡ª‡€‚}h>JNTV%å+.|wš£‰Rr…vOÐÖ95€MhF=eVOjj\œ·l€s‡lrrm^…••wV_ƒ••„—ˆ… y‚ˆ‘ˆ‚‹”…||m^‹œ¢º·š°èîß ¼•‘¾¢Š„¥™~c{…ˆ‹Ž‘‹yvsWsps€‰bYkqkb_b|pvaTi?ZxZQfcmnonh‚ˆˆ|jhzƒwq‰ž˜†“oŸŸ¥‘ew‹ˆtoL+/+1%öèú#*-ë 1!6@3oTQblQ>\?ØÄ÷ß×%íþnag:QŠAQo°¢Le\85/J€™ª‘®¡•¨Ÿ¥~‡¢—[daaˆ‚ZocwM)  ²ÆÊèëãèøÎÇdz´±«ÂÌöë èÖöÉÄ̺´¼¹›§ª›°Ãõp¾ßÍÕ˼ÙøQóçêðó w¢,5VfkjXHÿîį¯Éßù%s¼BÞ–`>& JRlv“¦Œ}†JGm>EeG#Kû CÇu„~!LYnXçË1`Aå=:'7,3kvbfxpmmavCX|‚ymv¦¬Ž™•“Ÿ±¢~–™¢¥¢~x–Š‰˜¶’Œ§°þׯÏôô'³žŽ¸Âœ‡ouffurs‚‚‹ˆ‚ssuvttu`c]qwbVsdHdskUS•_d[<ETl\Zcoo}•‰}Å¡ƒŒz’€zwzœ±Ÿ‡”š‘}~q‡t_H1'óúñåë $1*ZxM ?T\l#½ÒÞ"ïh\SbYDGV­aWŸ'E(WÌùÛŠ‡€›ª²¢¦©µˆpˆ”š`uŠ“uW„uaXM&#"*Û’Œ¤®ÄÅÃÜÜÏÛÍÔÍÇÇÅÉÕÏÎöÕóÒÌ« ’ª¶¶››Œ•ž®ÒÑâÊÌÆÀÖìäóíñóü]w,#/2€‘UíêðèÓÀ½ºÒè^‘LÖŒE#hh|}…–’”¯wbxrrgH[]E-wÇÎuD-B2  CXé 7qàíöðú*:77N€}iÃrxNr£®¥‡„„´™Ž—©µÇ¸©¬‰”¸¯ ympef™ÆÀc~·öÒÝæð׸چ€|ž—pgjdpsspÕÄ”vppsmZ`fipkcW`h\\yojSD23I~lD)7lloƒ™±r{{xrr„r~~„lc]et€ww˜•bQ¥oU^ÿí= Ý,* íßë¼ð 2]ŠQ_3?Ze[#íàûñðÝÜ ütPGS_Ghs‹Šb)=†ªª•‰˜§¤ž¼¯ š—‘ˆ‘ˆ‹‹…|v…‹…]nwm ÿú㶶®·ÁÊÂÏ̾ЯÔÐÍÙÅÌäÉ´ÒèâкÌÒúö˜¡§¤¤¡¡˜•ÃÀÑÓǽ½ÉÎÙÜßÅÿ MAAu´Í8óêêáƾÏÕÉÙ1I¥^G8/ 4zt…ƒ…‡‡ž—’†T9`£Mn`tnEmvOnhJvLÿ"( ä +ìôè×áäñý  .Iv^‘‚dyyˆ“™“„„œ¨¦°±®®¨¥œ¢¢¤££©¬µ‚pj_m‚¬Ð‘£©ÌÔ÷Ö£…bzƒ…ÁëÊgdRRdfhx„‹q]cucFKW]deWHH42DSK…Q3 1%9BÿC‡~ut“º‡~u“oUUUgg[RRm€’k_wƒ}q†”¹O&2 úö<- ýµñ-,GWZƒ±úñØñþÿðúò¼ø#$   Œ˜2k#85>Wd‹UUC G†››¡Œ€ž¡‰‰Ž¯¸|g‹©¬¯©Žvp‘|vj{XMG*ùæâï¡¢«¹½ÈÇÍƻ˶ÈÐÐÜËÉäɱÚÿëÜÕÍ×þºÅªª­›¡ž§ž’´´°©Ä´·ÌÎÚøæÕøõû>kSB^Ç>õêíáĺÎáÑÙö,L,.52 7qh‚€‚„‡—Ž§¡Œc²P\Sda=ZQ3kybMv  ùàÚö<ô××ÕÞîëóû   )pIapd||v|„„„“Šœ´¬¶·®¨™œ™œœ°©©²²‹‚‚v~s‹¦”©£Í²¾ÞÀ™‘wƒwy©Ê¯XdUUdaboljx]ew\IKTW[YK<?$);A6jE3&4"'* R~{r‡Ÿ„„{‡™{msg|ssUO[zƒ‰eVznhhcrl+2J\>!/+-(ÿúºÜãô347®¼$ñëÜæìâØÖÖÂS?&Œž&É #\N-H(WQ<##V¡˜ž’‰˜žq©µs^|‘£¬£‘…Žjd[MPQ!*üìà𪧘ÑÀ¶ÎÐÅ·ÏÖ¹ÍÙÖéÛöáÉÅ*öÌзÎ"çȼÈŧƒƒž•†«Ÿ¹¬Á«±Ò˺ÏçÆÎËô T=CøýÛåîíÞÇÆßåâå$51 1YJvw|„Šˆ µàΆœ–sigbO:plsœœ¬–R8#ùèáË2 ;;Ç¥·Åµºõäë A_Vbqk\z™xuŠ“œ‡«¢ ­°ªž¡§¤¤Ÿ£²²¯ š¦»«‹cT3Hf¢{¥¦…gsm|¬º®¦ˆ‚…vsššs£–pfiŒdh~SVTQQOA9-3*7I9."(*(4')bmlrŸ“{ŠŠ„uot}_wb_MStvpjU4+:^ˆCmyvXƒ¥eúØçÿÝýøÏÊÐúûë96!](ØíÚ³œ¢ÁÁå )eS#?!EÓ¾ëèî]FïKHpq_kv‘‚‘Ç””¬‚‚ˆsy…|…—‘ˆ”¯—mXaO–†b??] öìðèñ§¶ÇÉ˹ÈÑÖ×͸ËÖÙèÕ̽ÝèÙËÁ¶´(þË¿ž‰ƒ’˜¥½¹¾¬ÀÀºÎÒÐÔÕÖØÙ×ÚÝìñÌÍê  éß×èõøñäÆÙÐäàå%17#$+DY|z|xl‹ˆš³ª¡Æá—yŠY4_G/’‰¼Ñ²y*&äû íÿ¸¼½Üàääàë/\†ƒbŒ‘‡ŠZ]–«œ®œ†˜§›¹˜†•—¦¯²¬£©¯£wVeh€eVMlxhTK]‹µÇ…ˆ||s‘ˆv’~¡šŽkØm639?I>H??;CF<D9"÷05_[T]{r„r™¥–Šo|laRjv^aU1 '<0'*Z‡TKBJclbx-ßÆáÿùÖÚÔÐÙß÷úæâê&3èÍÊÀèŵ®¯µºQù5˜}J?OCû!"'Zi`KHep™Ÿ´«™„™‚yp…y‹ˆm|‚ŽsgFC"WV1G ó×äî÷ª¿ÏÍÒÅÌÒÖÓʲÝßâîÿÒºÙßÔ˵««ïÑ˹­¡’’’•®Ã¿Ä¦´·´ÅÒÓÛÞåÝÔÇËÌÈÍÊÅÓêëÚÚÎìþýéæðêÞßßé2"6.GVjty{i†Ž§¡¨Ìç©” c%:gT'}Ž­Àžpt<@3( þùÿþ÷Ʊ¬Ì×ÚÝåâîýKx{cŽŠŠ]]™¢™«¥‡„ŸŸº™Š–  £¯²© £¦‡ª~KWr~oZ]~j^QKk‰³Ñ‡  ”ˆ|—Žs”„¦¯¤‚èÒ‡d<006FAc`cnq_DH%&ý!&/IZcu}‡„œ¢„xfyvQNflf]EÑÙ?BK*Kf-;JYYUN%-½¿ëÕ¾ÜùöèòèçÝåíû åÑó巳õÄÏG1""H3+[N0$!$*ý"-i~kE8b™„™®«™rr…|sy|UjdUss|‚…mF@<U34öäàäïþìÕÉßÞËÑÒɾÁþñîøÿüØÍâþæÑ···è´³§Â¿‰¤¤¡˜˜½Æ¿Ê¾ÀÃÏÑ×Ýæíóƽ¹Ñ×·ÂñîüåÜÙÞòíÝÚÔâ2G òØ#_ ü&*1GJI8Iclzsy••¥“™|¦“[T@fkš¦G\ºÞ YH`_r,eÊÝt, ë=ò©ÊºÒÖÞ úëÜî*?K?iufcNWi~“‘–„¢«œ¢¢   ¦¦£‚ˆ»Ø¢q&Aƒ•tM“bPf|{k}¯š‚‘š  ÁµŽš•›½¥²¦¯‘{kQ0'"Df`{p"€V3!-;*/6fP5jŠŠ––{ou‚QQc`cB3!ùÿ#)MD8B+341.9:D¢øàîÇÁäïðÄæÖðKüŠS>ûôõåáíÃèþ(JFFTQc; 85;2,21cy†rZGp‘‹‚|sŽŽvx£…^js”£‚Ž‚yap…XX(&Wb!óïðÌÉÿ þ1ÿÆÀ¾ÎÒϵ»à H$øäóäïìÝż­Î¿È¹³¹¼¶¤¹­ž¡§À½¶ÁÐÃÌä×ÞÞáá䶹ÅÔÖ˶»¹è°£¾ÏÐÔÒÏÇûJðò"%+*#.8;=DCQo}pp’¨–™vœs[ošjkuR]Spp€ITCFeqÂà¿v3üñ"DÎ¥ÀÀãçõ<þÔÔõ(4(INoxxxci‡roi~rŠ„iuŠ…Ž£š‹¦ˆ…šœ¢tbY_kqeMPhyk]Z†• Žˆ¦¬ šÇÁš¢¢¢æΡ}qŒlvrZH(\rTã³PJE&&<;QB25@xx„›~lrllxjIL:47+:CO;22Y_;VYD‡vVHn}z=âç÷æàìÌßâ×ÒÓnøl æ!Üãî  ÐôbRØ“WQ  AP8AFADk— „…tg…||””pr‚yvy3 Žyp[gsmIX:$Ll÷èèáÛÖÒÒÝùóÀÇËÎÒÏ¿²Öæ Pëì÷ì¿­°¡Ñ¼·º®Ñ³¤¹¿°›§«¿¹²ÀÑÀÆáÑááÞÞÚ¹¿ËÎÐÐÃÆÎæ­£Íé³ÌÚÔÇ ú4Øüþ4F.%)27=\RPn|sq•–jz—s^u|bilR8h„ƒÇ‚€_Q_|¾¦žw:íÛó¡ØôÃìíýKÿÏÆà  %Dlv€gi…XHRjdyi~{l~Š¨˜„¨Ž‹^‡_khc]VVZyƒrkuŒˆ“ÉŽ•»¾š‹Á¹•¦£‘ǨW}k„’isjZ7f«…G›bJYB2,6X;O ;{œš|vajsagsZ*A)%($`¨„AwœEMP08pB8sŒŸI   JV;HCüèÕÖÝ×Ð+ãþú ø50& ÷»äq[–Z9åý-Mei((Fh_~—–‹Èàœl‡u{„“Ž…”jyŽ‚|8˜ŒlfZixZ<O9_ ,öê ÕÊÆÄÃÏÏÌÌÏÒÏÆ»Àåñ÷ú2üÌÉƺºÉ±ØÉÏÌñ½º··¶¹¹»ÒÑÐÒÕØÔáÌÆÒÛêÌÆÕÔ׿¶¤•’›˜ÅÅËÑÚæíõ  û777CICUgekz†’žzb|§§’¦ž x9C‰‡¤Žsn~ž¿êà¨EDZJûÞ×ÓÔüÿA7-éͧÚæñ*(,\{lE-&DJ?MeŠsc¬ÊU…¬§™€’€i\=1=^gzowr€ž•Åé祒¯³ž±”—ŽŸ—–{c\˜xŠŒwjgsõuŠƒ\8AAÿ5W4I=6<9¢¾“rjURU—gUXOB+0"@{Œ¹Å‰oPD;MEVe;§Å±+ïÌ.¢ÇÏWC*&ÞßïÍÅúÿò,3#9[òöôØRttYFNCãòGdyF7*QQœ]tuµ´Š–ŽŠ‡ujmlLm\U~£¥{“‰t`jnX^U+)eî20å -ñäÕÑ¡ÊÌÒÕØØÕÉýÁ¼ÕêêáêùöóþêÞÞÒÉÉÏÒäÒÌƴƽ±«½Å­¹ÁÆÑÐÕÛáÑáÒÏÛóùÞÌÒÔÎȳ³ÎοÎÂËËŶãïéàäï  õõø .11@CL@I\\etƒtƒƒ†£˜ª¤¤»£•®[O#1Œ|Rq{¡´åþç’²Ð<ýW Ðõò \Bx.6óÜÞûòøþ3?]GIXD5Nhh`aZÁâWpnŠ›‘€~@ý‚aziwobŒ¦š}z€s—£Ëž­£‚š‘‰‡Šie‰Š‡ˆ—sz‚”•s}‰te;)8V´dYQeqz~W:::4.g=7IK$:><nò ´‡€[5*"D&! -6,h> 8hÕöçĵ\<û $÷ÎÑæ(ùúóú×Ïãã =jzuoTéü)@QCE*>!&`8XTs€ƒjjo{xvvf7qJGXjp|fRT^]H9NI'îâçôå #&ùÐÛÀÐÒÛÛÛÛÏÏÏøÆÝìïæéøòìêÞÞäØÛÌÃØäÒØÛ·Ì̽®·¿½ºÏÚàÛÙ×ÕÎáÕÒáöùäÒÓͯ²© ¯¬£ÁÁÇľ¬ÓßÜâáéûøøþ 1+%14C@LbYq›†h›§•‰x•ª¼è¯¡¹ewdNyw,™»ÐÊ &3Å.k,]èþ÷0v8I@C!ÿàóñü&$B2>[P/]}qLdx›Œn|_z€{ƒ¦µ|6òv€\^o‡€kz„€†‹j‘¡™£Ô ¨ ‰”‹ƒŒ~_bs€zt•zˆyp|fq‰ƒt8>PJE39Yb†fQ1(++(%.".^i437MWˆŽ”xm@*I)/+%1J. K¡Ò /î6Æ[%÷+9WßêãØÕ603 ×Ïïì@aw…uNúì?:;>0U?Q3T&GbŒ€{msvoiscN$[$+2FO[1"B¦0BQE<%´ê]èö68 èùáÖÛðäØÕäØÒÌÍÒÝéééõøéõÞÆÉÞÛÌçêÿí,GüóÒÏÉÆÅÀÆáàÝÞÜÝÞÎáÛØêêêêÞÙв—š¦©µÁ¸¾¸²µ¸¾ÍÓëÞÝÝéïæøû (%+7=LFVSƒ¤ƒwŒ‰kh|†»¿ÎÍ£¢±—‰yLêýéG‡§‹%VnüpbaƒI<CL &?‰í±ð_>éââ <8MZQAiŽ~uZssxxx…‘RftC/:i–œ“ooŠe_jgW»¬’—³|ˆ®Ž…}ƒ{f_q^hd¤…žqiR8>{rccWWQ]-0T3<B<lI7<(%%4=L^@&;=TfoQK7?FÿãÙÎ[CRGøõ*HË©¡$ꥱŠedZ`çèåîèýA;òàùó0ò8 6RjKH2ô 4=FFUV`·W_=cŽšˆps…šo`UNT0Ô¸>Tkiƒª^P;BBk1ßKüÛò;EþäýèêáíðððçáÞáÓÏÕáóááÕùèÉÆêÞÌê, êÿóØÏÉÏÉ¿ÉäêììêèÚÃÔÛçíóðöääëÒÌ«®¨·ºº½Õ·½½¥º½ØÌÂÈàììõìéïø ..+74.(GM\eeYJGhŒ°Ã¬¯¥©ª–¾Ç´¦g‘ºñcZÎÆ´õÛ«º¡Ÿš«ªV!87R<€Hyg?Hõã´Æà%.   "nEƒŠofidpˆ¡}-Z{i2+íäN‰‘‘††žž}ZfuŠl~œ¢¾jjq}~lS;µy§’¯Â£V67UUdyj^X^7a%Ðr``ŠTf++".…^.13%XuMY^rzÛÖûÙÜÍ-e©v&?!xoNX¹“—ŸŸº¬‹sþ¹‡Pÿ)@]9 öØóú ø>Q:ë <>Zspk·³•-pdtb_c^mܺR]cHóé¸ã 660[‡ƒ?#C9epü ýáÞÞ õøíßâçÞêíêêáÞÞäßÖÖÙåßßÖ÷ëÏÌáØÆáùäíçÞÉÒÌØÌ¿Â×âçéâáØÌ×ÞçêððóäáêÞÏ««±®±ÀÀÒý½±´·ÛÕÂËàìéàãæìï ++(44.(5>VehG;>eŽ‹h—ºÀ½»°°©ÕåɯRŽÃzšÁÎÌ$þè·²¢Õ»¶¸±g3lY+“•cX^[HÛÌÈÀâîÛùû S`“fž{Z`Z_ˆyI|og=)ìH‚‹‘sn‰•†*eirzfƒ‡r—^ahrxxcP³|pžnšû»tK9dgsypgX^=fÖŸieh˜oov %"@7F^G‹f†_ZRúÁ¾ïà'‚Õ›65*nz87’Üå—–¡ƒ\uÄ­lêõø96) õâÙÞôü2TLé<OdmŒvóÉMvdeSMN^|öULH.öê× ×þ1VfVJK;YVö×ÒÕ þñøÕÐÖááççäÛØØáêåâââåâßßîîÞÛÏÏÆÞÞÛùùáÞÛÛÛêÕŶ¶ÖÞãßØÒêÝáäçêíðÞÞçÞÒ½ºÃ·ÌðÃÉáÌÃ̽ÃØÞÎÑÝææÔÔ×ï (((% &AVY\D85AeEpœÆãð½ÄŸÄѾ¢cv¡³ÎÖ§¯EÜxYÈ°œ’ìdVqyÁž\MZxCóÂÒÄáàÏÜ·Øéõ!9¡Ì™nnZmj_„†o{rdLMZŠ…u{êúÔnuMkdlD?gQb=CM]cTc_’e›ºP:hxtbHp~{`cWWlQUdlwƒ†ciG   +4ö,kkqzTÈèþ?$ü5SÖò7AdlW¬ÓÚ›’U_wSV?2  óùýÛ)(øÎä$c+G "õA|~–Š‚we7R_mRVE9/QXWuT[:- Úû ùÖÓ:$/:7.<?QOL-ûéÉ¿Ã úñíüÜäíðêäçáÞäíÕäóööäÞçäóÞÛÞØÒÛÞäööáÌÉÌáØáÛѹ¼åäæ÷íÕóãääääçíÛÛà¿ÂÔѹÔõÎÈÝÚÔÎÝÝÎ×ÚÚ×àãìÚÚøþûþ"&,;AA;88AQdt•¡«å󸻱충‚[iئ¿•¬©H3*鲂g¤úɨºƒ˜¢Ž¸ Tn-3…0Õ¬ÝòöåÆÀ¹¿Ðw¢_}¼QT…‹„–…CS(!8:O­òˆ³Ëºf‰PÒTM14DZ``‡’§­p_VRƒ—š}DXYM>A,AkS-<FLDBe‰”‚h^%!ðRßýx¤‚Frj528 ÛÓrz#BDhh^qEaq€‰xn\S&ÜçòãÆÝ7'<KÖÕÛÓî7jf+(J{{w ¬p]GDgjkf`M'aZ„`OFE(ïý÷ÚÇÄó&"49,$/,#öÜÝáôì   :èêøûòìûòéæìéõõïããÝìÝõÑÑõæ¼¼Ëé×ïìãàÝáÌÌÛÚÃØýðí Ýíççäááäê××࿹ȿ­¿È×æÉÉäáºÕØÎìãÝÔØáÃÛêðäõìòû"8MPDDDNX~“®ÂÞÕÛ¬¤«–€YWŠÏGpƒ¡š„úÜçëØÄWpf Ñ§hdˆtá3ûî: 9?aìÖÙàåäíÍÇÕìý6~ˆxƒc´‰{–ÂZ_!Ôå)ÿ#naO§‹dW0?)Rh&;,5;Pfp^w{k‘Tª‹XŒs„pFXH6EA/66,/?T`cg”áS]*$î7+D^ 7Dúþ¡êê_4^xUMH0êß&áßø7'Wii€t‚pf‡•C(ø*9@(<J=  ïúáåñþTRL`o¡³¡x{k`@1iqn\[m3Í”H($* ïʾçþ'"êÑÉýú îè þüãìùöççØÞóæû õ×××××äÞÛØÃÞÏçÑöóêáËÏøÊÓÎÌÒÙñööäÒÐðëåêæãÚÒÏÈÂË¿ÂÑÛÙ×ÐǸÌØÒÑÝÝÞááñëëïýêïøûþ +,AJS9H=U´°±ØÚཫ“‡gK,\z®æ6†›ˆh$7 ÔÑÂ{‚og¦…lar—¼½NüAL"4ýú¸ÇìÑòÞ¨¸Ç¯Ò÷Th`zš–h€¶ ð2\(ÙÊ×í0%>[yg%)$òD59*BWƒ‹qei~vgvq¸–gO9;?LQS;`i>÷:=+3K ñ/3):6¯ýÛjU—shŒù×éÎÌùûP]b ~‰…¡pUecwd{«FjAND&8C"N6óÖÙ-™mbsl{xr_L|d…UagKKZQ?Z„]<*, ÷Ðè×Ôìêüóçöñäî  ÓúäãïøõéæïãÝÝçöüöêÒíííííàÚ×Ô¶ÅÂïüBè·ËÉÊÍÐÏÌÒØíðíäÙÛóëèóæáØÑÏÑËÑ˼¹¹ÅÏÊÎÓÍÇÒÛÚçççàØØôîîòíòõøû %"/2H6KIht·½²´É̯”‰nM.1KY‰Ì7˜¡„nôÿçÂÐÏÉ–Sv„i…t©ÎÐlúô¨ÄÐòʹÆáäõÅø̵¼ÇÃËÔã#PÇÏ•œ¡íÞóÐT‰LüôËÙÑëí , ôðüíÌáùíùÿ8Cg}~3N^v{z~¦’‰„fC]PDZU, $# )>8f'69 äöîðöê(Qd-6H’ü‰Ùž˜ŽQ4î3`YëÞêîüYtx¬—£’¬pVbWln¡È}<.=60'01^!üëêòÅ RbMCJVm|aa|FCOL@+KGMM5  G>íÒÕêðÛÞäÞØöûöèýúþÿ øõûòæàÝÚÚ×ÚàáãæàÚÝÝÝÝÞÚ×ÔÑÔÅÈÚöý'úÙØÂÆÐÐÐÏÌÒØçäááâáðååöæáØÑÏÔÎÔι³³¹À¾ÊÓØ×ØÞâ>8ùíòêèîúöõõõò    <0HOqT†Ä⻂Š†~q\0HVŽÜ‹”\ùÝÕÂȶ­xWi“†ª’¼ÉÏŒU8ñȽ¶âµ®  ýëÎÏäûÁ³¿ÍÏzl?_H|ßSl‡m! îÐÎööóííÉØíçØóù)ïinoGAGp›½—š¤§„œ‹,5--:323#G5$,2&  '8!ðÖñõøC.#d]>\c·X‹to8F?ruäé$PVJOWsµÜ¦…beTfr†‰}™cXvŒK-Hu?*4õÈÒ   [S8C\h^C@^g=(:C. 02)  ðö ûþøþ ðA) íÿ  çêç  þôìøïïìæÝ×ÚÑÎ×ãüïÝÑÅÔÔÔÔÕÚÔÑÎàËÔÑêèâÖä¼½ÇÐÓÏÌÒØçÞÛÞäÜêÜÜóæáØÑÎÑËÑË¿¶³¹¿ÀÌÕ×ÕÜßê&qe;ôêæáêóûøõòï  ##8*BIk`‡ÔE-ýµŽƒ†n3NZŒÎùLU*âÔ¾À®Å§k‚ ¤± ØÍŠƒW×®¶ÛÐÕÿðóÿ Ò¸¯Æ¾Ú%3dL9f½bfZp! æÔçÕÌùóäêÛêíÏÃðÿ#)úHTX:)/xÀš•›‡‹‚)"+5*H<5A8 ýõü! ÿ ëÐæïü2Uü;8dnml-J'jKc<6STÜÜdkCFGQ²â©Œ‘nkSff}nt¡¤hbzm[\zh60<åá  XM>RenX2:a[@%7:)ùó6F   ëíùùöíÿÿù  8:ûæíÑÂãïÝÎÝżÎìïæÝÝÝÚÚÚÚÚ×ÑÎËÔÈãÔçÙßåßϳ®²ÍÙÏÌÒØäØÕÞêÖÞÍÐíæáØÑÎÈÂËÂÈ¿¹¼ÂËÔØÕÍäâó>¤•SçßÛØàéþûòïì   ",/5$9:Y>e©ÁÓסˆ¶~†ž„Z9QYcƒŒÒ¤ÙÊÒ©¿À¦¾£“½³Ô³•µÄï`%ZÓÏôêÔÃ¥ØÝ+?éÙ úÖØÓÀ¯·ÇÇÑ× $!ëJMƒS7à¿ÜêÒ±ÞدÄÌÒÆ®ðzzP5/&3W”ƒŒ¦£zs/;:æB )Pƒ  ÿöÛÆϸüâ 1ô¼ÈÊàü_ä7nY¤ kG5ü  %þÌÌü?RbU;”¿–§§~xZmD˜}}‚›§›„mj|4(/;r2 4AV[MM^t7dII.=( %öê Þ  øòøòîðÿÿ ü ïõ33÷  ûðúàÝàÝ×ÑË¿¼¿Ë®ºÒÒÀ´ºÃÀÀË×Ô×ËÝãÚÆÓÓÓÓÕ³®¯ÊÓÌÉØÛÏêÛêÏÙçèåØÝØÕÑÑÎι¶¹¼¿Â¶È×ØÍØØî!NK3 üâØ×æûééïòò /,&**..:H~›³¨šj–{„¢’woMKdhNp“‡Ÿ¦®¤ ¸«®©µ¬¯Ê× £°†zþ*,êõ87!Ùùë†Yï+3ÂõãÔ³»¾¶½ºÏäùÛÌü(/õåÖÆʵÈÀº©£®ÞÞäSY5#6ýå):N‘©™¥‹n ÙÏÍÒçö ú Ýü*ùÉÆÇ»¹á¹¯«¦£Û÷þßÌclm˜Ð¸^b_ëÝÞïò 7W$"330A\Xnƒ’Ÿ‰™{khe||jORtŒƒ˜pX@Bäç)<N%0BC)/=GGCGJ7OI:11 þ)#çêäùÿñëêóÿÞíùüöæÚëõñèïþ ðìéãÑËËÅ¿¼¿Å¾±ÉÒÀ±·½º¸¼ËÚ×È×ÝÚÉÓÓÓÓÕ§¨µÓßÉÀäçÒçÞçÓáçèåÞàÛÕÑÒÎι¼¿¿ÅȽÃÌÑÕÙÜð **  ýäÚÕäöàãééì/,'$$"*Ecx¢›‘ao}ŽzmtWTfdVYbju‹“£œœ·´ £«°³°¤µ­n>úQM Mb:ì+@Û™ ,?NÅãÛÙÝÔ»ÉË»¶ÃÚË·ÁÉ»ÎÖÄçÈâÃÓƽÏƽ¦”“ÆÒÛ/#ö, ò$.Cw¢šŸxH Þǽ©Êçú  éðÐÜË´™šÄŽ}r½½¿Ü¶ÝsW^§ÄuB?o÷ýóõül–@6=://GLqz}†š•‰zljgˆŽwVMSvyve\SSöü7/9.=:45/CD> =:." ?2ùÿùö÷ýýåêùêÞÞêüâÐÓíõÚâèøòûãàÝà˼¶¶¹¶¶Ê®·ÃÃÆÉÌÃÁ°¿ÝÔÅÎÑ×ÒÓÓÓÓÕËÌÍÖÜØðÿáÛÞÛâððëîíéäÛÑÏÎι¿ÂÂÈÉÇ»¾ÊÞÔÚçèÿïæçÙÓÜîíïõøø 2)'1+8d“œmfWbfU[r[[j_ig_[S€w‚wyŽ |ˆÈî͘³ß1¶;)Sc? (“©–…’Z+‰œ£”0 òéÔÍóäÀºÁÁ¡~¡‹œ›™§«§½ÁïÞ»™—ÒÀÆê;ö!  ÚÞÔÍèö3CR0 ýÙÓÒëÿ  TH=Iú÷Ü»»¹ˆŠ¯ïËšœŸ°(A>t@Lp(.[j8) K$VZ  McR>\f^}z”ƒ|qigg”›€‰}uxlpnhVFPMa& 7.#.8/7::1  #öðü÷ú  ñùüÿùíáØÌÉÄÇÁÁÆÅÒÏéðø ÝÚÝã×Χ³¶³¦±Å­§Å¿Â¿³±¿ÎËËÂÅÈÔØÓÓÓÓÕÈÆľ»äüÿóíÒáÒîÿóîñüòêÛÎÌÎι¶¹¼¿À¼»ÅËÖÇÊÒàæéêâÙëÚÔÖæêìòõõõø  %5&  û<``b:KPPOXSSLVmeSQC<4\w­YA=f]bŒŽ¬©¼É첂Bl[yqRpv©¦|½³þó×°{E-÷üôصª¤—‘”g{udkŽžÉ÷'üåØÉÌ«ÆêóóðöóÛåÿ  äÏìíúî  ýåÕëéô *' ,ñèܽŒ¨ ëÂȘâá.Œ$àITdonXK$òë !Y 0èü .B78Y_y|ˆš”wskffg||knfcj^PV]lzlcs@@&&7.  +(14.  -&ðóÛöðûø éíöùðØÕÕÒÐÚéÜËÍÐÖåû&7 ãààÚÚÚ¤°¶°¤©Ð«ŸÆÔ×ÔÅÃÈ×ÅÈ¿ÂÅÑÝÕÕÕÕ×ÕØÙÓÐäíêêðÏáÏðôîôÿõïÞÏÌÎ鳶¹¼½»¿ÊÍÓÄÄÌàÚÛçåâîÚÔ×æßäçêíðóü  %5& û3EA:HNGI^RGGSpedTEEEUh f-!QSVh}¤–—µ¨šÔ–Z"og{Œ‰…ºý²°ñÿãm§„k\<úÿɳ±¯š¤¡¹‰”zp’‰×ê Î-ÖÒáÿ  þøõèÏí÷)1úÜÀßåìê.÷ôîëê4:ëÜ\ íà>è³—Ä`*ó§«ê07“} ²Oj/"j‰•wþ!Gô8.îóC<Dgn‰y‚¥œtqkfcirrfticxvkb\\g]WoLO<) 9(## &,&ý'' îúúíçð ûì  èâêÿüóöáÒÃÄðüêßåÖÚï@.ãã×ÚÑË°¼ÂÂÀ²ÛÙÌËÌÐм¸ÈÈÈËÂÅÈÝìïíçäáØÕÕÒÒØÒÛäÞÞÞÞÞÞäðöÿðêðÞÎÎѹ¶ÈÅ¿¹³Î¿ÎÔÅÈÅÈ×ÜÙÖßåèÜÖÙâÙâëèåúý (   &#3<?''36<T:A0/Gckªx.B{“l~x†tÔÝc5w˜ÐÒ«°ÍøI- ü.UüÛ¯Š’zˆl[[1!âÓ¼ÍÞÍ™¢¦ˆƒ•ÝQ(Ï#SÜäØú$üÉÑøÿÏÔèþúû.*;6*8hbFNN8 ìáúíοÕÌýñåÏ©³êvk‚TÕÏÝý0D=P:Ox6)ý*'*3ú$ýùÿ#Tax¦Àlrryxlic‡ŒtŠoi{~WZurKTi]N0  õçô-óîì  ý÷ÿ &ïÒô òõó.  ã×Öß÷ ëýñëýëßååèîàð àÝÝàÚÔ¶¿Â¹¼ÔÝ×ËÆÌÏÃÀÈż¼¿ÑààááÞÞÆÉÏÒÕÏÒØÛÞÞÞÞÞçççççêêêÞÔÎο¹°³¹¿Å¹¼ËÑÑÎËË×ßÜÓÙßëâÜÓÍÖßèåâ÷ú(. þþýñ÷ôñýý'<[?86xxHT0?x½ŠKZŠec?mWÎW&É°â+wRO]O?Ù¾²¨z‰’æšx{©¦uE$ÁÁ¿§‡Ž–ªÝÝåØýòï+ç®ÄâúÞÒãîý3P~jd*ÿMzmdJFXcNYYULHcW.ûôØÝóêàóüÝÎÕüíP8ôÎ×øÓÙ"í $Eby9<*?ëêñ:Q„ku|mcji`Zi“•ƒ~smyvd^ggFKr~9Tu{oH-#óã÷êçéÏâßÜ×Øíñô!+éîéãÐÓïãîéÚâé éÔÖåúèëúýßÜ÷ñÙÙåÙÜîÜõÝÝãæÝ×ËÑÔÎÈÏÉÏÕÕÎÈÅÑÔÎÈ¿ÎÈÈÎØÜÛÛÞÞÆÉÏÒÕÕÛááÞÞÞÞÞçäáÞÞäêçÞÜË˹­³¶¿Â³¿ÅËÔ¹¹Å×áÜÓÖÙåßÜÐÇÓÜåâßîôý"(þ ûøýúóóáÞáíñ÷$9]YB$.`…aAK-<NxWEEcWaEa>ÈV ñãêêÏÀàÔiv–npe>(ñ¸ ¹˜~½† µŽC&Ô­Å­lu²ÎçÛРïùÿÄäÝÐÜîÏÜô/f‚oVF&G†´pNN`^O[TPPXŒmD1+#ýêöÝ2æØÑîýèÅå/ßÆÉÀ¸Êöòú*ƒui;§’‰h/)ïð 4HZvoppmprfdr‡†”„luoTT]`?T`xKQoro`I=üÛêëõþôÌÚ×ÑÑÑåë÷ÊÑÇÕ¾ÅàÑçÞÛÝßûîàâëññÜåî÷ÓÜîâßèÙÓÖâôÚ×éìæààããÚÏÙÄÓÜÕÉÄÄØÜÝÔËÈÅ¿¼ÂÌÍÏÕØÛØÕÕÒÒÌÛÛØÞÞÞÞÞØØÛÛÛÞêáÛåËÈ˼¿¹¶­ª¶È¼¹Ë¿¿È×äÜÐÍÐÐÙÜÖÊÐÙâßÜÜßîú   øòò÷ì ëôßÁÇÐÖáð  ÿ );YTN10E`f|iY;G)8&52@O„tZí0MšÄ²Üœ•G#(îã ý£›c‡š¤©¶ˆ—¬l\{9ܺ°Ä—¤4f…€D Þ¹ÔÏÄÅ´%íÕáüüô"9,D\bjcyzb’~ˆ˜fkw€ƒuf_n‡ZM-ô;&þÑ$-øßøÛÖÛ«ŸØèòé 2nwN=pH‰—ÄÁ£‚mm: ñò?F3bOlolprfdi„}¾Ÿoufiir{]{]oW]rr]RIãáÕâëïìàÚÑØÜ××à6B÷²ËÑËËÌÌñúõîõøôÜâññî÷÷èýÖñëñîèÜîñåîâÙããõæ×ÑìÝ××ÞÊÑÙÖÔØÙÛÙØÑųÂÅ­§¿äÙØØØØÕÛáÕÏÞÞÞÞíùíÌØÞÞÞÞÞáÞÕÏÐÎà˶¡ª°¼Å¶Â­­ÈÅÂÈÝÕÓÓÓÓÜèܾÊâßßßÜßâî÷þþûøøøìãáæíðêÞÉÉÏÒìïû (1:;D>?3HD87);>öö>.'odiU*äÝS8ŠÁU_\‘´<Ú¼ÆÜЩ­¤Ãª½®Ÿ¢·‹pE5í  ß ŽÞÀôw6íðøâÎÂÈõæñ÷ó 2tƒ‰teerc]…¦˜w g{ttz„})Õp|W%  ùöÖú÷Îò?Ý´ Cf_GdxÞ;²Â†ž›¤¤¡}MSk^fX@-APthNj`]gxrn‰œ‡fur`luu^`i]clZ]WBFC1ÌÕÏßæÚðúñà˼ËÜççæøǤץÉÕØûéãåããÜè÷ååñýýåå÷ëßÐÓÐÇǬÊææõéÚÔæÝ×ÚáÍÑÖÐÌÒÒÖØÙÑżÅ¶³¼È×ØØØØØØÛØÕÞØÛÞùöÛäÞÞÞÞÞÕØØÛÚÎÚË¿¹¼¿ÂÅÅ°­¹¼¹¿ÑÓÓÓÓÓÙßÙÇÍÜßßßââåëñùûûøøûòììíïðêáÒÌÌÒÕëïø (1:9B9<. (39@5))&#1"TRg]=éå@5!V€=RCœîµÌ»­ •ˆ›·¯š‘ ˆŠ8;ú é!NÌ ÷à´wMùÀÂüüò÷ñðöúøû,btvZMZ~Ql—·¶¯²üŒ‰{urzƒØ®sy‚R:76# ä÷5æÅÚà¸å9^vmt²¢þ9—ª¡{–—ˆ…ˆ|^agSY  )PmUMjccicien~crrlruoeclTWfZWQE+:N%ÌÝÞÜúéàïêâãμÂÙÜÞåõñž°ŠžÉÒÆá×âãâãâîôåèôýèè÷èÜåîåÄȳËïïòéàÝàààãéØØÒɺ¿ÅÎ×ÚÑÈ×ﶳ¶¼×ØØØØÛÕÏÛáÛÏÒÛÿùíêÞÞÞÞÞÒÕØÞÝοÈÑÑÑÎËËΰ¹¼­¿¿ÅËÓÓÓÓÓÖÄÊâÐÐÖâèîèèååðòõøûõïïõýòëßÖÍÖÙÜßëî÷ '09:@0.#ýØí5PQZE÷*$E->RoP\Sòó2MN >†£r2p¦»÷7•y\B‘™¾®š¦º¯Æfb',6O?<X¶Î ÞýÎç+:E/ öèÞÙíäú+6!#\$(glx„qƒ_x`€yst†YVio’pU=-üõôñ.m/Y>&`¢¢¨¿”©¸¡¥@·€±ÆŠx‡~ru‡eE* !<{óÕN>RZZZf‡€ekcZcio‡‡i\]l??QWHEK9?F.ÓÞäãáïøøÑÂÓÓÍÄÊÂÇãâÌ£©ws¢«Øêåäãäìñèâî÷Óñ÷ñèëÜÐÜÄ»µËÈÎììòïéæéììãÚÞâÞÕÈÆÉÍÓÓÚÚÚÑÅ­§¿æ×ØØØØØØÕØÛÞááÞíÞÞäÕÞÞÞÞÞáÞÕÏËÔ¹ÂѼ¿ÂÅȳª¹ÅËÔ×ÚÔÓÓÓÓÓÐÊÐÜÖÖÙâåèßßâåäéïøûøõò÷éâßßèååëî÷ú'09:J4-$Õë:VTSD;5#SPx{ƒORb. *,87UN¼Ä:¤C5­Ã·©¦—¡qg`lOquût¡ûÐåx[g.2ã¼ê5[psfJ/ ñéèðíÖ$#P9<8.QQb:asnqwŒž†YNTGkr}A0ôÍÓOMNKZkve[‚°°ÑñÎÃõïí¢‹‰¢Šœ{u‡ii™€VA0[a6;7E906QPJ\bbY\PŒeTQTB?E?99?$0CåØÞùýìþþçâÐÎ×ÛÅÂÆÉ¡”Œz’¬¢®±ÃØÖ××ÙåâÖßÜÐßâèßÓÖÓ;ÓÄÔÅããòïììøøõàÌÜåëçàÕÓÓÐÐàìÑÑÎËÈÈÈØ××××ÔÚàÔÏáùðáóÞáðÛÞÞÞÞÞÏÒÛáàÛ½½ÅÝ×Òý¶À««ÆÆÌÏÃÕÓÓÓÓÊÜÙÊÜâßßßÜÓÖâëÞáêöùííðôßÜßëîñô #(1=>Z:0,àÙõDJ;2PPEB93TN|i|ˆXk†34'*'BV b®Ÿ@7"Q‡¢§¸n›`;o•t‡ßºZ]x; 3ÓÝ«êLIO'E$ õÇÄöîôúÕ'UQ/îÿ,)eqsx} ´~tUAp„wZŠz1ù:GJ‡kw|sdd£ºøñþð¥’sˆ©©¢‡ofCgt âýF?\LT?.025]fooOSVqeM{E<TQ@(44+@6 õôøûØäý üÒÒÏÈÑÕ°®žˆuŠ½žÉ½ÀÊÉÈÉÄÓâÐÐÁëÐÓÐÇ»ÄÐÍÁúýӸ׼ããëñ÷÷ââååçÞÞÞÝÝÑÌÉÆÂÕàÅÈÔÉÃÀÃ×ÏÌÏØØØØØØÛùíÛçäÞØÕØØØØØÞÞÛÏÈÐ͸®ËÅÂÇÎÈú·´ÀÏÀ´ÞããÚÔéÚÑÎ××ÚÝàãÝÝÝÝçççççóöùüÿæêððóíóùöüý$''-=M-ZI611ïå"%AD>DKNLC`VkrhH;7* 9&'‰b6D‹ 8 è0Z‡ˆµÄ˜¨{i^z˜dz›ž=.GQæÝSCPPøæû1ûâÞîôèØÞíÀìÊ wPptfˆp“¯´}oTm}_UML^Z3Ak_†µ—†ƒ^vœ§à×۾Ο±´§„u˜Ž™„oro^1{Q $6I)nL[HEKal]hdV~Vf-LU3!"%-)    ù)êîý (õãàÈÞÈÂÝ˹¹§{„ƒ¤«§¯²¸ÏÓÐÍßèÙßßÐÁ¼¼Ñ×Ë¿ËμĸðòöóððçäáØÕÝÛÛÛÛÕÕÏÌÌÞÉÒ×ÔÌÆÆÌÕËÈËÔ××××ØÛäáÛáÞÛØÕØØØØØÕØØÌÆÀÍÒÒ½¼¼ÇÓƾ»¸µ»ÇÇÇÚÝàÚÔ×ÚÚ×Î×ØÛÞáÞÞÞÞçååååîñô÷üíðóöùóöùÿ-45+5MB3/3:Iò-(1GKGPPPV\KQ[g<.,' -%cR*85O"ô!Þîó2o|‡€œŠ`}O:\Nþýøûûú*æîáõ)8^KKU2  ëÇáÚîýßùðçêT8nSg˜ó—‚¬—‚‹}v…t‡g^jnnjE>c¿Šx“Š‡Ä› Gvüº×©ï±™±™â´Š{qhjmdB/#}‚=@@@A?w\Ra<?FXemPYX_wVa6CC*%+$,/' ÿ ÿ/5èò.@^"òòÔÖÑÎŹ¿ÎË­¤¤¢˜©³¾ØÞÙÓÙÜÓÍÊÊ͹Åμ¶¿Å»¿¶üþÿùóðíçáØÒÝÛÛÛÛØØÒÏÏÏÛáÎÎÆÆÉÒÏÈÅÈÎ××××ØØÒÕØÕÕØØØØØØØØÏÕØÒÎÔØÒÏ¿¿¼ÆÑ»»»»¾µ¸ÊÙÎÑÚÚÔÎÚàÚÑ×ØÛÞáááááçååååëîîôùöùüÿÿüü*:BM78LC1)%). .34COO~toZS<OZP=%÷ ý)?Eƒ^8Zx=îÑ@ÙºÜ,4_Ÿ³‹=@b®¾p 1/Ê©¾ËÝÛáϽŮ¹Î>FKkQPLLA@HBSL:w>êÿòÔÙU}¦­Ì½¾˜˜˜„Ž„_}‹{„|Pb„qfÏ”l{ˆ‹’ÍŠœNŒÔc«vd­™rowty‚yQÿ:jma=++>RPAJP=EHN:EaP:PQ=;)96433('&),)üüç#üñìãïãõûÑÝæÊÑ×¼­§¶¿¼¤Á½¨šš©³¼ÑÙÙÜÙÖèÙÊÍľ¸Áľµµ»Á¼¶üüüùööíêçáÚÛÛÛÛÛÕÕÏÌÌÉáØÂÅÀÀÆÏÎÅÂÅÎ×××××ÒÏÏÒÏÒÕØÛØØØØØÒØÞÛ×ÛÛÌÆÎÈÅÆη¸»¾Á²¯ÇÖÆÎ×Ú×Î×ÚÚ×ÕØÛÞáääääåååååèëîñôùüÿü0AGVCDH35'  (14=IL„gP>:OHúù8MX#ì@fJûÔŒáêB˜›IT~¿a »šªµÍÛôĤ•êäÕB3N„z‚\rccxnªó¸ZEèÏÃðþý (B±'Ô약®´›¥™œ†jZ”‹”ˆtuzqs—|m„š„¹vp¾Y@Äâû©Õ°¨pgƒz‡lu}zj^dŠ(IOLCUX@YMYhkINNELO}aLPE6/)66F<3+!,,ÿùùØööõàãÎÚàéìËÇÈÑÅ°¤§­³ ÆÆ®¦©­²¸ËÓÖÜÜÙúëßÍÇÇ»²¾Ä¾»²¾Ë¶ùùöùÿííððòÛÛÛÛÛÏÌÉÆÃÉÏ·¼¶´´½ÉË¿ÂË×××××ÉÒÏÉÉÌÒØÛØØØØØÛáêçæÐÔÎËæØÏÆÆ´µ¾ÁIJ¦»ÊÀÈÔ×××ÎÎÚéÕØÛÞáççççååååååèëîñ   &*;KQf\WE%!,-1AGc…–ˆgJú&C( øö#"@LFÓI(QÚôÎÜH 7PƒŒ“{?^{V  Ûêå×Õëí8„(ú¸üáz¥x‰³¡¢Ù¿ƒ‹žuÅ°”bfÍâìïý5QGÇ‚E~Þ¤”²°½’´•kbpK°¢ª’Œ}ywWj‚}€n¥v…cxc9ƒª½¬‡u¤¨p„uwk[mpiUCCb\Vv‚g;3<A8_^T<K3F49ePG9D5AfI13  óÿÕðüóóööùéÔòòéѼÑøÊÙ»» £µ¥¾Ç¸¿È¼³³¼ÄÊßåâ¸ÇÍÍľÄį©ÄÁµÁÝι üùðìÞÞÞÞÞØÛÛÌÉÌÌÌÎÂÀ½´«¹ÅÎËÅÔÑËÈÈÌÏÕÕÕÆÌÞÏÕÛÞØÒááØÛäéæØÔËÇÇÔÞÙʵ¯©¸ÁÍÍÌÑÔÑÎ×××××ÏØÞÞØäêíäåâÜÜßåââîÿ"3R`r‡|~h53(#)<$""47VV`¶ó´^H"" õ%(=LVW#W/,"ðõÔØF›\½Ë¢v”®šŠzÿýÙîÐPZxrdRŠ£¡–‰‚„Ÿ¦ŽŸ¥†Ÿš•…‡§&Ô×å/Gl…¹K`0"›¬»’µ£Çª”‰u‹–‘——v›kmwqŽ‡t}œŽž‰‰_nz<0T—Ž—{vz}|Z~q}sdmiRL[nf'>Skdw *HZS_U=?<<A8-OORLGGP'0%(%ðçêÿðäÞáãÝÚãææÔÑÚÍÏÒú¢½º¨¾¸Ê¼Ñ¼Ä»»Á×ÐÁÇÐÐÖÖÖÙ×ÎÂÂŶ¶ÂÎË  # üóðöÝÛÛÛÛØÛØÏÌÉÉÉËÂÉɽ«½ÅËËÅËÎÑ×ØÉÏÒÕÒÉÌÛÒÒÛÞÛÒÕØíðêìá××ÕÐÌÏØÕÍÁµ¦©µÍÓÅË×ÑËÔÔÔÔÔÔÛääÞáçêáÛÜââßåââî)7Wi~—‹h011)$'!9?`cOœÌ”B>!0 LR<8þ1vC ÝÝÛß^ n­¼Á~”Å»ÐBGy6!ALchcjž²‰j‚]Po——š¡„°±¦…Š£$ÙÜñ9G/Wžº#•hh™©‰¶¸Æ«œŒu’›Œ‚†­y6Z“‚Ærw™„£yŒ¯<!+‹Š—k_‰…vTuz†p^gi^[ixs!$@}wŒ)KW?GM;AD9-21VMŒzIIA&2-(3$ ÿçêóóÞÙÝ×ÔÝààÚ××ÍÐÍÄ»²»»¾ÈÈÔ¾ÔÅÐÀººÔоÁÍâÜÜßÜÛÒÆÆɽ··½ÈÈÈ  )//ÿóðÿàÞÞÞÞÛØÒÒÒÌÌÌÎÂÒØÆ®ÃÂÅÈËÂÅÑÝáÆÉÏÏÉÒÒÒÛÌÕÞÞÛäáùêÛÜÇÃÆƽº¸ÂÉÊÄ»¦»ÁÊǼÂÎÑÎÑÑÑÑÑ×ÞççááÞÞáÏÖåèâåââî  &)0>Wu’»È½w;1*$!#  );PGWPFNH4%1554*7&>L<!óÖÎÊðÖ¹ÝøìBY‚²ÕÆ{j«Í;U}]kBWd]?22Teq·p©äŠPFzŒž—‹•›zg! FY?`x´= Ö9îÊ«˜´Óé ¬}‚¥´£‰z{„Ÿ¸£•{‚ƒ“Ÿ¯|Ÿ·—et~w‰´nKŒƒ’oiwqd[dlX]ckqb/7jda/e*3,5#$.0-BR/FVd]jX\_5-+åÛÏØäÿùóäÙÑËÈÑÔ×ààÎÑÎż¼Â¼ÂÚèB0ÚОº»Ç­ÁÜÐÖôÐÊÖÄØÒÆÆÆ·ºº·¹¼Â ùöéççççÞÕÌÒÕÕÕÕ×ËÉƽ´Æ¿¿ÅÑËÈ¿½ÃÆÉÌÃØÕÌáÆÒáááííááèÞÙÏɽ¼Çи¯¬¯ÓÓÓÇ¿¹ÈÔËËËËËÑØÞÞØÞØÕÞçâÜÜßåââî  #/:Mt˜Ò÷ì™^;C6),>6B?$=1L@ 8--C)*(#+ ßÈ©¡Ÿ×ˬíF8™ŸÎ¤ˆPh»íÃeQð&4=ZPC,=GiZ ]]NQ\krsy—‰ƒv‡ŠjCVV5:Lmi|¹õÔÉ祪«ök’Ïš~~°µ´•}–Š¡Œ|‰Siv‚‡£´Žq‚“el€}SbsX`sc]QY>UgsfW^`_quG=\ƒ‚€ŒJG03,2.>?On~vvœp_P)þïÜÞäÞÛÏÕÕɻſ¼ÅÈ××ÔËÔμ¶¹³ÈÅÑ §zìÁ¾¸¯¯¶©ÁÙâÓÊÙÁÏƺº½½Æƽ«ª­ üòíííííÞÕÌÕØÛÛÛÝÎÆÀº·É¿¿ÅÔÎȼ³°ÀÆÉÌÃÛØÉáÂÑàááêêÕç÷çíÛÒª¥¨³Á²¦©¯ÐÖÖÍÆ¿³È×ËËËËËËÕÛÛÕÞØÒÞóèÙÖÜåââîÿ !"*5Gp–Øø£m@QF)÷ +*==:)5%23**#  øä¹±´Ë„§ÍË´é2d>‰Zz}s4;˜Že>]ò?YH5O{_–T.(T\Asit”tw‚‹‹{jC"^ZD=Hr^š¿»¥£§ÂË Ÿ‰ÈYnª™xi¡®µ’/p‚´¥YyY_i{}ž®…tš¨W‚…qcnBrQ|b@HBP2Tl{f]ffdwkI=c¡ƒª·WQM<'!*$0A2F7¸ˆ¦kM8$ïæâçóêÞÉÌ̺¥Á¾¸ÁÄÖÐÐÊÔ˹¶¹­ËÈËoHѾľ®«©¶ÇÍå!ÜÓâÇÉ÷··ÀÌÌÀ¨§¤ ÿöïäííçÛÛØÕÏÏÛÕÏѼÌÒ̽À´ºÀÀºÆÉÉÌÄ»ÓÓÊÖÜÖÉÏÒÛáæó÷ùööáêßÙÀÃý¶½½½ÀÃú®½ÉÎÎÑÑÅÈËÎÑ×ÝàÝ×ààààÝÝàææÝàãæéù#23/!&]‚Ù»e[dT? ($>:7,!*-$ÿôýùÔ¼åÁÛ§ÆÖðB5Q]"SZ“™«“zo/B<N<M42LGprI[CgF^pmpvœ~fQQfvyu3Lwƒ^|”=Q“¼É£s‘Äò"ЄwhÃÌÂÉ{w{xE'SfÐÎÀ¾¾·Ÿ…™Š[hnC8*<;V^_G?NT^sw]fcmxwr‹W¯©C’•J+"&; '38AR^KTN60 ñî÷óôôáÕ½¼¹°ª®®«««±´«±ÂÀ·´´¥··ÀáðöíÀ´±««º¿ÌÛíÿóüù¾ÊÈ¿·´®»»¯¿´± ÿüùõðíçáÛÛØÕÏÏÕØÕÔËÀ·´·ÏؽºÒÏÉÕñÓÓÜß¾ÓÜÓ½ÌÏØÞãö ùððçÖÐƺ·ºÅ·ÀÆÆë®·ÆÃÈÔàæËÎÎÔ×ÔÚÝÚÔ×××××ÚÝàãÝàãæéçû/D62 >Y ÁÈg;@9*""2IA/)$úú-6$ ç÷V0¶èýF¤N6 ÷FbnŽ¡û*tŒVîË£V@WP;Tz]8Q[T‘|vF‚g[OCEfxf]o–‚vrYL)Aj~[^\^ƒ–¨¢5#Fuž||Œ²½À—vNVCmHZBΛ~V[SE@<3PYe*-EUmt€„`_tsv»Ô±Ì¥ŒsUGS>A,"$&4(". õïòùñßÏ̽³­§§«®±´´¥¥ŸŸ¡¨®¥Ÿ¥®¥œ´ºÃÉ·±±´´º­½ØÒØÛäÛÆÑÍËÂÃÆ´¸¸µÅÀ´ ÿÿüùùøíäÞÛÛØÕÏÏÒÛØ×Å·±´ÃÏؽºÒÏÉÕóÓÙÙÜÁÐÙÐÀËÌÕÛàö ùðÿçÊÄ̺±®³ÃÌÉ÷±½ÏÌÉËÔàãËÎÑÔ×Ñ×Ú×Ñ××××××ÚààÝàãæéäü 0G;6$0E‚œžY163'+%!/D@)*$ ýú00'%"  UÆqÈã $oª`E"ø8Rekl_ïô)h–n ¹ŒfMoPkŒ‚]2Igl¨Šl9iQQiš~Zu~r`i—xnj`SAfnX„x:;qé¶ýáKŒx¦œ“—vƒ–|qN,7­*kŠWCñ­}ra_YMH;"3ˆV€Y6BP^m™M`ƒtw€{caÀã¼Ù¢sL><J=."(C úôñîñíäÛÛȹ³®³«®´·º®¨¨¢œ¢¨Ÿ–®´«œ²´ºº«¢´ºº½»ÄÇÁÊÍÜиÐÁ¼³½Àº¸¸»Êƺ üüùüüüÿðÛØÛÛØÕÏÏÉáÞ×Ëý··À´ºÀÀºÆÉÉÎÄÓÇÊÍÇÄÇÌÈÉÒØÝó÷ùööùÞÐÍÉÌÉù½ÏÕ̺ÆÀ·½ÛÚÑÈÅÑÔÔÚÝÎÔ×ÔÎààààÑÔ×ÚÝÝàãæéêÿ -A>9')KVWF21996.+(',3$+0!')ø÷ôý!$.(ýK°EsÈÅè ewF:ö.]LSßC_;wLLZÉæa†z@N3D_™¥9W?K]Ù®cruluif]eoeŸeldgieQ“Û/goÃz›yœ¥”Žˆp«¢¹—oujVó" D¸–lÿÀC]ZZK2&I:BwMK`b‚vzŒŠ€V5>kqSU‘øÀ¾@k¹U1(   þ  øõøøõïæàáäÕËȱ¨¥±«®·Àô¨®¢¥¢™–™¨«¥–¬±±´«¨´ÃýÌÍ»¬»¾ÇÄ»¾µ­§ºÃÀµµÁÊÏÉ7,ü ÿüùöìêííðçäáÛÛÕááÝÂÃÀÀ½À´±·ÆÀ·«½ÅÄÇÁ»Ð¾¸ÄÛË´ÒäæíîíêêáØÍÊÀÏØÛÑÏÌÃÀºÃ·®Ã´¼Ñ×ÔÔÑÑÚãÝÝÝÝÝæàÔÈæàÔÑÑéééééáð#&-- #) "%3-#  '1=; ýýýýýý .4#ö§Öéï #CCC(ûú1æ Úfaû[imp{ušˆ4ON@aDY_S8PGJhorxroTiT6ouUeUxHÌŠŠzLL÷ö‚£o±““—–{£™zjir@J”λ¬Þ–E(Ì{QMME,>:<^~YJKfqjyz~‹Wmc&)EMj|ÒTktM=0 öøûñ÷öÝþò×ìàììéàÌÌÀ³°·«¥¬·±±®±´«¥¢ŸœŸ¥™¥¢Ÿ™”¨¥¨´·´½½´À½·ÃÌÌÀ·ºÃ¾­¡ÀÌþÍÓ¸ÉÕ=2 ÿüùöòðíçäáçäáÞÛØáÞÚÈÆÆÀÀÀº··º½±«ºÀÍÐÁµÁ¾¾ÄÌýÏØÝêëííêäÛÐÍÃÒØØÑÕ̽´«À·±À´¼ÈÑÑ×ÑÑ×àÚÚÚÚÚ××××àÝÑÔ×ãããããäï !&&&) $0-!ãúúúúú#(  ù¾¯Ùøþ(@;9  $ûÿë´ Phamg]nŠ~BYZA5GPYS5AJYz\`ic]i]QH`cFK8MlWp­‰ŠiÛöö3/!ç ™‚—„‹„Ÿœ‰pcT48x²Ý”¾«w.z?EGM?/868XwkVKW]a^hu{„]jc:':;\n‰ùÖ¦{z}[XE ðòþååíáõïÝòàæãàÚÌɽ³­±«¨¬±±®®±±«¥Ÿ™›Ÿ¢™ŸŸœ™™«¨¨´·´ÀÀ´¾½·ÀÉɽ··»µ³³·º·²¾Ç¿ÉÕJF&öóóíéíçÞÛÕêêäááÞÞØÚÔÒÌÆÃÀÆÀ´¥®¨¨´º¾ÙÙе¸»¾À·ØÉÀËçèíðððçÜÙÏÒÒÕÑÛÒƽ´º´±º½¼¶¿ÈàÔÎËÎÑÑÑÑÑËÎÚãÔÑÑÚàÚÚÚÚÚäéîóù þùöòþüñ÷û    –Hõôôôôôåèý%ñ¥Ãàù 309  860?äËÐßæGOF?%<lfc)0JqEM8JJ,S_ehwuou~cNE<9SPNA4AwpmvxlµÞ¼ºõœvƒrYg_T—–”†~ThUh¿ 7=ÛB3"3A-2..4J^|eKBBpRt¨dm\Zmm+$ 26annx¨Á½Šh ÝÝÞÌÌÛÏéïàãËÎÈÅË¿³§¢¢¯²°£«®±«¨«¢œ˜œœ™™–œŸ¥¨±®±½À±ÆƱ¾À½Àý·´±¯©¹Â«Ÿ«¦¬¸ÔÌÌ?;ùööðìááççêðíêääçØÒ××ÒÌÀ·ÀÀ½·®¨«´º½ßÓ»²Êµ¬»ÕÌØÏÌÑáåðöùðêßÜÛÒÏÌÑÒÕØØÛ´´´´Ã¿ÂÅ×ÎÈËÑÔÔÔÔÔÝÚÔÑÚ×Ñ×Ý×××××áæèíðýùóöûùõòïìííïñìòúýïéûòòøÿ8øÚëëëëëîëñå÷ *   ó³Áà  õÿ(L1ëù/$ åÄÀ¼ÕãÝQkPaw\W['+\ZM@14C.@Ogec`lu<]E'.>5?17dvao]ii”Ô³ÈÅ›‹²—¦b]P^x{yz—¨ßè°R}nÎ46É]0 )28DMIJNQQF@\Škdkfsn:6 1?Z¯ÁZ;íÉȶÃÕÛ®ÚÝÅ˶¼°³Å³³§œ–£§ª§£¥«±¥Ÿ«¨¥¢¤¥¢¨««®®±´º·ºÆÉ´ºº´¿ÃÆÀºº½½·¬¬­°®«·¸²ÁËÆÆ(&  þûøõþöêäÞóðíççêÕÏÔÔËÅ´«À³°¶Åª°¿Âƺ´ÃÒ½ÃÉÉÆéËÛçáßâðûüèâÙÖäÕËÉÒÐÊÁ¾·±±´±ÄÈÔËÅÈÅÅÎÚÝÝÝÝÝ××××æàÔÑÑÝÝÝÝÝÛãðôü÷íæîõöóìììéæìïëïøû÷íüðæèòøùùøûååååååëßú  ,òº³Ýèèü<ñ¿@3ÙÕ·ÕúÀÒ,RYY`b`i>7GKGU%"a."(CG`¢–xiQH0fh@TD5B9MckMoº¾¹¾ j{k5*Mvfogp‹˜—‹¨‰¯[`MÂòä™8,6 0;CKN1<GJJde_WXR¦dPGW(?E@mw>öϼ¿¿·ÀÒÀ®®®ÛÒ·¨«Ã¬«Ÿ“¬ š¡«Ÿ«´Ÿ™¨®±º°®¨´½ÆÃÀº·À½½ÉϽ««½¿Âȼ³¼ÅÈ¿¯¤°¹¥œ®¯¦µ·ÀÃûøõòïòðêäáÞÞÞÞÞêäáÞÌÊÊÄÀÙª§§­­°¼¿ÃÌÉÃÉÒɱº¶ÈßçëáÝáíîîäÕÌÞÖÓÕÞËØο¢»´®¹Î̽·¹¼ÈÎÏÌÔ×ÝãæÝÝÝÝæÝÈÑÝÝÝÝÝÝçæèççþùóðëìåàÛÒÐÐßïäôýúðððêçØÚáêíþ ýôèâÙâåú þúøîȼ¤àûõý ã» åßÝŹ¤±ëêÿ ?7OjLLROA;^R1.+.7C*Nc{o3WT30ID_bCC2:TTŠb_­¡la^W?)$ AP\Žœ¬…ˆ”d^lœ«¥s&(/ù,lšÉ\DGG>;HEB?+7mv\M2)ü -T`Y@<âæøéݹ¼¼¼¶§§¶ÑÚ³ª§ª±±«€•”¡§ª¶¿Â­˜¤¹·´®´ºÃÃÃÆǽ±¨½Æ±·ºÀÀÈѹſ¼³«¨®´¨¥¨««¯ÇÅ¿ ÿùöóðïóðíêçêêêêêêäáÞÃÆÉÒÕÊÃÀÃÉ¢¢±ÆÎȼÂÈË×ιÆÑÛååßêççôöóÛÕØÞÕÒÕÞÎÕέ·º½¶¼½·½ÂÈÌÏÉÀÔ×ÚÝàààÚÔàØÌÒØÛÛÛÛÛØÝëðõûöñèëêãàÛÔÑÐÜèéèèîôåâßÜÐÒÛáäöü÷îâÜÓÙÓî   &ûæǬªéþõìøòïëʸ -ýëëïθÁÐÜÊ ;•òM&,DGPkF+.4(71.+AMGY\DDGA'=GA;;;JJGWIULIdsj.#   ü;ShÏÛ™ƒ„Žzvqec5J F;ã1`o‚XW;,AJ852/22J\P>/6ÿ '*ùááÞÛØñ«¨°³¶¿¼¼°§¤§¯­¡˜—–•¡«®·½À«´À·²¯²ÁÊßÜÖÐͺ´®ºÀ·ºº½ÆÆÆýýº±«Ãº®¨¨´±«¥¸¹¿ÿÿùöóðïðððóóðððððêäáÞáÛØÌÆÆÀ·±¨º´««¯¿ÑË¿ÈÔÑ¿ÏÂÔéñôíéêöúóØÛäÞÕÒÕÞÑÕÎÈ¿ºÃƹ­®±ÀÈÎÏÏƺ×××ÔÔÚÚÔÑÚØÒÒØÛÛÛÛÛÌ×éôÿýçæàÝÚÛØÕÛäçÜÜâñÜÜÖÓÍÏÕÞáíÿüö÷ñâÜÖâÖô ùûÿøëÚ¿¸µ¼æõøûþøîÖÄ÷ýâåøßÇÜèåÁ';Y}M>_qS2A)25,) #/05VJ;P;>D'/>& 2G2;57."OR^”ÄÇIF&#JYb™¦‰†xgpm^XI$-MRW ÷óûÝì( 9›y;741.(""-!36*$-3  õøåØÏÌÆÃÃÒº±´Ã½À½«¢«Ÿœ¢°ªž ¦Ÿœ˜¡«²²µ¸¸»¬¸Ê¶¶¼Î××Ñ˼º´´ººÀ½½½ÌÀºÏÆýº±«¶°³ÂÈ¿¶°§¬³Å ÿùöóðíìðóöùðððððêäáÞíäÞÌÃ¥±º½ºÆº¨¢¢¼ÚμÂÑ˿μÎæïóèäæóôðááäÞÕÒÕÞÔÒÎËÈÀÃÿ­®®½ÅÈÌÏÉÀÚ×ÔÑÎÑÔÔÔÕÕÕÕÕÛÛÛÛÛÌ×éòý%)åãßÝÚáÚ×ÛâÜÙÜßèßÜÙÖÏÒÛáäêüùðý÷èâÜÜÖñüïêéâѸ¾ÇÅÚéûû ðßÊëôúñôôåéÓÜè÷Ö !EDA>/#ewM&G,/5)/),\J8MA>;/.2##2M8>8/6*QZco«m`22/#>SnŠ“su^muoH0#;F?Eüïíðèéõ"&k<274(%%$''$'0- ÿúëèßÏÀÀÀº·Ã·±ºÆÀÀ·«¥¨ŸœŸ­ª£¢¥¨¤¡ª´µµµµµÁ¬¸Ð¿¿¿Î×ÎËÈ¿¼·····ÃÀÀ½Ï½´ÒÌýº±«ªª¶ÅÈ¿¹³°¯¶ÈüùöóðíìðöüÿêêêêêêäáÞäáÞÛ×ÃÊÊÁ²¸²©©¬ÂÈÈ¶ÅŹËÆÏÛÚÖÝÙÞëíêíêçÞÕÒÕÞ×ÒÎÎÑÆÀºÅ³±®·¼¼ÆÌÏÌÚ×ÑËÈÂÈÔàÒÕØÕÕÛÛÛÛÛÕÝçêð$ýãáÛÚÙäÝØÝãÏÙâßÖåâßÙØÛáêíäöóêüôëå¾ÁÙÖýðéëÝÊåèÑÈ×þéõáÖÊèôë*òéÑàïû&(1CFCRO@LS2/,8)MDJDMD,=4+71FjpaGeMGM;Me†scQ<HQ$<j[Nf[j‡7Omj> ÚÁÙëá`Z0<@&,2#  "þÿìæçÞáƨ®½±¥™¢®±Å¼°¶¹§ž›ž­°³§ž·´°¹Ã¸¸µ²²¾ÄÐÊÐÍÇÍÐÓÓÓÖØ··º·´ÉÃÀºÒº®ØÒýº±­«±·«¥·ºº½¶¼Î  ÿùöóçöóäöíùÿóðððóóðíççÕÒÒÌÈÏǦ£»²²¾»µ¼Èȶ¶Å¹ÈÇÈÊÏÒÍÒÊáëäÞÛØÛÌÌÕÕÎÒÑÑÔÃÆÀ­³·Àº°¹«·ØÕοÑÚÔÑÔ×ÚÛÛÛÛÛáááááããßÞÝÿ ùïÜÛãÖËä×ÏÔÛÕÖÙÜßÜÙÙÖØØÞáääêíöüôýúÜÖÙâåîñ  éÓÑиÍÎÑÔ×ããããÉÐÜååôúðêðüääü.4.C1+1CtKBE9!  28JPMM8>_aI..+7OIO_hePSnYeŠ7OL7471.(**( 1:FT\cZ\I? -âÝ÷ÔØ"*'93-! úý*'õòóíáÛéàÛÓÏÏɱ¥¥««««®´·«¨«¨«·½À¿²µ¾±­¹ÊÈÅ¿¼ÈËËÎÙÓÇÇÐÜÇÇÓĽô´½´ÃîÉÀÀÏÉɺ´«°µ¯¦©¬µ»¾ÇÚ××ÿùöóêöóêøüóÿÿðóóóóóóíêçÕÒÒÌÈÎß™®Ã÷½Æ¿Åȹ¹ÈŶƿÀÇÌÌÍÒÍÜëáÞÛÛÕØÒÏÞÑÒÑÑÑÀÀºª¹À̽­°®½ÛÒ°°ÔÝÔÎÑÔÚÚØØØØÞÞÞÞÞíæÛ×ÑðöóïäâÜÔÑçÔËÏàÒÓÖÙÜâßÖÐÙØÞáääêíöýúý÷ßÙÜåîñ÷éÐÎÑ»ÊÎÔÔ×××××ÐÐÐÜâôýøòøûû ,,#&,@kNEKH- 08SSGM8;bzC//,5PMAYcfW]fQfr:CL4(@4."'$ùþ,kh†KD;:ýðøÚåõ!#9$ ú÷ñô÷ õûùóáÛöìäÙÕÕϺ±¥´º±Ÿ°³¶³°¶¿¿¼ÎÊÁý¼»¾ÁÇËËÅÂÂ××ÔÔÐÐÐÓÖâÁ»ÊÊÉ̺·½±À÷ýÀÒÏ÷±«°¶¹¹°­¹³¹ÑÚ×ÑÿùöóöóóöõóÿöüüöððöóííçäáÞÚÂÀ±´ÒÃÃ¥±Ã¿Ź¿Ëų¾¨¶ÆÇÅÉÔÒ×ãÞÞÞÞÕáÛÌç×ÕÑÎË«®ºÅ¤®ÉÌų´ÃØÿÂÝãÎËÎÑÔ×ÕÕÕÕÛÛÛÛÛØ×ÚÛÝÑÓãîìäÒÕÛæÑÈËÚÏÐÓÖÙåâÖÍÙØÞáääêíöýú÷îåßßèý  ÿõóòÍÈÎÁ»ËÚÚ×ÚÚÚÚÙÓÊÓÙî÷ý #5FJ@7:Os(û&GD8DGA52+28;GMeeGR]`W]QNcS[,/A>5555&#üìó î&!CW6M8(%(ùèà( ÿõòòøøøøøïûüöåßðãÛÊáÒ««·±®®ºÉ¯²µ¾¾ÄÙÙÁØÍÇÓÇÀÉËÍËÏÏÉÆÆÕÏÌÆÌÏØÞÞÉÀÆ̯º½««´®º½½º´ºÏ̺±««³¶Â˹°³ÅÈȹ¼Åÿÿùöóÿðóòüùö ùðíùöóðÕÒÒÌȾ½®±Ò··ÃÀ¼Â¹Â¼ÅÎÅ°¸¢¹ÏÏÆÅ×××ÝØÞáäçÕÕÞÞÝØÎËÅý½Ë­®±½Å×½½ÆºË¼ËÑËÈÈÎÑÑÏÏÏÏÕÕÕÕÕØ×ÕÔÒÓÈÝëãàÛÝÞÔÙ×ÑÅÈÊÐÐÓÜÙÙÖÙØÞáääêíöýèýèÜâÙÖß'þüõÍÂËDzËàà×ÝÝÝÝÙÜßÜÙßèîúýýÿùó& ## "WU::Xs4þãôü))&885SLS5)2AGSGOWTBE<W]WWKJ;AG>;8875/çìïý!!2ëßûþ  þìæïïïòæâåñúèÙßôéáêîëèâÛ×ÐÙϺºÀÉý·¹²¯µÇÍÐÙÖĸ¾ÇÇÏÉ¿¼ÄÖÊÇÄÁ¾ÇÇÊÍÛÔÈÈÑŶ¹Â®®·´½Æº·´´·®«º´±¨¥«¶²»Ä¾¸»»¸²¼¿ÈÿÿüùöðöòòòøïìûõòïæãàÝÚ¿¹¡¡¿¹¹×˾¹¼ÅÎÈ°¸¢½ÖÕËÅ××ØÚ×ÚããìÑÑæÚáÜÐÊÃÕ̿Ź´¨´½ã¼¹ª¼ËËÅÈËÑÑÑÑÑÑ×××××àÛÏËÆÖÈØäÝÝÞààÏÜßÑÁÈÊÍÐÓÖÙÙÜÙØÞáääêíöýäüäØáØÒÞ îêïöÍÂËȯÊââÖÖÖÖÖÙÜèßÙÜâè÷üúýýúüòæ +==:1+FH'$@\)øÚçì%@@41[=O=7I47FCOWQ9<6ZZH];XI:@F=7.8;8(íç÷1þDüìÝúÿøüðÞÛáääçÚÙÙèñâÐÙôéÚäîíêâÞÛ×ÑÑÑÈÂÎÑγœ²¯µÊÐÓÓÐÄ©·ÆÃÏ˹²¾ØÆÃÀ½ºÆÌÏÕáÖ¾ÁÊЯ¬»·±½½ÌÕÀ·´±·®¨´«®¨¥«¶­³¼¼¹¿ª¤ªÇÇÍùüú÷úúúúúññññÙÙÙÙ×áÚÑËÈÔÔÔÔÔ­¼Î×ÈÈÅ¿ÀÆÌÒÏÉÀÃÌÕØÜÜÜÜèâÜÓÏÙÛÛÛÛØ̺ÃÂÅ×ÎÅÎËȼ´ÈËÎÎÑÚÚÚÚÉÈÈÈÈÈÈÈÈÈËËËËËËËËËÔÔÔÔÔÑÑÑÑÑÂÈÔ×ÝÎÎÎÎÏÒÛäççêíóøöêÞÛÞÛØên@òòìïÑ¿­²¿ÃÏÕÛÒÌÌÒÖ×××××ÝàéïïïïïïþïÑì"%(+2420,éÛÖÝåú$-5ES;2;55MPcW<6<99999>>855;AGV@7( ïõøï(õ ûöñèßÜâÐÐâÝÜÜÜÜååååãÞààããõïæÑËËȹÅȶ£¾µ¯ÄÊÜÜÜܹ¸¸¸¸Ê¾¸¯¯©¸ÊľÁÄÇÊÆÆÆÆÆ·´®¥ŸŸ¥®······±±±±±®®®®¯¦ Íʵ¸¸¸¸º¸¸ PDL-2.074/utils/0000755000175000017500000000000014200406301013221 5ustar osboxesosboxesPDL-2.074/utils/perldlpp.pl0000755000175000017500000000262714172737500015432 0ustar osboxesosboxes#!/usr/bin/perl # use PDL::NiceSlice; my $prefile = ""; { local $/; $prefile = <>; } my ($postfile) = PDL::NiceSlice->perldlpp($prefile); print $postfile; __END__ =head2 perldlpp.pl =for ref Script to filter PDL::NiceSlice constructs from argument file to STDOUT =for usage perldlpp.pl file-w-niceslice.pm > file-no-niceslice.pm ( unix systems) perl perldlpp.pl file-w-niceslice.pm > file-no-niceslice.pm (win32 systems) C is a preprocessor script for perl module files to filter and translate the PDL::NiceSlice constructs. The name of the file(s) to be filtered is given as argument to the command and the result of the source filtering is output to STDOUT. One use for this script is to preprocess the .pm files installed for PDL to remove the requirement for PDL::NiceSlice filtering in the core PDL modules. This allows PDL to be used with environments such as C that are not compatible with source code filters. It is planned to add C support for this filter to the PDL configure, build, and install process. =for example # For example (using the unix shell): mkdir fixed # filter all pm files in this directory into fixed/ for pm in *.pm ; do perldlpp.pl $pm > fixed/$pm ; done Now the fixed/*.pm files have been PDL::NiceSlice processed and could be used to replace the original input files as "clean" (no source filter) versions. =cut 1; PDL-2.074/win32/0000755000175000017500000000000014200406301013023 5ustar osboxesosboxesPDL-2.074/win32/INSTALL0000644000175000017500000001231314014062163014063 0ustar osboxesosboxesInstalling on Win32 =================== For instructions relating to the installation of PDL binaries (PPM packages) see the wiki: https://github.com/PDLPorters/pdl/wiki/Installing-PDL-on-Windows ######################################################################## ######################################################################## If you would like, instead, to build PDL from source, that's (generally) fairly straight forward. Certain parts of PDL (eg PDL::Slatec and PDL::Minuit) can't be built without a fortran compiler. In the docs that follow I call these parts (somewhat loosely) "the fortran stuff". The absence of a fortran compiler does not prevent one from building PDL - it simply means that the PDL that gets built does not include "the fortran stuff". To Build from Source -------------------- 1) You'll need a make utility and a compiler - dmake/MinGW provides best mileage. To install them onto 32-bit ActivePerl (if you don't already have them) simply: ppm install MinGW Sadly, this approach won't currently work at all with 64-bit ActivePerl. The best way to get MinGW support with 64-bit ActivePerl is to install one of the "Personal Builds" of the MinGW64 compiler available from http://sourceforge.net/projects/mingw-w64/files/Toolchains%20targetting%20Win64/ and install ExtUtils::FakeConfig from CPAN. But while this is not all that difficult for those who are well acquainted with compilers and perl, it's not as straightforward as most novice programmers would like. (If you need to take this approach and have difficulty getting it configured, asking for help at somewhere like http://www.perlmonks.org is probably your best bet.) Another option with ActivePerl (both 32-bit and 64-bit) is to use an appropriate Microsoft Compiler. This may come at the cost of reduced mileage wrt "the fortran stuff" and external libraries support. Strawberry Perl (either 32-bit or 64-bit) is probably the easiest path to take, as it comes with a ready-to-go dmake utility and MinGW compiler. And, as of the perl-5.16.0 builds, it now includes a fortran compiler. For earlier versions of Strawberry Perl a fortran compiler (suitable for building "the fortran stuff") is readily available as a separate download that can be installed straight over the top of the Strawberry Perl installation. If you have difficulty locating that fortran compiler just ask on the Vanilla Perl mailing list. (See http://lists.perl.org/list/win32-vanilla.html ) 2) Then, run: cpan -i ExtUtils::F77 # Optional - this is for "the fortran stuff". # It will fail if it can't find a g77 or gfortran # compiler. If using a Microsoft compiler see # "Other Options" below. # Note that failure here does not prevent you from # from building PDL. It just means that the PDL # you build will be missing "the fortran stuff". cpan -i PGPLOT # Optional - for PGPLOT graphics support. # This will fail if the pgplot C library can't # be found. # It will also fail if no Fortran compiler is # found---simpler to install using ppm # (see above). cpan -i OpenGL # Optional, but recommended - this is for PDL's # TriD support. # Also available via ppm (see above) if there # is any problem building. cpan -i PDL # Will first install any missing pre-requisites. # This should succeed, but the PDL that's built # will be missing some features if any of the # above 'cpan -i ..' commands failed. If it's a developer release that you're trying to install then you'll need to specify the full distribution path info, e.g.: cpan -i CHM/PDL-2.004_997.tar.gz Other Options ------------- 1) Using an MS compiler and f2c instead of MinGW/g77/gfortran The capability of building "the fortran stuff" with an MS compiler, f2c, and associated libraries libi77.lib and libf77.lib probably still exists (but none of the current PDL developers have any knowledge or experience with this option). According to mythology, if you want to use f2c you need to edit win32/win32f77.pl to reflect the location of f2c, the libs and the include file f2c.h. Then, you'll also need to run: perl Makefile.PL F77CONF=win32/win32f77.pl instead of simply: perl Makefile.PL 2) Building a "non-default" (custom) PDL If you don't want to accept a (basic) "default" build of PDL, download the source from CPAN, extract it to some location, cd to that location and edit (the self-documenting) perldl.conf accordingly. Then run, in succession: perl Makefile.PL dmake test dmake install This enables building of such extras as: a) PDL::IO::GD (needs the gd C library); b) PDL::GSL::* modules (needs the gsl C library); c) PDL::GIS::Proj & PDL::Transform::Proj4 (needs the proj4 C library); PDL-2.074/win32/win32f77.pl0000644000175000017500000000542013265417442014671 0ustar osboxesosboxespackage F77Conf; # a minimal hardcoded config designed for win32 # using f2c use Config; BEGIN { $F77Conf::done = 0 } print "Config ",__PACKAGE__->config(),"\n"; print "Compiler ",__PACKAGE__->compiler(),"\n"; print "Runtime ",__PACKAGE__->runtime(),"\n"; print "Trail_ ",__PACKAGE__->trail_() ? "yes" : "no", "\n"; print "Cflags ",__PACKAGE__->cflags(),"\n"; $F77Conf::libs = "C:\\temp\\f2c\\libf77.lib C:\\temp\\f2c\\libi77.lib"; # include path and f2c location are buried in the __DATA__ section __PACKAGE__->mkcompiler; sub config { return 'win32_f2c'; } # change location of f2c libs to match your installation sub runtime { $F77Conf::libs; } sub trail_ { return 1; } sub compiler { $myf77 = &mkcompiler; return "$Config{perl} $myf77"; } sub cflags { return ''; } sub testcompiler { my ($this) = @_; return 1; # for the moment bypass this my $file = "/tmp/testf77$$"; my $ret; open(OUT,">$file.f"); print OUT " print *, 'Hello World'\n"; print OUT " end\n"; close(OUT); print "Compiling the test Fortran program...\n"; my ($compiler,$cflags) = ($this->compiler,$this->cflags); system "$compiler $cflags $file.f -o ${file}_exe"; print "Executing the test program...\n"; if (`${file}_exe` ne " Hello World\n") { print "Test of Fortran Compiler FAILED. \n"; print "Do not know how to compile Fortran on your system\n"; $ret=0; } else{ print "Congratulations you seem to have a working f77!\n"; $ret=1; } unlink("${file}_exe"); unlink("$file.f"); unlink("$file.o") if -e "$file.o"; return $ret; } sub tmpdir { use Cwd; my $dir = exists $ENV{TEMP} ? $ENV{TEMP} : exists $ENV{TMP} ? $ENV{TMP} : cwd; # current working directory as last resort } sub mkcompiler { my $myf77 = tmpdir().'\myf77'; unless ($F77Conf::done) { open my $fi, ">$myf77" or die "couldn't open $myf77"; use Config; print $fi "$Config{startperl}\n"; print $fi join('',); close $fi; } $F77Conf::done = 1; return $myf77; } 1; __DATA__ use Getopt::Std; use File::Basename; getopts('co:'); $cflags = '/nologo /MD /W3 /GX /O2 /D "WIN32" /D "_CONSOLE" /D "_MBCS" /YX /c /I"c:/temp/f2c"'; # this must include the include path for your f2c.h ! $out = ''; $out = $opt_o if defined $opt_o; $fort = $ARGV[0]; $fort =~ s|/|\\|g; $out =~ s|/|\\|g; $out = "/Fo\"$out\""; $c = $fort; $c =~ s/\.f$/.c/; $cdir = '-d' . dirname $c; $obj = $fort; $obj =~ s/\.f$/.obj/; $obj = $opt_o if defined $opt_o; $f2c = 'c:\\temp\\f2c\\f2c'; print "$f2c $cdir $fort\n"; system "$f2c $cdir $fort"; die "error during f2c execution, no $c\n" unless -f $c; # now compile print "cl.exe $out $cflags $c\n"; system "cl.exe $out $cflags $c"; die "error during cl execution\n" unless -f $obj; PDL-2.074/PDLdb.pl0000644000175000017500000115511014172737500013367 0ustar osboxesosboxes =head1 NAME PDLdb.pl - the perl debugger with PDL support =head1 SYNOPSIS export PERL5DB='BEGIN { require "PDLdb.pl" }' # e.g., with sh/bash perl -d your_Perl_script =head1 DESCRIPTION C is an enhanced version of the perl debugger which supports PDL::NiceSlice constructs. Set the PERL5DB environment variable as shown above and it will be loaded automatically by Perl when you invoke a script with C. This documentation tries to outline the structure and services provided by C, i.e., C, and to describe how you can use them. =head1 GENERAL NOTES The debugger can look pretty forbidding to many Perl programmers. There are a number of reasons for this, many stemming out of the debugger's history. When the debugger was first written, Perl didn't have a lot of its nicer features - no references, no lexical variables, no closures, no object-oriented programming. So a lot of the things one would normally have done using such features was done using global variables, globs and the C operator in creative ways. Some of these have survived into the current debugger; a few of the more interesting and still-useful idioms are noted in this section, along with notes on the comments themselves. =head2 Why not use more lexicals? Experienced Perl programmers will note that the debugger code tends to use mostly package globals rather than lexically-scoped variables. This is done to allow a significant amount of control of the debugger from outside the debugger itself. Unfortunately, though the variables are accessible, they're not well documented, so it's generally been a decision that hasn't made a lot of difference to most users. Where appropriate, comments have been added to make variables more accessible and usable, with the understanding that these I debugger internals, and are therefore subject to change. Future development should probably attempt to replace the globals with a well-defined API, but for now, the variables are what we've got. =head2 Automated variable stacking via C As you may recall from reading C, the C operator makes a temporary copy of a variable in the current scope. When the scope ends, the old copy is restored. This is often used in the debugger to handle the automatic stacking of variables during recursive calls: sub foo { local $some_global++; # Do some stuff, then ... return; } What happens is that on entry to the subroutine, C<$some_global> is localized, then altered. When the subroutine returns, Perl automatically undoes the localization, restoring the previous value. Voila, automatic stack management. The debugger uses this trick a I. Of particular note is C, which lets the debugger get control inside of C'ed code. The debugger localizes a saved copy of C<$@> inside the subroutine, which allows it to keep C<$@> safe until it C returns, at which point the previous value of C<$@> is restored. This makes it simple (well, I) to keep track of C<$@> inside Cs which C other C. In any case, watch for this pattern. It occurs fairly often. =head2 The C<^> trick This is used to cleverly reverse the sense of a logical test depending on the value of an auxiliary variable. For instance, the debugger's C (search for subroutines by pattern) allows you to negate the pattern like this: # Find all non-'foo' subs: S !/foo/ Boolean algebra states that the truth table for XOR looks like this: =over 4 =item * 0 ^ 0 = 0 (! not present and no match) --> false, don't print =item * 0 ^ 1 = 1 (! not present and matches) --> true, print =item * 1 ^ 0 = 1 (! present and no match) --> true, print =item * 1 ^ 1 = 0 (! present and matches) --> false, don't print =back As you can see, the first pair applies when C isn't supplied, and the second pair applies when it is. The XOR simply allows us to compact a more complicated if-then-elseif-else into a more elegant (but perhaps overly clever) single test. After all, it needed this explanation... =head2 FLAGS, FLAGS, FLAGS There is a certain C programming legacy in the debugger. Some variables, such as C<$single>, C<$trace>, and C<$frame>, have I values composed of 1, 2, 4, etc. (powers of 2) OR'ed together. This allows several pieces of state to be stored independently in a single scalar. A test like if ($scalar & 4) ... is checking to see if the appropriate bit is on. Since each bit can be "addressed" independently in this way, C<$scalar> is acting sort of like an array of bits. Obviously, since the contents of C<$scalar> are just a bit-pattern, we can save and restore it easily (it will just look like a number). The problem, is of course, that this tends to leave magic numbers scattered all over your program whenever a bit is set, cleared, or checked. So why do it? =over 4 =item * First, doing an arithmetical or bitwise operation on a scalar is just about the fastest thing you can do in Perl: C actually creates a subroutine call, and array and hash lookups are much slower. Is this over-optimization at the expense of readability? Possibly, but the debugger accesses these variables a I. Any rewrite of the code will probably have to benchmark alternate implementations and see which is the best balance of readability and speed, and then document how it actually works. =item * Second, it's very easy to serialize a scalar number. This is done in the restart code; the debugger state variables are saved in C<%ENV> and then restored when the debugger is restarted. Having them be just numbers makes this trivial. =item * Third, some of these variables are being shared with the Perl core smack in the middle of the interpreter's execution loop. It's much faster for a C program (like the interpreter) to check a bit in a scalar than to access several different variables (or a Perl array). =back =head2 What are those C comments for? Any comment containing C means that the comment is either somewhat speculative - it's not exactly clear what a given variable or chunk of code is doing, or that it is incomplete - the basics may be clear, but the subtleties are not completely documented. Send in a patch if you can clear up, fill out, or clarify an C. =head1 DATA STRUCTURES MAINTAINED BY CORE There are a number of special data structures provided to the debugger by the Perl interpreter. The array C<@{$main::{'_<'.$filename}}> (aliased locally to C<@dbline> via glob assignment) contains the text from C<$filename>, with each element corresponding to a single line of C<$filename>. The hash C<%{'_<'.$filename}> (aliased locally to C<%dbline> via glob assignment) contains breakpoints and actions. The keys are line numbers; you can set individual values, but not the whole hash. The Perl interpreter uses this hash to determine where breakpoints have been set. Any true value is considered to be a breakpoint; C uses C<$break_condition\0$action>. Values are magical in numeric context: 1 if the line is breakable, 0 if not. The scalar C<${"_<$filename"}> simply contains the string C<_<$filename>. This is also the case for evaluated strings that contain subroutines, or which are currently being executed. The $filename for Ced strings looks like C<(eval 34)> or C<(re_eval 19)>. =head1 DEBUGGER STARTUP When C starts, it reads an rcfile (C for non-interactive sessions, C<.perldb> for interactive ones) that can set a number of options. In addition, this file may define a subroutine C<&afterinit> that will be executed (in the debugger's context) after the debugger has initialized itself. Next, it checks the C environment variable and treats its contents as the argument of a C command in the debugger. =head2 STARTUP-ONLY OPTIONS The following options can only be specified at startup. To set them in your rcfile, add a call to C<&parse_options("optionName=new_value")>. =over 4 =item * TTY the TTY to use for debugging i/o. =item * noTTY if set, goes in NonStop mode. On interrupt, if TTY is not set, uses the value of noTTY or F<$HOME/.perldbtty$$> to find TTY using Term::Rendezvous. Current variant is to have the name of TTY in this file. =item * ReadLine if false, a dummy ReadLine is used, so you can debug ReadLine applications. =item * NonStop if true, no i/o is performed until interrupt. =item * LineInfo file or pipe to print line number info to. If it is a pipe, a short "emacs like" message is used. =item * RemotePort host:port to connect to on remote host for remote debugging. =item * HistFile file to store session history to. There is no default and so no history file is written unless this variable is explicitly set. =item * HistSize number of commands to store to the file specified in C. Default is 100. =back =head3 SAMPLE RCFILE &parse_options("NonStop=1 LineInfo=db.out"); sub afterinit { $trace = 1; } The script will run without human intervention, putting trace information into C. (If you interrupt it, you had better reset C to something I!) =head1 INTERNALS DESCRIPTION =head2 DEBUGGER INTERFACE VARIABLES Perl supplies the values for C<%sub>. It effectively inserts a C<&DB::DB();> in front of each place that can have a breakpoint. At each subroutine call, it calls C<&DB::sub> with C<$DB::sub> set to the called subroutine. It also inserts a C before the first line. After each Cd file is compiled, but before it is executed, a call to C<&DB::postponed($main::{'_<'.$filename})> is done. C<$filename> is the expanded name of the Cd file (as found via C<%INC>). =head3 IMPORTANT INTERNAL VARIABLES =head4 C<$CreateTTY> Used to control when the debugger will attempt to acquire another TTY to be used for input. =over =item * 1 - on C =item * 2 - debugger is started inside debugger =item * 4 - on startup =back =head4 C<$doret> The value -2 indicates that no return value should be printed. Any other positive value causes C to print return values. =head4 C<$evalarg> The item to be eval'ed by C. Used to prevent messing with the current contents of C<@_> when C is called. =head4 C<$frame> Determines what messages (if any) will get printed when a subroutine (or eval) is entered or exited. =over 4 =item * 0 - No enter/exit messages =item * 1 - Print I messages on subroutine entry =item * 2 - Adds exit messages on subroutine exit. If no other flag is on, acts like 1+2. =item * 4 - Extended messages: C<< I=I from I:I >>. If no other flag is on, acts like 1+4. =item * 8 - Adds parameter information to messages, and overloaded stringify and tied FETCH is enabled on the printed arguments. Ignored if C<4> is not on. =item * 16 - Adds C return from I: I> messages on subroutine/eval exit. Ignored if C<4> is is not on. =back To get everything, use C<$frame=30> (or C as a debugger command). The debugger internally juggles the value of C<$frame> during execution to protect external modules that the debugger uses from getting traced. =head4 C<$level> Tracks current debugger nesting level. Used to figure out how many CE> pairs to surround the line number with when the debugger outputs a prompt. Also used to help determine if the program has finished during command parsing. =head4 C<$onetimeDump> Controls what (if anything) C will print after evaluating an expression. =over 4 =item * C - don't print anything =item * C - use C to display the value returned =item * C - print the methods callable on the first item returned =back =head4 C<$onetimeDumpDepth> Controls how far down C will go before printing C<...> while dumping a structure. Numeric. If C, print all levels. =head4 C<$signal> Used to track whether or not an C signal has been detected. C, which is called before every statement, checks this and puts the user into command mode if it finds C<$signal> set to a true value. =head4 C<$single> Controls behavior during single-stepping. Stacked in C<@stack> on entry to each subroutine; popped again at the end of each subroutine. =over 4 =item * 0 - run continuously. =item * 1 - single-step, go into subs. The C command. =item * 2 - single-step, don't go into subs. The C command. =item * 4 - print current sub depth (turned on to force this when C occurs. =back =head4 C<$trace> Controls the output of trace information. =over 4 =item * 1 - The C command was entered to turn on tracing (every line executed is printed) =item * 2 - watch expressions are active =item * 4 - user defined a C in C =back =head4 C<$slave_editor> 1 if C was directed to a pipe; 0 otherwise. =head4 C<@cmdfhs> Stack of filehandles that C will read commands from. Manipulated by the debugger's C command and C itself. =head4 C<@dbline> Local alias to the magical line array, C<@{$main::{'_<'.$filename}}> , supplied by the Perl interpreter to the debugger. Contains the source. =head4 C<@old_watch> Previous values of watch expressions. First set when the expression is entered; reset whenever the watch expression changes. =head4 C<@saved> Saves important globals (C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>, C<$\>, C<$^W>) so that the debugger can substitute safe values while it's running, and restore them when it returns control. =head4 C<@stack> Saves the current value of C<$single> on entry to a subroutine. Manipulated by the C command to turn off tracing in all subs above the current one. =head4 C<@to_watch> The 'watch' expressions: to be evaluated before each line is executed. =head4 C<@typeahead> The typeahead buffer, used by C. =head4 C<%alias> Command aliases. Stored as character strings to be substituted for a command entered. =head4 C<%break_on_load> Keys are file names, values are 1 (break when this file is loaded) or undef (don't break when it is loaded). =head4 C<%dbline> Keys are line numbers, values are C. If used in numeric context, values are 0 if not breakable, 1 if breakable, no matter what is in the actual hash entry. =head4 C<%had_breakpoints> Keys are file names; values are bitfields: =over 4 =item * 1 - file has a breakpoint in it. =item * 2 - file has an action in it. =back A zero or undefined value means this file has neither. =head4 C<%option> Stores the debugger options. These are character string values. =head4 C<%postponed> Saves breakpoints for code that hasn't been compiled yet. Keys are subroutine names, values are: =over 4 =item * C - break when this sub is compiled =item * C<< break +0 if >> - break (conditionally) at the start of this routine. The condition will be '1' if no condition was specified. =back =head4 C<%postponed_file> This hash keeps track of breakpoints that need to be set for files that have not yet been compiled. Keys are filenames; values are references to hashes. Each of these hashes is keyed by line number, and its values are breakpoint definitions (C). =head1 DEBUGGER INITIALIZATION The debugger's initialization actually jumps all over the place inside this package. This is because there are several BEGIN blocks (which of course execute immediately) spread through the code. Why is that? The debugger needs to be able to change some things and set some things up before the debugger code is compiled; most notably, the C<$deep> variable that C uses to tell when a program has recursed deeply. In addition, the debugger has to turn off warnings while the debugger code is compiled, but then restore them to their original setting before the program being debugged begins executing. The first C block simply turns off warnings by saving the current setting of C<$^W> and then setting it to zero. The second one initializes the debugger variables that are needed before the debugger begins executing. The third one puts C<$^X> back to its former value. We'll detail the second C block later; just remember that if you need to initialize something before the debugger starts really executing, that's where it has to go. =cut package # this is the PDLdb DB; BEGIN {eval 'use IO::Handle'}; # Needed for flush only? breaks under miniperl # Debugger for Perl 5.00x; perl5db.pl patch level: $VERSION = 0.01; $header = "PDLdb.pl version $VERSION"; =head1 DEBUGGER ROUTINES =head2 C This function replaces straight C inside the debugger; it simplifies the process of evaluating code in the user's context. The code to be evaluated is passed via the package global variable C<$DB::evalarg>; this is done to avoid fiddling with the contents of C<@_>. Before we do the C, we preserve the current settings of C<$trace>, C<$single>, C<$^D> and C<$usercontext>. The latter contains the preserved values of C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>, C<$\>, C<$^W> and the user's current package, grabbed when C got control. This causes the proper context to be used when the eval is actually done. Afterward, we restore C<$trace>, C<$single>, and C<$^D>. Next we need to handle C<$@> without getting confused. We save C<$@> in a local lexical, localize C<$saved[0]> (which is where C will put C<$@>), and then call C to capture C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>, C<$\>, and C<$^W>) and set C<$,>, C<$/>, C<$\>, and C<$^W> to values considered sane by the debugger. If there was an C error, we print it on the debugger's output. If C<$onetimedump> is defined, we call C if it's set to 'dump', or C if it's set to 'methods'. Setting it to something else causes the debugger to do the eval but not print the result - handy if you want to do something else with it (the "watch expressions" code does this to get the value of the watch expression but not show it unless it matters). In any case, we then return the list of output from C to the caller, and unwinding restores the former version of C<$@> in C<@saved> as well (the localization of C<$saved[0]> goes away at the end of this scope). =head3 Parameters and variables influencing execution of DB::eval() C isn't parameterized in the standard way; this is to keep the debugger's calls to C from mucking with C<@_>, among other things. The variables listed below influence C's execution directly. =over 4 =item C<$evalarg> - the thing to actually be eval'ed =item C<$trace> - Current state of execution tracing =item C<$single> - Current state of single-stepping =item C<$onetimeDump> - what is to be displayed after the evaluation =item C<$onetimeDumpDepth> - how deep C should go when dumping results =back The following variables are altered by C during its execution. They are "stacked" via C, enabling recursive calls to C. =over 4 =item C<@res> - used to capture output from actual C. =item C<$otrace> - saved value of C<$trace>. =item C<$osingle> - saved value of C<$single>. =item C<$od> - saved value of C<$^D>. =item C<$saved[0]> - saved value of C<$@>. =item $\ - for output of C<$@> if there is an evaluation error. =back =head3 The problem of lexicals The context of C presents us with some problems. Obviously, we want to be 'sandboxed' away from the debugger's internals when we do the eval, but we need some way to control how punctuation variables and debugger globals are used. We can't use local, because the code inside C can see localized variables; and we can't use C either for the same reason. The code in this routine compromises and uses C. After this routine is over, we don't have user code executing in the debugger's context, so we can use C freely. =cut ############################################## Begin lexical danger zone # 'my' variables used here could leak into (that is, be visible in) # the context that the code being evaluated is executing in. This means that # the code could modify the debugger's variables. # # Fiddling with the debugger's context could be Bad. We insulate things as # much as we can. sub eval { # 'my' would make it visible from user code # but so does local! --tchrist # Remember: this localizes @DB::res, not @main::res. local @res; { # Try to keep the user code from messing with us. Save these so that # even if the eval'ed code changes them, we can put them back again. # Needed because the user could refer directly to the debugger's # package globals (and any 'my' variables in this containing scope) # inside the eval(), and we want to try to stay safe. local $otrace = $trace; local $osingle = $single; local $od = $^D; # Untaint the incoming eval() argument. { ($evalarg) = $evalarg =~ /(.*)/s; } # $usercontext built in DB::DB near the comment # "set up the context for DB::eval ..." # Evaluate and save any results. $evalarg = PDL::NiceSlice->perldlpp($evalarg); @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug # Restore those old values. $trace = $otrace; $single = $osingle; $^D = $od; } # Save the current value of $@, and preserve it in the debugger's copy # of the saved precious globals. my $at = $@; # Since we're only saving $@, we only have to localize the array element # that it will be stored in. local $saved[0]; # Preserve the old value of $@ eval { &DB::save }; # Now see whether we need to report an error back to the user. if ($at) { local $\ = ''; print $OUT $at; } # Display as required by the caller. $onetimeDump and $onetimedumpDepth # are package globals. elsif ($onetimeDump) { if ( $onetimeDump eq 'dump' ) { local $option{dumpDepth} = $onetimedumpDepth if defined $onetimedumpDepth; dumpit( $OUT, \@res ); } elsif ( $onetimeDump eq 'methods' ) { methods( $res[0] ); } } ## end elsif ($onetimeDump) @res; } ## end sub eval ############################################## End lexical danger zone # After this point it is safe to introduce lexicals. # The code being debugged will be executing in its own context, and # can't see the inside of the debugger. # # However, one should not overdo it: leave as much control from outside as # possible. If you make something a lexical, it's not going to be addressable # from outside the debugger even if you know its name. # This file is automatically included if you do perl -d. # It's probably not useful to include this yourself. # # Before venturing further into these twisty passages, it is # wise to read the perldebguts man page or risk the ire of dragons. # # (It should be noted that perldebguts will tell you a lot about # the underlying mechanics of how the debugger interfaces into the # Perl interpreter, but not a lot about the debugger itself. The new # comments in this code try to address this problem.) # Note that no subroutine call is possible until &DB::sub is defined # (for subroutines defined outside of the package DB). In fact the same is # true if $deep is not defined. # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich) # modified Perl debugger, to be run from Emacs in perldb-mode # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990 # Johan Vromans -- upgrade to 4.0 pl 10 # Ilya Zakharevich -- patches after 5.001 (and some before ;-) # (We have made efforts to clarify the comments in the change log # in other places; some of them may seem somewhat obscure as they # were originally written, and explaining them away from the code # in question seems conterproductive.. -JM) ######################################################################## # Changes: 0.94 # + A lot of things changed after 0.94. First of all, core now informs # debugger about entry into XSUBs, overloaded operators, tied operations, # BEGIN and END. Handy with `O f=2'. # + This can make debugger a little bit too verbose, please be patient # and report your problems promptly. # + Now the option frame has 3 values: 0,1,2. XXX Document! # + Note that if DESTROY returns a reference to the object (or object), # the deletion of data may be postponed until the next function call, # due to the need to examine the return value. # # Changes: 0.95 # + `v' command shows versions. # # Changes: 0.96 # + `v' command shows version of readline. # primitive completion works (dynamic variables, subs for `b' and `l', # options). Can `p %var' # + Better help (`h <' now works). New commands <<, >>, {, {{. # {dump|print}_trace() coded (to be able to do it from <, <, or {. (A command # without an argument should *never* be a destructive action; this # API is fundamentally screwed up; likewise option setting, which # is equally buggered.) # + Added command stack dump on argument of "?" for >, <, or {. # + Added a semi-built-in doc viewer command that calls man with the # proper %Config::Config path (and thus gets caching, man -k, etc), # or else perldoc on obstreperous platforms. # + Added to and rearranged the help information. # + Detected apparent misuse of { ... } to declare a block; this used # to work but now is a command, and mysteriously gave no complaint. # # Changes: 1.08: Apr 25, 2001 Jon Eveland # BUG FIX: # + This patch to perl5db.pl cleans up formatting issues on the help # summary (h h) screen in the debugger. Mostly columnar alignment # issues, plus converted the printed text to use all spaces, since # tabs don't seem to help much here. # # Changes: 1.09: May 19, 2001 Ilya Zakharevich # Minor bugs corrected; # + Support for auto-creation of new TTY window on startup, either # unconditionally, or if started as a kid of another debugger session; # + New `O'ption CreateTTY # I bits control attempts to create a new TTY on events: # 1: on fork() # 2: debugger is started inside debugger # 4: on startup # + Code to auto-create a new TTY window on OS/2 (currently one # extra window per session - need named pipes to have more...); # + Simplified interface for custom createTTY functions (with a backward # compatibility hack); now returns the TTY name to use; return of '' # means that the function reset the I/O handles itself; # + Better message on the semantic of custom createTTY function; # + Convert the existing code to create a TTY into a custom createTTY # function; # + Consistent support for TTY names of the form "TTYin,TTYout"; # + Switch line-tracing output too to the created TTY window; # + make `b fork' DWIM with CORE::GLOBAL::fork; # + High-level debugger API cmd_*(): # cmd_b_load($filenamepart) # b load filenamepart # cmd_b_line($lineno [, $cond]) # b lineno [cond] # cmd_b_sub($sub [, $cond]) # b sub [cond] # cmd_stop() # Control-C # cmd_d($lineno) # d lineno (B) # The cmd_*() API returns FALSE on failure; in this case it outputs # the error message to the debugging output. # + Low-level debugger API # break_on_load($filename) # b load filename # @files = report_break_on_load() # List files with load-breakpoints # breakable_line_in_filename($name, $from [, $to]) # # First breakable line in the # # range $from .. $to. $to defaults # # to $from, and may be less than # # $to # breakable_line($from [, $to]) # Same for the current file # break_on_filename_line($name, $lineno [, $cond]) # # Set breakpoint,$cond defaults to # # 1 # break_on_filename_line_range($name, $from, $to [, $cond]) # # As above, on the first # # breakable line in range # break_on_line($lineno [, $cond]) # As above, in the current file # break_subroutine($sub [, $cond]) # break on the first breakable line # ($name, $from, $to) = subroutine_filename_lines($sub) # # The range of lines of the text # The low-level API returns TRUE on success, and die()s on failure. # # Changes: 1.10: May 23, 2001 Daniel Lewart # BUG FIXES: # + Fixed warnings generated by "perl -dWe 42" # + Corrected spelling errors # + Squeezed Help (h) output into 80 columns # # Changes: 1.11: May 24, 2001 David Dyck # + Made "x @INC" work like it used to # # Changes: 1.12: May 24, 2001 Daniel Lewart # + Fixed warnings generated by "O" (Show debugger options) # + Fixed warnings generated by "p 42" (Print expression) # Changes: 1.13: Jun 19, 2001 Scott.L.Miller@compaq.com # + Added windowSize option # Changes: 1.14: Oct 9, 2001 multiple # + Clean up after itself on VMS (Charles Lane in 12385) # + Adding "@ file" syntax (Peter Scott in 12014) # + Debug reloading selfloaded stuff (Ilya Zakharevich in 11457) # + $^S and other debugger fixes (Ilya Zakharevich in 11120) # + Forgot a my() declaration (Ilya Zakharevich in 11085) # Changes: 1.15: Nov 6, 2001 Michael G Schwern # + Updated 1.14 change log # + Added *dbline explainatory comments # + Mentioning perldebguts man page # Changes: 1.16: Feb 15, 2002 Mark-Jason Dominus # + $onetimeDump improvements # Changes: 1.17: Feb 20, 2002 Richard Foley # Moved some code to cmd_[.]()'s for clarity and ease of handling, # rationalised the following commands and added cmd_wrapper() to # enable switching between old and frighteningly consistent new # behaviours for diehards: 'o CommandSet=pre580' (sigh...) # a(add), A(del) # action expr (added del by line) # + b(add), B(del) # break [line] (was b,D) # + w(add), W(del) # watch expr (was W,W) # # added del by expr # + h(summary), h h(long) # help (hh) (was h h,h) # + m(methods), M(modules) # ... (was m,v) # + o(option) # lc (was O) # + v(view code), V(view Variables) # ... (was w,V) # Changes: 1.18: Mar 17, 2002 Richard Foley # + fixed missing cmd_O bug # Changes: 1.19: Mar 29, 2002 Spider Boardman # + Added missing local()s -- DB::DB is called recursively. # Changes: 1.20: Feb 17, 2003 Richard Foley # + pre'n'post commands no longer trashed with no args # + watch val joined out of eval() # Changes: 1.21: Jun 04, 2003 Joe McMahon # + Added comments and reformatted source. No bug fixes/enhancements. # + Includes cleanup by Robin Barker and Jarkko Hietaniemi. # Changes: 1.22 Jun 09, 2003 Alex Vandiver # + Flush stdout/stderr before the debugger prompt is printed. # Changes: 1.23: Dec 21, 2003 Dominique Quatravaux # + Fix a side-effect of bug #24674 in the perl debugger ("odd taint bug") # Changes: 1.24: Mar 03, 2004 Richard Foley # + Added command to save all debugger commands for sourcing later. # + Added command to display parent inheritance tree of given class. # + Fixed minor newline in history bug. # Changes: 1.25: Apr 17, 2004 Richard Foley # + Fixed option bug (setting invalid options + not recognising valid short forms) # Changes: 1.26: Apr 22, 2004 Richard Foley # + unfork the 5.8.x and 5.9.x debuggers. # + whitespace and assertions call cleanup across versions # + H * deletes (resets) history # + i now handles Class + blessed objects # Changes: 1.27: May 09, 2004 Richard Foley # + updated pod page references - clunky. # + removed windowid restriction for forking into an xterm. # + more whitespace again. # + wrapped restart and enabled rerun [-n] (go back n steps) command. # Changes: 1.28: Oct 12, 2004 Richard Foley # + Added threads support (inc. e and E commands) # Changes: 1.29: Nov 28, 2006 Bo Lindbergh # + Added macosx_get_fork_TTY support # Changes: 1.30: Mar 06, 2007 Andreas Koenig # + Added HistFile, HistSize # Changes: 1.31 # + Remove support for assertions and -A # + stop NEXT::AUTOLOAD from emitting warnings under the debugger. RT #25053 # + "update for Mac OS X 10.5" [finding the tty device] # + "What I needed to get the forked debugger to work" [on VMS] # + [perl #57016] debugger: o warn=0 die=0 ignored # + Note, but don't use, PERLDBf_SAVESRC # + Fix #7013: lvalue subs not working inside debugger ######################################################################## =head1 DEBUGGER INITIALIZATION The debugger starts up in phases. =head2 BASIC SETUP First, it initializes the environment it wants to run in: turning off warnings during its own compilation, defining variables which it will need to avoid warnings later, setting itself up to not exit when the program terminates, and defaulting to printing return values for the C command. =cut # Needed for the statement after exec(): # # This BEGIN block is simply used to switch off warnings during debugger # compiliation. Probably it would be better practice to fix the warnings, # but this is how it's done at the moment. BEGIN { $ini_warn = $^W; $^W = 0; } # Switch compilation warnings off until another BEGIN. local ($^W) = 0; # Switch run-time warnings off during init. =head2 THREADS SUPPORT If we are running under a threaded Perl, we require threads and threads::shared if the environment variable C is set, to enable proper threaded debugger control. C<-dt> can also be used to set this. Each new thread will be announced and the debugger prompt will always inform you of each new thread created. It will also indicate the thread id in which we are currently running within the prompt like this: [tid] DB<$i> Where C<[tid]> is an integer thread id and C<$i> is the familiar debugger command prompt. The prompt will show: C<[0]> when running under threads, but not actually in a thread. C<[tid]> is consistent with C usage. While running under threads, when you set or delete a breakpoint (etc.), this will apply to all threads, not just the currently running one. When you are in a currently executing thread, you will stay there until it completes. With the current implementation it is not currently possible to hop from one thread to another. The C and C commands are currently fairly minimal - see C and C. Note that threading support was built into the debugger as of Perl version C<5.8.6> and debugger version C<1.2.8>. =cut BEGIN { # ensure we can share our non-threaded variables or no-op if ($ENV{PERL5DB_THREADED}) { require threads; require threads::shared; import threads::shared qw(share); $DBGR; share(\$DBGR); lock($DBGR); print "Threads support enabled\n"; } else { *lock = sub(*) {}; *share = sub(*) {}; } } # This would probably be better done with "use vars", but that wasn't around # when this code was originally written. (Neither was "use strict".) And on # the principle of not fiddling with something that was working, this was # left alone. warn( # Do not ;-) # These variables control the execution of 'dumpvar.pl'. $dumpvar::hashDepth, $dumpvar::arrayDepth, $dumpvar::dumpDBFiles, $dumpvar::dumpPackages, $dumpvar::quoteHighBit, $dumpvar::printUndef, $dumpvar::globPrint, $dumpvar::usageOnly, # used to save @ARGV and extract any debugger-related flags. @ARGS, # used to control die() reporting in diesignal() $Carp::CarpLevel, # used to prevent multiple entries to diesignal() # (if for instance diesignal() itself dies) $panic, # used to prevent the debugger from running nonstop # after a restart $second_time, ) if 0; foreach my $k (keys (%INC)) { &share(\$main::{'_<'.$filename}); }; # Command-line + PERLLIB: # Save the contents of @INC before they are modified elsewhere. @ini_INC = @INC; # This was an attempt to clear out the previous values of various # trapped errors. Apparently it didn't help. XXX More info needed! # $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?! # We set these variables to safe values. We don't want to blindly turn # off warnings, because other packages may still want them. $trace = $signal = $single = 0; # Uninitialized warning suppression # (local $^W cannot help - other packages!). # Default to not exiting when program finishes; print the return # value when the 'r' command is used to return from a subroutine. $inhibit_exit = $option{PrintRet} = 1; =head1 OPTION PROCESSING The debugger's options are actually spread out over the debugger itself and C; some of these are variables to be set, while others are subs to be called with a value. To try to make this a little easier to manage, the debugger uses a few data structures to define what options are legal and how they are to be processed. First, the C<@options> array defines the I of all the options that are to be accepted. =cut @options = qw( CommandSet HistFile HistSize hashDepth arrayDepth dumpDepth DumpDBFiles DumpPackages DumpReused compactDump veryCompact quote HighBit undefPrint globPrint PrintRet UsageOnly frame AutoTrace TTY noTTY ReadLine NonStop LineInfo maxTraceLen recallCommand ShellBang pager tkRunning ornaments signalLevel warnLevel dieLevel inhibit_exit ImmediateStop bareStringify CreateTTY RemotePort windowSize DollarCaretP ); @RememberOnROptions = qw(DollarCaretP); =pod Second, C lists the variables that each option uses to save its state. =cut %optionVars = ( hashDepth => \$dumpvar::hashDepth, arrayDepth => \$dumpvar::arrayDepth, CommandSet => \$CommandSet, DumpDBFiles => \$dumpvar::dumpDBFiles, DumpPackages => \$dumpvar::dumpPackages, DumpReused => \$dumpvar::dumpReused, HighBit => \$dumpvar::quoteHighBit, undefPrint => \$dumpvar::printUndef, globPrint => \$dumpvar::globPrint, UsageOnly => \$dumpvar::usageOnly, CreateTTY => \$CreateTTY, bareStringify => \$dumpvar::bareStringify, frame => \$frame, AutoTrace => \$trace, inhibit_exit => \$inhibit_exit, maxTraceLen => \$maxtrace, ImmediateStop => \$ImmediateStop, RemotePort => \$remoteport, windowSize => \$window, HistFile => \$histfile, HistSize => \$histsize, ); =pod Third, C<%optionAction> defines the subroutine to be called to process each option. =cut %optionAction = ( compactDump => \&dumpvar::compactDump, veryCompact => \&dumpvar::veryCompact, quote => \&dumpvar::quote, TTY => \&TTY, noTTY => \&noTTY, ReadLine => \&ReadLine, NonStop => \&NonStop, LineInfo => \&LineInfo, recallCommand => \&recallCommand, ShellBang => \&shellBang, pager => \&pager, signalLevel => \&signalLevel, warnLevel => \&warnLevel, dieLevel => \&dieLevel, tkRunning => \&tkRunning, ornaments => \&ornaments, RemotePort => \&RemotePort, DollarCaretP => \&DollarCaretP, ); =pod Last, the C<%optionRequire> notes modules that must be Cd if an option is used. =cut # Note that this list is not complete: several options not listed here # actually require that dumpvar.pl be loaded for them to work, but are # not in the table. A subsequent patch will correct this problem; for # the moment, we're just recommenting, and we are NOT going to change # function. %optionRequire = ( compactDump => 'dumpvar.pl', veryCompact => 'dumpvar.pl', quote => 'dumpvar.pl', ); =pod There are a number of initialization-related variables which can be set by putting code to set them in a BEGIN block in the C environment variable. These are: =over 4 =item C<$rl> - readline control XXX needs more explanation =item C<$warnLevel> - whether or not debugger takes over warning handling =item C<$dieLevel> - whether or not debugger takes over die handling =item C<$signalLevel> - whether or not debugger takes over signal handling =item C<$pre> - preprompt actions (array reference) =item C<$post> - postprompt actions (array reference) =item C<$pretype> =item C<$CreateTTY> - whether or not to create a new TTY for this debugger =item C<$CommandSet> - which command set to use (defaults to new, documented set) =back =cut # These guys may be defined in $ENV{PERL5DB} : $rl = 1 unless defined $rl; $warnLevel = 1 unless defined $warnLevel; $dieLevel = 1 unless defined $dieLevel; $signalLevel = 1 unless defined $signalLevel; $pre = [] unless defined $pre; $post = [] unless defined $post; $pretype = [] unless defined $pretype; $CreateTTY = 3 unless defined $CreateTTY; $CommandSet = '580' unless defined $CommandSet; share($rl); share($warnLevel); share($dieLevel); share($signalLevel); share($pre); share($post); share($pretype); share($rl); share($CreateTTY); share($CommandSet); =pod The default C, C, and C handlers are set up. =cut warnLevel($warnLevel); dieLevel($dieLevel); signalLevel($signalLevel); =pod The pager to be used is needed next. We try to get it from the environment first. If it's not defined there, we try to find it in the Perl C. If it's not there, we default to C. We then call the C function to save the pager name. =cut # This routine makes sure $pager is set up so that '|' can use it. pager( # If PAGER is defined in the environment, use it. defined $ENV{PAGER} ? $ENV{PAGER} # If not, see if Config.pm defines it. : eval { require Config } && defined $Config::Config{pager} ? $Config::Config{pager} # If not, fall back to 'more'. : 'more' ) unless defined $pager; =pod We set up the command to be used to access the man pages, the command recall character (C unless otherwise defined) and the shell escape character (C unless otherwise defined). Yes, these do conflict, and neither works in the debugger at the moment. =cut setman(); # Set up defaults for command recall and shell escape (note: # these currently don't work in linemode debugging). &recallCommand("!") unless defined $prc; &shellBang("!") unless defined $psh; =pod We then set up the gigantic string containing the debugger help. We also set the limit on the number of arguments we'll display during a trace. =cut sethelp(); # If we didn't get a default for the length of eval/stack trace args, # set it here. $maxtrace = 400 unless defined $maxtrace; =head2 SETTING UP THE DEBUGGER GREETING The debugger I helps to inform the user how many debuggers are running, and whether the current debugger is the primary or a child. If we are the primary, we just hang onto our pid so we'll have it when or if we start a child debugger. If we are a child, we'll set things up so we'll have a unique greeting and so the parent will give us our own TTY later. We save the current contents of the C environment variable because we mess around with it. We'll also need to hang onto it because we'll need it if we restart. Child debuggers make a label out of the current PID structure recorded in PERLDB_PIDS plus the new PID. They also mark themselves as not having a TTY yet so the parent will give them one later via C. =cut # Save the current contents of the environment; we're about to # much with it. We'll need this if we have to restart. $ini_pids = $ENV{PERLDB_PIDS}; if ( defined $ENV{PERLDB_PIDS} ) { # We're a child. Make us a label out of the current PID structure # recorded in PERLDB_PIDS plus our (new) PID. Mark us as not having # a term yet so the parent will give us one later via resetterm(). my $env_pids = $ENV{PERLDB_PIDS}; $pids = "[$env_pids]"; # Unless we are on OpenVMS, all programs under the DCL shell run under # the same PID. if (($^O eq 'VMS') && ($env_pids =~ /\b$$\b/)) { $term_pid = $$; } else { $ENV{PERLDB_PIDS} .= "->$$"; $term_pid = -1; } } ## end if (defined $ENV{PERLDB_PIDS... else { # We're the parent PID. Initialize PERLDB_PID in case we end up with a # child debugger, and mark us as the parent, so we'll know to set up # more TTY's is we have to. $ENV{PERLDB_PIDS} = "$$"; $pids = "[pid=$$]"; $term_pid = $$; } $pidprompt = ''; # Sets up $emacs as a synonym for $slave_editor. *emacs = $slave_editor if $slave_editor; # May be used in afterinit()... =head2 READING THE RC FILE The debugger will read a file of initialization options if supplied. If running interactively, this is C<.perldb>; if not, it's C. =cut # As noted, this test really doesn't check accurately that the debugger # is running at a terminal or not. my $dev_tty = '/dev/tty'; $dev_tty = 'TT:' if ($^O eq 'VMS'); if ( -e $dev_tty ) { # this is the wrong metric! $rcfile = ".perldb"; } else { $rcfile = "perldb.ini"; } =pod The debugger does a safety test of the file to be read. It must be owned either by the current user or root, and must only be writable by the owner. =cut # This wraps a safety test around "do" to read and evaluate the init file. # # This isn't really safe, because there's a race # between checking and opening. The solution is to # open and fstat the handle, but then you have to read and # eval the contents. But then the silly thing gets # your lexical scope, which is unfortunate at best. sub safe_do { my $file = shift; # Just exactly what part of the word "CORE::" don't you understand? local $SIG{__WARN__}; local $SIG{__DIE__}; unless ( is_safe_file($file) ) { CORE::warn < command is invoked, it tries to capture all of the state it can into environment variables, and then sets C. When we start executing again, we check to see if C is there; if so, we reload all the information that the R command stuffed into the environment variables. PERLDB_RESTART - flag only, contains no restart data itself. PERLDB_HIST - command history, if it's available PERLDB_ON_LOAD - breakpoints set by the rc file PERLDB_POSTPONE - subs that have been loaded/not executed, and have actions PERLDB_VISITED - files that had breakpoints PERLDB_FILE_... - breakpoints for a file PERLDB_OPT - active options PERLDB_INC - the original @INC PERLDB_PRETYPE - preprompt debugger actions PERLDB_PRE - preprompt Perl code PERLDB_POST - post-prompt Perl code PERLDB_TYPEAHEAD - typeahead captured by readline() We chug through all these variables and plug the values saved in them back into the appropriate spots in the debugger. =cut if ( exists $ENV{PERLDB_RESTART} ) { # We're restarting, so we don't need the flag that says to restart anymore. delete $ENV{PERLDB_RESTART}; # $restart = 1; @hist = get_list('PERLDB_HIST'); %break_on_load = get_list("PERLDB_ON_LOAD"); %postponed = get_list("PERLDB_POSTPONE"); share(@hist); share(@truehist); share(%break_on_load); share(%postponed); # restore breakpoints/actions my @had_breakpoints = get_list("PERLDB_VISITED"); for ( 0 .. $#had_breakpoints ) { my %pf = get_list("PERLDB_FILE_$_"); $postponed_file{ $had_breakpoints[$_] } = \%pf if %pf; } # restore options my %opt = get_list("PERLDB_OPT"); my ( $opt, $val ); while ( ( $opt, $val ) = each %opt ) { $val =~ s/[\\\']/\\$1/g; parse_options("$opt'$val'"); } # restore original @INC @INC = get_list("PERLDB_INC"); @ini_INC = @INC; # return pre/postprompt actions and typeahead buffer $pretype = [ get_list("PERLDB_PRETYPE") ]; $pre = [ get_list("PERLDB_PRE") ]; $post = [ get_list("PERLDB_POST") ]; @typeahead = get_list( "PERLDB_TYPEAHEAD", @typeahead ); } ## end if (exists $ENV{PERLDB_RESTART... =head2 SETTING UP THE TERMINAL Now, we'll decide how the debugger is going to interact with the user. If there's no TTY, we set the debugger to run non-stop; there's not going to be anyone there to enter commands. =cut if ($notty) { $runnonstop = 1; share($runnonstop); } =pod If there is a TTY, we have to determine who it belongs to before we can proceed. If this is a slave editor or graphical debugger (denoted by the first command-line switch being '-emacs'), we shift this off and set C<$rl> to 0 (XXX ostensibly to do straight reads). =cut else { # Is Perl being run from a slave editor or graphical debugger? # If so, don't use readline, and set $slave_editor = 1. $slave_editor = ( ( defined $main::ARGV[0] ) and ( $main::ARGV[0] eq '-emacs' ) ); $rl = 0, shift(@main::ARGV) if $slave_editor; #require Term::ReadLine; =pod We then determine what the console should be on various systems: =over 4 =item * Cygwin - We use C instead of a separate device. =cut if ( $^O eq 'cygwin' ) { # /dev/tty is binary. use stdin for textmode undef $console; } =item * Unix - use C. =cut elsif ( -e "/dev/tty" ) { $console = "/dev/tty"; } =item * Windows or MSDOS - use C. =cut elsif ( $^O eq 'dos' or -e "con" or $^O eq 'MSWin32' ) { $console = "con"; } =item * MacOS - use C if this is the MPW version; C if not. Note that Mac OS X returns C, not C. Also note that the debugger doesn't do anything special for C. Maybe it should. =cut elsif ( $^O eq 'MacOS' ) { if ( $MacPerl::Version !~ /MPW/ ) { $console = "Dev:Console:Perl Debug"; # Separate window for application } else { $console = "Dev:Console"; } } ## end elsif ($^O eq 'MacOS') =item * VMS - use C. =cut else { # everything else is ... $console = "sys\$command"; } =pod =back Several other systems don't use a specific console. We C for those (Windows using a slave editor/graphical debugger, NetWare, OS/2 with a slave editor, Epoc). =cut if ( ( $^O eq 'MSWin32' ) and ( $slave_editor or defined $ENV{EMACS} ) ) { # /dev/tty is binary. use stdin for textmode $console = undef; } if ( $^O eq 'NetWare' ) { # /dev/tty is binary. use stdin for textmode $console = undef; } # In OS/2, we need to use STDIN to get textmode too, even though # it pretty much looks like Unix otherwise. if ( defined $ENV{OS2_SHELL} and ( $slave_editor or $ENV{WINDOWID} ) ) { # In OS/2 $console = undef; } # EPOC also falls into the 'got to use STDIN' camp. if ( $^O eq 'epoc' ) { $console = undef; } =pod If there is a TTY hanging around from a parent, we use that as the console. =cut $console = $tty if defined $tty; =head2 SOCKET HANDLING The debugger is capable of opening a socket and carrying out a debugging session over the socket. If C was defined in the options, the debugger assumes that it should try to start a debugging session on that port. It builds the socket and then tries to connect the input and output filehandles to it. =cut # Handle socket stuff. if ( defined $remoteport ) { # If RemotePort was defined in the options, connect input and output # to the socket. require IO::Socket; $OUT = new IO::Socket::INET( Timeout => '10', PeerAddr => $remoteport, Proto => 'tcp', ); if ( !$OUT ) { die "Unable to connect to remote host: $remoteport\n"; } $IN = $OUT; } ## end if (defined $remoteport) =pod If no C was defined, and we want to create a TTY on startup, this is probably a situation where multiple debuggers are running (for example, a backticked command that starts up another debugger). We create a new IN and OUT filehandle, and do the necessary mojo to create a new TTY if we know how and if we can. =cut # Non-socket. else { # Two debuggers running (probably a system or a backtick that invokes # the debugger itself under the running one). create a new IN and OUT # filehandle, and do the necessary mojo to create a new tty if we # know how, and we can. create_IN_OUT(4) if $CreateTTY & 4; if ($console) { # If we have a console, check to see if there are separate ins and # outs to open. (They are assumed identical if not.) my ( $i, $o ) = split /,/, $console; $o = $i unless defined $o; # read/write on in, or just read, or read on STDIN. open( IN, "+<$i" ) || open( IN, "<$i" ) || open( IN, "<&STDIN" ); # read/write/create/clobber out, or write/create/clobber out, # or merge with STDERR, or merge with STDOUT. open( OUT, "+>$o" ) || open( OUT, ">$o" ) || open( OUT, ">&STDERR" ) || open( OUT, ">&STDOUT" ); # so we don't dongle stdout } ## end if ($console) elsif ( not defined $console ) { # No console. Open STDIN. open( IN, "<&STDIN" ); # merge with STDERR, or with STDOUT. open( OUT, ">&STDERR" ) || open( OUT, ">&STDOUT" ); # so we don't dongle stdout $console = 'STDIN/OUT'; } ## end elsif (not defined $console) # Keep copies of the filehandles so that when the pager runs, it # can close standard input without clobbering ours. $IN = \*IN, $OUT = \*OUT if $console or not defined $console; } ## end elsif (from if(defined $remoteport)) # Unbuffer DB::OUT. We need to see responses right away. my $previous = select($OUT); $| = 1; # for DB::OUT select($previous); # Line info goes to debugger output unless pointed elsewhere. # Pointing elsewhere makes it possible for slave editors to # keep track of file and position. We have both a filehandle # and a I/O description to keep track of. $LINEINFO = $OUT unless defined $LINEINFO; $lineinfo = $console unless defined $lineinfo; # share($LINEINFO); # <- unable to share globs share($lineinfo); # =pod To finish initialization, we show the debugger greeting, and then call the C subroutine if there is one. =cut # Show the debugger greeting. $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/; unless ($runnonstop) { local $\ = ''; local $, = ''; if ( $term_pid eq '-1' ) { print $OUT "\nDaughter DB session started...\n"; } else { print $OUT "\nLoading DB routines from $header\n"; print $OUT ( "Editor support ", $slave_editor ? "enabled" : "available", ".\n" ); print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n"; } ## end else [ if ($term_pid eq '-1') } ## end unless ($runnonstop) } ## end else [ if ($notty) # XXX This looks like a bug to me. # Why copy to @ARGS and then futz with @args? @ARGS = @ARGV; for (@args) { # Make sure backslashes before single quotes are stripped out, and # keep args unless they are numeric (XXX why?) # s/\'/\\\'/g; # removed while not justified understandably # s/(.*)/'$1'/ unless /^-?[\d.]+$/; # ditto } # If there was an afterinit() sub defined, call it. It will get # executed in our scope, so it can fiddle with debugger globals. if ( defined &afterinit ) { # May be defined in $rcfile &afterinit(); } # Inform us about "Stack dump during die enabled ..." in dieLevel(). $I_m_init = 1; ############################################################ Subroutines =head1 SUBROUTINES =head2 DB This gigantic subroutine is the heart of the debugger. Called before every statement, its job is to determine if a breakpoint has been reached, and stop if so; read commands from the user, parse them, and execute them, and hen send execution off to the next statement. Note that the order in which the commands are processed is very important; some commands earlier in the loop will actually alter the C<$cmd> variable to create other commands to be executed later. This is all highly I but can be confusing. Check the comments for each C<$cmd ... && do {}> to see what's happening in any given command. =cut require PDL::NiceSlice; sub DB { # lock the debugger and get the thread id for the prompt lock($DBGR); my $tid; if ($ENV{PERL5DB_THREADED}) { $tid = eval { "[".threads->tid."]" }; } # Check for whether we should be running continuously or not. # _After_ the perl program is compiled, $single is set to 1: if ( $single and not $second_time++ ) { # Options say run non-stop. Run until we get an interrupt. if ($runnonstop) { # Disable until signal # If there's any call stack in place, turn off single # stepping into subs throughout the stack. for ( $i = 0 ; $i <= $stack_depth ; ) { $stack[ $i++ ] &= ~1; } # And we are now no longer in single-step mode. $single = 0; # If we simply returned at this point, we wouldn't get # the trace info. Fall on through. # return; } ## end if ($runnonstop) elsif ($ImmediateStop) { # We are supposed to stop here; XXX probably a break. $ImmediateStop = 0; # We've processed it; turn it off $signal = 1; # Simulate an interrupt to force # us into the command loop } } ## end if ($single and not $second_time... # If we're in single-step mode, or an interrupt (real or fake) # has occurred, turn off non-stop mode. $runnonstop = 0 if $single or $signal; # Preserve current values of $@, $!, $^E, $,, $/, $\, $^W. # The code being debugged may have altered them. &save; # Since DB::DB gets called after every line, we can use caller() to # figure out where we last were executing. Sneaky, eh? This works because # caller is returning all the extra information when called from the # debugger. local ( $package, $filename, $line ) = caller; local $filename_ini = $filename; # set up the context for DB::eval, so it can properly execute # code on behalf of the user. We add the package in so that the # code is eval'ed in the proper package (not in the debugger!). local $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' . "package $package;"; # Create an alias to the active file magical array to simplify # the code here. local (*dbline) = $main::{ '_<' . $filename }; # we need to check for pseudofiles on Mac OS (these are files # not attached to a filename, but instead stored in Dev:Pseudo) if ( $^O eq 'MacOS' && $#dbline < 0 ) { $filename_ini = $filename = 'Dev:Pseudo'; *dbline = $main::{ '_<' . $filename }; } # Last line in the program. local $max = $#dbline; # if we have something here, see if we should break. if ( $dbline{$line} && ( ( $stop, $action ) = split( /\0/, $dbline{$line} ) ) ) { # Stop if the stop criterion says to just stop. if ( $stop eq '1' ) { $signal |= 1; } # It's a conditional stop; eval it in the user's context and # see if we should stop. If so, remove the one-time sigil. elsif ($stop) { $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval; $dbline{$line} =~ s/;9($|\0)/$1/; } } ## end if ($dbline{$line} && ... # Preserve the current stop-or-not, and see if any of the W # (watch expressions) has changed. my $was_signal = $signal; # If we have any watch expressions ... if ( $trace & 2 ) { for ( my $n = 0 ; $n <= $#to_watch ; $n++ ) { $evalarg = $to_watch[$n]; local $onetimeDump; # Tell DB::eval() to not output results # Fix context DB::eval() wants to return an array, but # we need a scalar here. my ($val) = join( "', '", &eval ); $val = ( ( defined $val ) ? "'$val'" : 'undef' ); # Did it change? if ( $val ne $old_watch[$n] ) { # Yep! Show the difference, and fake an interrupt. $signal = 1; print $OUT < C is a function that can be defined by the user; it is a function which will be run on each entry to C; it gets the current package, filename, and line as its parameters. The watchfunction can do anything it likes; it is executing in the debugger's context, so it has access to all of the debugger's internal data structures and functions. C can control the debugger's actions. Any of the following will cause the debugger to return control to the user's program after C executes: =over 4 =item * Returning a false value from the C itself. =item * Altering C<$single> to a false value. =item * Altering C<$signal> to a false value. =item * Turning off the C<4> bit in C<$trace> (this also disables the check for C. This can be done with $trace &= ~4; =back =cut # If there's a user-defined DB::watchfunction, call it with the # current package, filename, and line. The function executes in # the DB:: package. if ( $trace & 4 ) { # User-installed watch return if watchfunction( $package, $filename, $line ) and not $single and not $was_signal and not( $trace & ~4 ); } ## end if ($trace & 4) # Pick up any alteration to $signal in the watchfunction, and # turn off the signal now. $was_signal = $signal; $signal = 0; =head2 GETTING READY TO EXECUTE COMMANDS The debugger decides to take control if single-step mode is on, the C command was entered, or the user generated a signal. If the program has fallen off the end, we set things up so that entering further commands won't cause trouble, and we say that the program is over. =cut # Check to see if we should grab control ($single true, # trace set appropriately, or we got a signal). if ( $single || ( $trace & 1 ) || $was_signal ) { # Yes, grab control. if ($slave_editor) { # Tell the editor to update its position. $position = "\032\032$filename:$line:0\n"; print_lineinfo($position); } =pod Special check: if we're in package C, we've gone through the C block at least once. We set up everything so that we can continue to enter commands and have a valid context to be in. =cut elsif ( $package eq 'DB::fake' ) { # Fallen off the end already. $term || &setterm; print_help(< to quit or B to restart, use B I to avoid stopping after program termination, B, B or B to get additional info. EOP # Set the DB::eval context appropriately. $package = 'main'; $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' . "package $package;"; # this won't let them modify, alas } ## end elsif ($package eq 'DB::fake') =pod If the program hasn't finished executing, we scan forward to the next executable line, print that out, build the prompt from the file and line number information, and print that. =cut else { # Still somewhere in the midst of execution. Set up the # debugger prompt. $sub =~ s/\'/::/; # Swap Perl 4 package separators (') to # Perl 5 ones (sorry, we don't print Klingon #module names) $prefix = $sub =~ /::/ ? "" : "${'package'}::"; $prefix .= "$sub($filename:"; $after = ( $dbline[$line] =~ /\n$/ ? '' : "\n" ); # Break up the prompt if it's really long. if ( length($prefix) > 30 ) { $position = "$prefix$line):\n$line:\t$dbline[$line]$after"; $prefix = ""; $infix = ":\t"; } else { $infix = "):\t"; $position = "$prefix$line$infix$dbline[$line]$after"; } # Print current line info, indenting if necessary. if ($frame) { print_lineinfo( ' ' x $stack_depth, "$line:\t$dbline[$line]$after" ); } else { print_lineinfo($position); } # Scan forward, stopping at either the end or the next # unbreakable line. for ( $i = $line + 1 ; $i <= $max && $dbline[$i] == 0 ; ++$i ) { #{ vi # Drop out on null statements, block closers, and comments. last if $dbline[$i] =~ /^\s*[\;\}\#\n]/; # Drop out if the user interrupted us. last if $signal; # Append a newline if the line doesn't have one. Can happen # in eval'ed text, for instance. $after = ( $dbline[$i] =~ /\n$/ ? '' : "\n" ); # Next executable line. $incr_pos = "$prefix$i$infix$dbline[$i]$after"; $position .= $incr_pos; if ($frame) { # Print it indented if tracing is on. print_lineinfo( ' ' x $stack_depth, "$i:\t$dbline[$i]$after" ); } else { print_lineinfo($incr_pos); } } ## end for ($i = $line + 1 ; $i... } ## end else [ if ($slave_editor) } ## end if ($single || ($trace... =pod If there's an action to be executed for the line we stopped at, execute it. If there are any preprompt actions, execute those as well. =cut # If there's an action, do it now. $evalarg = $action, &eval if $action; # Are we nested another level (e.g., did we evaluate a function # that had a breakpoint in it at the debugger prompt)? if ( $single || $was_signal ) { # Yes, go down a level. local $level = $level + 1; # Do any pre-prompt actions. foreach $evalarg (@$pre) { &eval; } # Complain about too much recursion if we passed the limit. print $OUT $stack_depth . " levels deep in subroutine calls!\n" if $single & 4; # The line we're currently on. Set $incr to -1 to stay here # until we get a command that tells us to advance. $start = $line; $incr = -1; # for backward motion. # Tack preprompt debugger actions ahead of any actual input. @typeahead = ( @$pretype, @typeahead ); =head2 WHERE ARE WE? XXX Relocate this section? The debugger normally shows the line corresponding to the current line of execution. Sometimes, though, we want to see the next line, or to move elsewhere in the file. This is done via the C<$incr>, C<$start>, and C<$max> variables. C<$incr> controls by how many lines the I line should move forward after a command is executed. If set to -1, this indicates that the I line shouldn't change. C<$start> is the I line. It is used for things like knowing where to move forwards or backwards from when doing an C or C<-> command. C<$max> tells the debugger where the last line of the current file is. It's used to terminate loops most often. =head2 THE COMMAND LOOP Most of C is actually a command parsing and dispatch loop. It comes in two parts: =over 4 =item * The outer part of the loop, starting at the C label. This loop reads a command and then executes it. =item * The inner part of the loop, starting at the C label. This part is wholly contained inside the C block and only executes a command. Used to handle commands running inside a pager. =back So why have two labels to restart the loop? Because sometimes, it's easier to have a command I another command and then re-execute the loop to do the new command. This is faster, but perhaps a bit more convoluted. =cut # The big command dispatch loop. It keeps running until the # user yields up control again. # # If we have a terminal for input, and we get something back # from readline(), keep on processing. CMD: while ( # We have a terminal, or can get one ... ( $term || &setterm ), # ... and it belogs to this PID or we get one for this PID ... ( $term_pid == $$ or resetterm(1) ), # ... and we got a line of command input ... defined( $cmd = &readline( "$pidprompt $tid DB" . ( '<' x $level ) . ( $#hist + 1 ) . ( '>' x $level ) . " " ) ) ) { share($cmd); # ... try to execute the input as debugger commands. # Don't stop running. $single = 0; # No signal is active. $signal = 0; # Handle continued commands (ending with \): $cmd =~ s/\\$/\n/ && do { $cmd .= &readline(" cont: "); redo CMD; }; =head4 The null command A newline entered by itself means I. We grab the command out of C<$laststep> (where it was recorded previously), and copy it back into C<$cmd> to be executed below. If there wasn't any previous command, we'll do nothing below (no command will match). If there was, we also save it in the command history and fall through to allow the command parsing to pick it up. =cut # Empty input means repeat the last command. $cmd =~ /^$/ && ( $cmd = $laststep ); chomp($cmd); # get rid of the annoying extra newline push( @hist, $cmd ) if length($cmd) > 1; push( @truehist, $cmd ); share(@hist); share(@truehist); # This is a restart point for commands that didn't arrive # via direct user input. It allows us to 'redo PIPE' to # re-execute command processing without reading a new command. PIPE: { $cmd =~ s/^\s+//s; # trim annoying leading whitespace $cmd =~ s/\s+$//s; # trim annoying trailing whitespace ($i) = split( /\s+/, $cmd ); =head3 COMMAND ALIASES The debugger can create aliases for commands (these are stored in the C<%alias> hash). Before a command is executed, the command loop looks it up in the alias hash and substitutes the contents of the alias for the command, completely replacing it. =cut # See if there's an alias for the command, and set it up if so. if ( $alias{$i} ) { # Squelch signal handling; we want to keep control here # if something goes loco during the alias eval. local $SIG{__DIE__}; local $SIG{__WARN__}; # This is a command, so we eval it in the DEBUGGER's # scope! Otherwise, we can't see the special debugger # variables, or get to the debugger's subs. (Well, we # _could_, but why make it even more complicated?) eval "\$cmd =~ $alias{$i}"; if ($@) { local $\ = ''; print $OUT "Couldn't evaluate `$i' alias: $@"; next CMD; } } ## end if ($alias{$i}) =head3 MAIN-LINE COMMANDS All of these commands work up to and after the program being debugged has terminated. =head4 C - quit Quit the debugger. This entails setting the C<$fall_off_end> flag, so we don't try to execute further, cleaning any restart-related stuff out of the environment, and executing with the last value of C<$?>. =cut $cmd =~ /^q$/ && do { $fall_off_end = 1; clean_ENV(); exit $?; }; =head4 C - trace Turn tracing on or off. Inverts the appropriate bit in C<$trace> (q.v.). =cut $cmd =~ /^t$/ && do { $trace ^= 1; local $\ = ''; print $OUT "Trace = " . ( ( $trace & 1 ) ? "on" : "off" ) . "\n"; next CMD; }; =head4 C - list subroutines matching/not matching a pattern Walks through C<%sub>, checking to see whether or not to print the name. =cut $cmd =~ /^S(\s+(!)?(.+))?$/ && do { $Srev = defined $2; # Reverse scan? $Spatt = $3; # The pattern (if any) to use. $Snocheck = !defined $1; # No args - print all subs. # Need to make these sane here. local $\ = ''; local $, = ''; # Search through the debugger's magical hash of subs. # If $nocheck is true, just print the sub name. # Otherwise, check it against the pattern. We then use # the XOR trick to reverse the condition as required. foreach $subname ( sort( keys %sub ) ) { if ( $Snocheck or $Srev ^ ( $subname =~ /$Spatt/ ) ) { print $OUT $subname, "\n"; } } next CMD; }; =head4 C - list variables in current package Since the C command actually processes this, just change this to the appropriate C command and fall through. =cut $cmd =~ s/^X\b/V $package/; =head4 C - list variables Uses C to dump out the current values for selected variables. =cut # Bare V commands get the currently-being-debugged package # added. $cmd =~ /^V$/ && do { $cmd = "V $package"; }; # V - show variables in package. $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do { # Save the currently selected filehandle and # force output to debugger's filehandle (dumpvar # just does "print" for output). local ($savout) = select($OUT); # Grab package name and variables to dump. $packname = $1; @vars = split( ' ', $2 ); # If main::dumpvar isn't here, get it. do 'dumpvar.pl' || die $@ unless defined &main::dumpvar; if ( defined &main::dumpvar ) { # We got it. Turn off subroutine entry/exit messages # for the moment, along with return values. local $frame = 0; local $doret = -2; # must detect sigpipe failures - not catching # then will cause the debugger to die. eval { &main::dumpvar( $packname, defined $option{dumpDepth} ? $option{dumpDepth} : -1, # assume -1 unless specified @vars ); }; # The die doesn't need to include the $@, because # it will automatically get propagated for us. if ($@) { die unless $@ =~ /dumpvar print failed/; } } ## end if (defined &main::dumpvar) else { # Couldn't load dumpvar. print $OUT "dumpvar.pl not available.\n"; } # Restore the output filehandle, and go round again. select($savout); next CMD; }; =head4 C - evaluate and print an expression Hands the expression off to C, setting it up to print the value via C instead of just printing it directly. =cut $cmd =~ s/^x\b/ / && do { # Remainder gets done by DB::eval() $onetimeDump = 'dump'; # main::dumpvar shows the output # handle special "x 3 blah" syntax XXX propagate # doc back to special variables. if ( $cmd =~ s/^\s*(\d+)(?=\s)/ / ) { $onetimedumpDepth = $1; } }; =head4 C - print methods Just uses C to determine what methods are available. =cut $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do { methods($1); next CMD; }; # m expr - set up DB::eval to do the work $cmd =~ s/^m\b/ / && do { # Rest gets done by DB::eval() $onetimeDump = 'methods'; # method output gets used there }; =head4 C - switch files =cut $cmd =~ /^f\b\s*(.*)/ && do { $file = $1; $file =~ s/\s+$//; # help for no arguments (old-style was return from sub). if ( !$file ) { print $OUT "The old f command is now the r command.\n"; # hint print $OUT "The new f command switches filenames.\n"; next CMD; } ## end if (!$file) # if not in magic file list, try a close match. if ( !defined $main::{ '_<' . $file } ) { if ( ($try) = grep( m#^_<.*$file#, keys %main:: ) ) { { $try = substr( $try, 2 ); print $OUT "Choosing $try matching `$file':\n"; $file = $try; } } ## end if (($try) = grep(m#^_<.*$file#... } ## end if (!defined $main::{ ... # If not successfully switched now, we failed. if ( !defined $main::{ '_<' . $file } ) { print $OUT "No file matching `$file' is loaded.\n"; next CMD; } # We switched, so switch the debugger internals around. elsif ( $file ne $filename ) { *dbline = $main::{ '_<' . $file }; $max = $#dbline; $filename = $file; $start = 1; $cmd = "l"; } ## end elsif ($file ne $filename) # We didn't switch; say we didn't. else { print $OUT "Already in $file.\n"; next CMD; } }; =head4 C<.> - return to last-executed line. We set C<$incr> to -1 to indicate that the debugger shouldn't move ahead, and then we look up the line in the magical C<%dbline> hash. =cut # . command. $cmd =~ /^\.$/ && do { $incr = -1; # stay at current line # Reset everything to the old location. $start = $line; $filename = $filename_ini; *dbline = $main::{ '_<' . $filename }; $max = $#dbline; # Now where are we? print_lineinfo($position); next CMD; }; =head4 C<-> - back one window We change C<$start> to be one window back; if we go back past the first line, we set it to be the first line. We ser C<$incr> to put us back at the currently-executing line, and then put a C (list one window from C<$start>) in C<$cmd> to be executed later. =cut # - - back a window. $cmd =~ /^-$/ && do { # back up by a window; go to 1 if back too far. $start -= $incr + $window + 1; $start = 1 if $start <= 0; $incr = $window - 1; # Generate and execute a "l +" command (handled below). $cmd = 'l ' . ($start) . '+'; }; =head3 PRE-580 COMMANDS VS. NEW COMMANDS: C, EE, {, {{> In Perl 5.8.0, a realignment of the commands was done to fix up a number of problems, most notably that the default case of several commands destroying the user's work in setting watchpoints, actions, etc. We wanted, however, to retain the old commands for those who were used to using them or who preferred them. At this point, we check for the new commands and call C to deal with them instead of processing them in-line. =cut # All of these commands were remapped in perl 5.8.0; # we send them off to the secondary dispatcher (see below). $cmd =~ /^([aAbBeEhilLMoOPvwW]\b|[<>\{]{1,2})\s*(.*)/so && do { &cmd_wrapper( $1, $2, $line ); next CMD; }; =head4 C - List lexicals in higher scope Uses C to find the lexicals supplied as arguments in a scope above the current one and then displays then using C. =cut $cmd =~ /^y(?:\s+(\d*)\s*(.*))?$/ && do { # See if we've got the necessary support. eval { require PadWalker; PadWalker->VERSION(0.08) } or &warn( $@ =~ /locate/ ? "PadWalker module not found - please install\n" : $@ ) and next CMD; # Load up dumpvar if we don't have it. If we can, that is. do 'dumpvar.pl' || die $@ unless defined &main::dumpvar; defined &main::dumpvar or print $OUT "dumpvar.pl not available.\n" and next CMD; # Got all the modules we need. Find them and print them. my @vars = split( ' ', $2 || '' ); # Find the pad. my $h = eval { PadWalker::peek_my( ( $1 || 0 ) + 1 ) }; # Oops. Can't find it. $@ and $@ =~ s/ at .*//, &warn($@), next CMD; # Show the desired vars with dumplex(). my $savout = select($OUT); # Have dumplex dump the lexicals. dumpvar::dumplex( $_, $h->{$_}, defined $option{dumpDepth} ? $option{dumpDepth} : -1, @vars ) for sort keys %$h; select($savout); next CMD; }; =head3 COMMANDS NOT WORKING AFTER PROGRAM ENDS All of the commands below this point don't work after the program being debugged has ended. All of them check to see if the program has ended; this allows the commands to be relocated without worrying about a 'line of demarcation' above which commands can be entered anytime, and below which they can't. =head4 C - single step, but don't trace down into subs Done by setting C<$single> to 2, which forces subs to execute straight through when entered (see C). We also save the C command in C<$laststep>, so a null command knows what to re-execute. =cut # n - next $cmd =~ /^n$/ && do { end_report(), next CMD if $finished and $level <= 1; # Single step, but don't enter subs. $single = 2; # Save for empty command (repeat last). $laststep = $cmd; last CMD; }; =head4 C - single-step, entering subs Sets C<$single> to 1, which causes C to continue tracing inside subs. Also saves C as C<$lastcmd>. =cut # s - single step. $cmd =~ /^s$/ && do { # Get out and restart the command loop if program # has finished. end_report(), next CMD if $finished and $level <= 1; # Single step should enter subs. $single = 1; # Save for empty command (repeat last). $laststep = $cmd; last CMD; }; =head4 C - run continuously, setting an optional breakpoint Most of the code for this command is taken up with locating the optional breakpoint, which is either a subroutine name or a line number. We set the appropriate one-time-break in C<@dbline> and then turn off single-stepping in this and all call levels above this one. =cut # c - start continuous execution. $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do { # Hey, show's over. The debugged program finished # executing already. end_report(), next CMD if $finished and $level <= 1; # Capture the place to put a one-time break. $subname = $i = $1; # Probably not needed, since we finish an interactive # sub-session anyway... # local $filename = $filename; # local *dbline = *dbline; # XXX Would this work?! # # The above question wonders if localizing the alias # to the magic array works or not. Since it's commented # out, we'll just leave that to speculation for now. # If the "subname" isn't all digits, we'll assume it # is a subroutine name, and try to find it. if ( $subname =~ /\D/ ) { # subroutine name # Qualify it to the current package unless it's # already qualified. $subname = $package . "::" . $subname unless $subname =~ /::/; # find_sub will return "file:line_number" corresponding # to where the subroutine is defined; we call find_sub, # break up the return value, and assign it in one # operation. ( $file, $i ) = ( find_sub($subname) =~ /^(.*):(.*)$/ ); # Force the line number to be numeric. $i += 0; # If we got a line number, we found the sub. if ($i) { # Switch all the debugger's internals around so # we're actually working with that file. $filename = $file; *dbline = $main::{ '_<' . $filename }; # Mark that there's a breakpoint in this file. $had_breakpoints{$filename} |= 1; # Scan forward to the first executable line # after the 'sub whatever' line. $max = $#dbline; ++$i while $dbline[$i] == 0 && $i < $max; } ## end if ($i) # We didn't find a sub by that name. else { print $OUT "Subroutine $subname not found.\n"; next CMD; } } ## end if ($subname =~ /\D/) # At this point, either the subname was all digits (an # absolute line-break request) or we've scanned through # the code following the definition of the sub, looking # for an executable, which we may or may not have found. # # If $i (which we set $subname from) is non-zero, we # got a request to break at some line somewhere. On # one hand, if there wasn't any real subroutine name # involved, this will be a request to break in the current # file at the specified line, so we have to check to make # sure that the line specified really is breakable. # # On the other hand, if there was a subname supplied, the # preceding block has moved us to the proper file and # location within that file, and then scanned forward # looking for the next executable line. We have to make # sure that one was found. # # On the gripping hand, we can't do anything unless the # current value of $i points to a valid breakable line. # Check that. if ($i) { # Breakable? if ( $dbline[$i] == 0 ) { print $OUT "Line $i not breakable.\n"; next CMD; } # Yes. Set up the one-time-break sigil. $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p. } ## end if ($i) # Turn off stack tracing from here up. for ( $i = 0 ; $i <= $stack_depth ; ) { $stack[ $i++ ] &= ~1; } last CMD; }; =head4 C - return from a subroutine For C to work properly, the debugger has to stop execution again immediately after the return is executed. This is done by forcing single-stepping to be on in the call level above the current one. If we are printing return values when a C is executed, set C<$doret> appropriately, and force us out of the command loop. =cut # r - return from the current subroutine. $cmd =~ /^r$/ && do { # Can't do anythign if the program's over. end_report(), next CMD if $finished and $level <= 1; # Turn on stack trace. $stack[$stack_depth] |= 1; # Print return value unless the stack is empty. $doret = $option{PrintRet} ? $stack_depth - 1 : -2; last CMD; }; =head4 C - stack trace Just calls C. =cut $cmd =~ /^T$/ && do { print_trace( $OUT, 1 ); # skip DB next CMD; }; =head4 C - List window around current line. Just calls C. =cut $cmd =~ /^w\b\s*(.*)/s && do { &cmd_w( 'w', $1 ); next CMD; }; =head4 C - watch-expression processing. Just calls C. =cut $cmd =~ /^W\b\s*(.*)/s && do { &cmd_W( 'W', $1 ); next CMD; }; =head4 C - search forward for a string in the source We take the argument and treat it as a pattern. If it turns out to be a bad one, we return the error we got from trying to C it and exit. If not, we create some code to do the search and C it so it can't mess us up. =cut $cmd =~ /^\/(.*)$/ && do { # The pattern as a string. $inpat = $1; # Remove the final slash. $inpat =~ s:([^\\])/$:$1:; # If the pattern isn't null ... if ( $inpat ne "" ) { # Turn of warn and die procesing for a bit. local $SIG{__DIE__}; local $SIG{__WARN__}; # Create the pattern. eval '$inpat =~ m' . "\a$inpat\a"; if ( $@ ne "" ) { # Oops. Bad pattern. No biscuit. # Print the eval error and go back for more # commands. print $OUT "$@"; next CMD; } $pat = $inpat; } ## end if ($inpat ne "") # Set up to stop on wrap-around. $end = $start; # Don't move off the current line. $incr = -1; # Done in eval so nothing breaks if the pattern # does something weird. eval ' for (;;) { # Move ahead one line. ++$start; # Wrap if we pass the last line. $start = 1 if ($start > $max); # Stop if we have gotten back to this line again, last if ($start == $end); # A hit! (Note, though, that we are doing # case-insensitive matching. Maybe a qr// # expression would be better, so the user could # do case-sensitive matching if desired. if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) { if ($slave_editor) { # Handle proper escaping in the slave. print $OUT "\032\032$filename:$start:0\n"; } else { # Just print the line normally. print $OUT "$start:\t",$dbline[$start],"\n"; } # And quit since we found something. last; } } '; # If we wrapped, there never was a match. print $OUT "/$pat/: not found\n" if ( $start == $end ); next CMD; }; =head4 C - search backward for a string in the source Same as for C, except the loop runs backwards. =cut # ? - backward pattern search. $cmd =~ /^\?(.*)$/ && do { # Get the pattern, remove trailing question mark. $inpat = $1; $inpat =~ s:([^\\])\?$:$1:; # If we've got one ... if ( $inpat ne "" ) { # Turn off die & warn handlers. local $SIG{__DIE__}; local $SIG{__WARN__}; eval '$inpat =~ m' . "\a$inpat\a"; if ( $@ ne "" ) { # Ouch. Not good. Print the error. print $OUT $@; next CMD; } $pat = $inpat; } ## end if ($inpat ne "") # Where we are now is where to stop after wraparound. $end = $start; # Don't move away from this line. $incr = -1; # Search inside the eval to prevent pattern badness # from killing us. eval ' for (;;) { # Back up a line. --$start; # Wrap if we pass the first line. $start = $max if ($start <= 0); # Quit if we get back where we started, last if ($start == $end); # Match? if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) { if ($slave_editor) { # Yep, follow slave editor requirements. print $OUT "\032\032$filename:$start:0\n"; } else { # Yep, just print normally. print $OUT "$start:\t",$dbline[$start],"\n"; } # Found, so done. last; } } '; # Say we failed if the loop never found anything, print $OUT "?$pat?: not found\n" if ( $start == $end ); next CMD; }; =head4 C<$rc> - Recall command Manages the commands in C<@hist> (which is created if C reports that the terminal supports history). It find the the command required, puts it into C<$cmd>, and redoes the loop to execute it. =cut # $rc - recall command. $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do { # No arguments, take one thing off history. pop(@hist) if length($cmd) > 1; # Relative (- found)? # Y - index back from most recent (by 1 if bare minus) # N - go to that particular command slot or the last # thing if nothing following. $i = $1 ? ( $#hist - ( $2 || 1 ) ) : ( $2 || $#hist ); # Pick out the command desired. $cmd = $hist[$i]; # Print the command to be executed and restart the loop # with that command in the buffer. print $OUT $cmd, "\n"; redo CMD; }; =head4 C<$sh$sh> - C command Calls the C to handle the command. This keeps the C and C from getting messed up. =cut # $sh$sh - run a shell command (if it's all ASCII). # Can't run shell commands with Unicode in the debugger, hmm. $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do { # System it. &system($1); next CMD; }; =head4 C<$rc I $rc> - Search command history Another command to manipulate C<@hist>: this one searches it with a pattern. If a command is found, it is placed in C<$cmd> and executed via C. =cut # $rc pattern $rc - find a command in the history. $cmd =~ /^$rc([^$rc].*)$/ && do { # Create the pattern to use. $pat = "^$1"; # Toss off last entry if length is >1 (and it always is). pop(@hist) if length($cmd) > 1; # Look backward through the history. for ( $i = $#hist ; $i ; --$i ) { # Stop if we find it. last if $hist[$i] =~ /$pat/; } if ( !$i ) { # Never found it. print $OUT "No such command!\n\n"; next CMD; } # Found it. Put it in the buffer, print it, and process it. $cmd = $hist[$i]; print $OUT $cmd, "\n"; redo CMD; }; =head4 C<$sh> - Invoke a shell Uses C to invoke a shell. =cut # $sh - start a shell. $cmd =~ /^$sh$/ && do { # Run the user's shell. If none defined, run Bourne. # We resume execution when the shell terminates. &system( $ENV{SHELL} || "/bin/sh" ); next CMD; }; =head4 C<$sh I> - Force execution of a command in a shell Like the above, but the command is passed to the shell. Again, we use C to avoid problems with C and C. =cut # $sh command - start a shell and run a command in it. $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do { # XXX: using csh or tcsh destroys sigint retvals! #&system($1); # use this instead # use the user's shell, or Bourne if none defined. &system( $ENV{SHELL} || "/bin/sh", "-c", $1 ); next CMD; }; =head4 C - display commands in history Prints the contents of C<@hist> (if any). =cut $cmd =~ /^H\b\s*\*/ && do { @hist = @truehist = (); print $OUT "History cleansed\n"; next CMD; }; $cmd =~ /^H\b\s*(-(\d+))?/ && do { # Anything other than negative numbers is ignored by # the (incorrect) pattern, so this test does nothing. $end = $2 ? ( $#hist - $2 ) : 0; # Set to the minimum if less than zero. $hist = 0 if $hist < 0; # Start at the end of the array. # Stay in while we're still above the ending value. # Tick back by one each time around the loop. for ( $i = $#hist ; $i > $end ; $i-- ) { # Print the command unless it has no arguments. print $OUT "$i: ", $hist[$i], "\n" unless $hist[$i] =~ /^.?$/; } next CMD; }; =head4 C - look up documentation Just calls C to print the appropriate document. =cut # man, perldoc, doc - show manual pages. $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do { runman($1); next CMD; }; =head4 C

I Same as \"I\" in current package. B<|>I Run debugger command, piping DB::OUT to current pager. B<||>I Same as B<|>I but DB::OUT is temporarilly select()ed as well. B<\=> [I I] Define a command alias, or list current aliases. I Execute as a perl statement in current package. B Pure-man-restart of debugger, some of debugger state and command-line options may be lost. Currently the following settings are preserved: history, breakpoints and actions, debugger Bptions and the following command-line options: I<-w>, I<-I>, I<-e>. B [I] ... Set boolean option to true B [IB] Query options B [IB<=>I] [I=B<\">IB<\">] ... Set options. Use quotes if spaces in value. I, I chars used to recall command or spawn shell; I program for output of \"|cmd\"; I run Tk while prompting (with ReadLine); I I I level of verbosity; I Allows stepping off the end of the script. I Debugger should stop as early as possible. I Remote hostname:port for remote debugging The following options affect what happens with B, B, and B commands: I, I print only first N elements ('' for all); I, I change style of array and hash dump; I whether to print contents of globs; I dump arrays holding debugged files; I dump symbol tables of packages; I dump contents of \"reused\" addresses; I, I, I change style of string dump; I Do not print the overload-stringified value; Other options include: I affects printing of return value after B command, I affects printing messages on subroutine entry/exit. I affects printing messages on possible breaking points. I gives max length of evals/args listed in stack trace. I affects screen appearance of the command line. I bits control attempts to create a new TTY on events: 1: on fork() 2: debugger is started inside debugger 4: on startup During startup options are initialized from \$ENV{PERLDB_OPTS}. You can put additional initialization options I, I, I, I, and I there (or use `B' after you set them). B or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction. B Summary of debugger commands. B [I] Get help [on a specific debugger command], enter B<|h> to page. B Long help for debugger commands B<$doccmd> I Runs the external doc viewer B<$doccmd> command on the named Perl I, or on B<$doccmd> itself if omitted. Set B<\$DB::doccmd> to change viewer. Type `|h h' for a paged display if this was too hard to read. "; # Fix balance of vi % matching: }}}} # note: tabs in the following section are not-so-helpful $summary = <<"END_SUM"; I I B [I|I] List source code B Stack trace B<-> or B<.> List previous/current line B [I] Single step [in expr] B [I] View around line B [I] Next, steps over subs B I View source in file /B> Repeat last B or B BIB BIB Search forw/backw B Return from subroutine B Show module versions B [I|I] Continue until position I B List break/watch/actions B [...] Set debugger options B [I] Toggle trace [trace expr] B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I] Do pre/post-prompt B [I|I|I] [I] Set breakpoint B<$prc> [I|I] Redo a previous command B I Delete a/all breakpoints B [I<-num>] Display last num commands B [I] I Do cmd before line B<=> [I I] Define/list an alias B I Delete a/all actions B [I] Get help on command B I Add a watch expression B Complete help page B I Delete a/all watch exprs B<|>[B<|>]I Send output to pager B<$psh>\[B<$psh>\] I Run cmd in a subprocess B or B<^D> Quit B Attempt a restart I B Execute perl code, also see: B,B,B I B|B I Evals expr in list context, dumps the result or lists methods. B

I Print expression (uses script's current package). B [[B]I] List subroutine names [not] matching pattern B [I [I]] List Variables in Package. Vars can be ~pattern or !pattern. B [I] Same as \"B I [I]\". B I inheritance tree. B [I [I]] List lexicals in higher scope . Vars same as B. B Display thread id B Display all thread ids. For more help, type B I, or run B<$doccmd perldebug> for all docs. END_SUM # ')}}; # Fix balance of vi % matching # and this is really numb... $pre580_help = " B Stack trace. B [I] Single step [in I]. B [I] Next, steps over subroutine calls [in I]. B> Repeat last B or B command. B Return from current subroutine. B [I|I] Continue; optionally inserts a one-time-only breakpoint at the specified position. B IB<+>I List I+1 lines starting at I. B IB<->I List lines I through I. B I List single I. B I List first window of lines from subroutine. B I<\$var> List first window of lines from subroutine referenced by I<\$var>. B List next window of lines. B<-> List previous window of lines. B [I] List window around I. B<.> Return to the executed line. B I Switch to viewing I. File must be already loaded. I may be either the full name of the file, or a regular expression matching the full file name: B I and B I may access the same file. Evals (with saved bodies) are considered to be filenames: B I<(eval 7)> and B I access the body of the 7th eval (in the order of execution). BIB Search forwards for I; final B is optional. BIB Search backwards for I; final B is optional. B List all breakpoints and actions. B [[B]I] List subroutine names [not] matching I. B Toggle trace mode. B I Trace through execution of I. B [I] [I] Set breakpoint; I defaults to the current execution line; I breaks if it evaluates to true, defaults to '1'. B I [I] Set breakpoint at first line of subroutine. B I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>. B B I Set breakpoint on `require'ing the given file. B B I [I] Set breakpoint at first line of subroutine after it is compiled. B B I Stop after the subroutine is compiled. B [I] Delete the breakpoint for I. B Delete all breakpoints. B [I] I Set an action to be done before the I is executed; I defaults to the current execution line. Sequence is: check for breakpoint/watchpoint, print line if necessary, do action, prompt user if necessary, execute line. B [I] Delete the action for I. B Delete all actions. B I Add a global watch-expression. B Delete all watch-expressions. B [I [I]] List some (default all) variables in package (default current). Use B<~>I and BI for positive and negative regexps. B [I] Same as \"B I [I]\". B I Evals expression in list context, dumps the result. B I Evals expression in list context, prints methods callable on the first element of the result. B I Prints methods callable via the given class. B<<> ? List Perl commands to run before each prompt. B<<> I Define Perl command to run before each prompt. B<<<> I Add to the list of Perl commands to run before each prompt. B<>> ? List Perl commands to run after each prompt. B<>> I Define Perl command to run after each prompt. B<>>B<>> I Add to the list of Perl commands to run after each prompt. B<{> I Define debugger command to run before each prompt. B<{> ? List debugger commands to run before each prompt. B<{{> I Add to the list of debugger commands to run before each prompt. B<$prc> I Redo a previous command (default previous command). B<$prc> I<-number> Redo number'th-to-last command. B<$prc> I Redo last command that started with I. See 'B I' too. B<$psh$psh> I Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)" . ( $rc eq $sh ? "" : " B<$psh> [I] Run I in subshell (forces \"\$SHELL -c 'cmd'\")." ) . " See 'B I' too. B I Execute I containing debugger commands (may nest). B I<-number> Display last number commands (default all). B

I Same as \"I\" in current package. B<|>I Run debugger command, piping DB::OUT to current pager. B<||>I Same as B<|>I but DB::OUT is temporarilly select()ed as well. B<\=> [I I] Define a command alias, or list current aliases. I Execute as a perl statement in current package. B Show versions of loaded modules. B Pure-man-restart of debugger, some of debugger state and command-line options may be lost. Currently the following settings are preserved: history, breakpoints and actions, debugger Bptions and the following command-line options: I<-w>, I<-I>, I<-e>. B [I] ... Set boolean option to true B [IB] Query options B [IB<=>I] [I=B<\">IB<\">] ... Set options. Use quotes if spaces in value. I, I chars used to recall command or spawn shell; I program for output of \"|cmd\"; I run Tk while prompting (with ReadLine); I I I level of verbosity; I Allows stepping off the end of the script. I Debugger should stop as early as possible. I Remote hostname:port for remote debugging The following options affect what happens with B, B, and B commands: I, I print only first N elements ('' for all); I, I change style of array and hash dump; I whether to print contents of globs; I dump arrays holding debugged files; I dump symbol tables of packages; I dump contents of \"reused\" addresses; I, I, I change style of string dump; I Do not print the overload-stringified value; Other options include: I affects printing of return value after B command, I affects printing messages on subroutine entry/exit. I affects printing messages on possible breaking points. I gives max length of evals/args listed in stack trace. I affects screen appearance of the command line. I bits control attempts to create a new TTY on events: 1: on fork() 2: debugger is started inside debugger 4: on startup During startup options are initialized from \$ENV{PERLDB_OPTS}. You can put additional initialization options I, I, I, I, and I there (or use `B' after you set them). B or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction. B [I] Get help [on a specific debugger command], enter B<|h> to page. B Summary of debugger commands. B<$doccmd> I Runs the external doc viewer B<$doccmd> command on the named Perl I, or on B<$doccmd> itself if omitted. Set B<\$DB::doccmd> to change viewer. Type `|h' for a paged display if this was too hard to read. "; # Fix balance of vi % matching: }}}} # note: tabs in the following section are not-so-helpful $pre580_summary = <<"END_SUM"; I I B [I|I] List source code B Stack trace B<-> or B<.> List previous/current line B [I] Single step [in expr] B [I] List around line B [I] Next, steps over subs B I View source in file /B> Repeat last B or B BIB BIB Search forw/backw B Return from subroutine B Show versions of modules B [I|I] Continue until position I B List break/watch/actions B [...] Set debugger options B [I] Toggle trace [trace expr] B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I] Do pre/post-prompt B [I|I|I] [I] Set breakpoint B<$prc> [I|I] Redo a previous command B [I] or B Delete a/all breakpoints B [I<-num>] Display last num commands B [I] I Do cmd before line B<=> [I I] Define/list an alias B I Add a watch expression B [I] Get help on command B or B Delete all actions/watch B<|>[B<|>]I Send output to pager B<$psh>\[B<$psh>\] I Run cmd in a subprocess B or B<^D> Quit B Attempt a restart I B Execute perl code, also see: B,B,B I B|B I Evals expr in list context, dumps the result or lists methods. B

I Print expression (uses script's current package). B [[B]I] List subroutine names [not] matching pattern B [I [I]] List Variables in Package. Vars can be ~pattern or !pattern. B [I] Same as \"B I [I]\". B [I [I]] List lexicals in higher scope . Vars same as B. For more help, type B I, or run B<$doccmd perldebug> for all docs. END_SUM # ')}}; # Fix balance of vi % matching } ## end sub sethelp =head2 C Most of what C does is just text formatting. It finds the C and C ornaments, cleans them off, and substitutes the proper terminal control characters to simulate them (courtesy of C). =cut sub print_help { local $_ = shift; # Restore proper alignment destroyed by eeevil I<> and B<> # ornaments: A pox on both their houses! # # A help command will have everything up to and including # the first tab sequence padded into a field 16 (or if indented 20) # wide. If it's wider than that, an extra space will be added. s{ ^ # only matters at start of line ( \040{4} | \t )* # some subcommands are indented ( < ? # so works [BI] < [^\t\n] + ) # find an eeevil ornament ( \t+ ) # original separation, discarded ( .* ) # this will now start (no earlier) than # column 16 } { my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4); my $clean = $command; $clean =~ s/[BI]<([^>]*)>/$1/g; # replace with this whole string: ($leadwhite ? " " x 4 : "") . $command . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ") . $text; }mgex; s{ # handle bold ornaments B < ( [^>] + | > ) > } { $Term::ReadLine::TermCap::rl_term_set[2] . $1 . $Term::ReadLine::TermCap::rl_term_set[3] }gex; s{ # handle italic ornaments I < ( [^>] + | > ) > } { $Term::ReadLine::TermCap::rl_term_set[0] . $1 . $Term::ReadLine::TermCap::rl_term_set[1] }gex; local $\ = ''; print $OUT $_; } ## end sub print_help =head2 C This routine does a lot of gyrations to be sure that the pager is C. It checks for C masquerading as C and records the result in C<$ENV{LESS}> so we don't have to go through doing the stats again. =cut sub fix_less { # We already know if this is set. return if defined $ENV{LESS} && $ENV{LESS} =~ /r/; # Pager is less for sure. my $is_less = $pager =~ /\bless\b/; if ( $pager =~ /\bmore\b/ ) { # Nope, set to more. See what's out there. my @st_more = stat('/usr/bin/more'); my @st_less = stat('/usr/bin/less'); # is it really less, pretending to be more? $is_less = @st_more && @st_less && $st_more[0] == $st_less[0] && $st_more[1] == $st_less[1]; } ## end if ($pager =~ /\bmore\b/) # changes environment! # 'r' added so we don't do (slow) stats again. $ENV{LESS} .= 'r' if $is_less; } ## end sub fix_less =head1 DIE AND WARN MANAGEMENT =head2 C C is a just-drop-dead C handler. It's most useful when trying to debug a debugger problem. It does its best to report the error that occurred, and then forces the program, debugger, and everything to die. =cut sub diesignal { # No entry/exit messages. local $frame = 0; # No return value prints. local $doret = -2; # set the abort signal handling to the default (just terminate). $SIG{'ABRT'} = 'DEFAULT'; # If we enter the signal handler recursively, kill myself with an # abort signal (so we just terminate). kill 'ABRT', $$ if $panic++; # If we can show detailed info, do so. if ( defined &Carp::longmess ) { # Don't recursively enter the warn handler, since we're carping. local $SIG{__WARN__} = ''; # Skip two levels before reporting traceback: we're skipping # mydie and confess. local $Carp::CarpLevel = 2; # mydie + confess # Tell us all about it. &warn( Carp::longmess("Signal @_") ); } # No Carp. Tell us about the signal as best we can. else { local $\ = ''; print $DB::OUT "Got signal @_\n"; } # Drop dead. kill 'ABRT', $$; } ## end sub diesignal =head2 C The debugger's own default C<$SIG{__WARN__}> handler. We load C to be able to get a stack trace, and output the warning message vi C. =cut sub dbwarn { # No entry/exit trace. local $frame = 0; # No return value printing. local $doret = -2; # Turn off warn and die handling to prevent recursive entries to this # routine. local $SIG{__WARN__} = ''; local $SIG{__DIE__} = ''; # Load Carp if we can. If $^S is false (current thing being compiled isn't # done yet), we may not be able to do a require. eval { require Carp } if defined $^S; # If error/warning during compilation, # require may be broken. # Use the core warn() unless Carp loaded OK. CORE::warn( @_, "\nCannot print stack trace, load with -MCarp option to see stack" ), return unless defined &Carp::longmess; # Save the current values of $single and $trace, and then turn them off. my ( $mysingle, $mytrace ) = ( $single, $trace ); $single = 0; $trace = 0; # We can call Carp::longmess without its being "debugged" (which we # don't want - we just want to use it!). Capture this for later. my $mess = Carp::longmess(@_); # Restore $single and $trace to their original values. ( $single, $trace ) = ( $mysingle, $mytrace ); # Use the debugger's own special way of printing warnings to print # the stack trace message. &warn($mess); } ## end sub dbwarn =head2 C The debugger's own C<$SIG{__DIE__}> handler. Handles providing a stack trace by loading C and calling C to get it. We turn off single stepping and tracing during the call to C to avoid debugging it - we just want to use it. If C is zero, we let the program being debugged handle the exceptions. If it's 1, you get backtraces for any exception. If it's 2, the debugger takes over all exception handling, printing a backtrace and displaying the exception via its C routine. =cut sub dbdie { local $frame = 0; local $doret = -2; local $SIG{__DIE__} = ''; local $SIG{__WARN__} = ''; my $i = 0; my $ineval = 0; my $sub; if ( $dieLevel > 2 ) { local $SIG{__WARN__} = \&dbwarn; &warn(@_); # Yell no matter what return; } if ( $dieLevel < 2 ) { die @_ if $^S; # in eval propagate } # The code used to check $^S to see if compiliation of the current thing # hadn't finished. We don't do it anymore, figuring eval is pretty stable. eval { require Carp }; die( @_, "\nCannot print stack trace, load with -MCarp option to see stack" ) unless defined &Carp::longmess; # We do not want to debug this chunk (automatic disabling works # inside DB::DB, but not in Carp). Save $single and $trace, turn them off, # get the stack trace from Carp::longmess (if possible), restore $signal # and $trace, and then die with the stack trace. my ( $mysingle, $mytrace ) = ( $single, $trace ); $single = 0; $trace = 0; my $mess = "@_"; { package Carp; # Do not include us in the list eval { $mess = Carp::longmess(@_); }; } ( $single, $trace ) = ( $mysingle, $mytrace ); die $mess; } ## end sub dbdie =head2 C Set the C<$DB::warnLevel> variable that stores the value of the C option. Calling C with a positive value results in the debugger taking over all warning handlers. Setting C to zero leaves any warning handlers set up by the program being debugged in place. =cut sub warnLevel { if (@_) { $prevwarn = $SIG{__WARN__} unless $warnLevel; $warnLevel = shift; if ($warnLevel) { $SIG{__WARN__} = \&DB::dbwarn; } elsif ($prevwarn) { $SIG{__WARN__} = $prevwarn; } else { undef $SIG{__WARN__}; } } ## end if (@_) $warnLevel; } ## end sub warnLevel =head2 C Similar to C. Non-zero values for C result in the C function overriding any other C handler. Setting it to zero lets you use your own C handler. =cut sub dieLevel { local $\ = ''; if (@_) { $prevdie = $SIG{__DIE__} unless $dieLevel; $dieLevel = shift; if ($dieLevel) { # Always set it to dbdie() for non-zero values. $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2; # No longer exists, so don't try to use it. #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2; # If we've finished initialization, mention that stack dumps # are enabled, If dieLevel is 1, we won't stack dump if we die # in an eval(). print $OUT "Stack dump during die enabled", ( $dieLevel == 1 ? " outside of evals" : "" ), ".\n" if $I_m_init; # XXX This is probably obsolete, given that diehard() is gone. print $OUT "Dump printed too.\n" if $dieLevel > 2; } ## end if ($dieLevel) # Put the old one back if there was one. elsif ($prevdie) { $SIG{__DIE__} = $prevdie; print $OUT "Default die handler restored.\n"; } else { undef $SIG{__DIE__}; print $OUT "Die handler removed.\n"; } } ## end if (@_) $dieLevel; } ## end sub dieLevel =head2 C Number three in a series: set C to zero to keep your own signal handler for C and/or C. Otherwise, the debugger takes over and handles them with C. =cut sub signalLevel { if (@_) { $prevsegv = $SIG{SEGV} unless $signalLevel; $prevbus = $SIG{BUS} unless $signalLevel; $signalLevel = shift; if ($signalLevel) { $SIG{SEGV} = \&DB::diesignal; $SIG{BUS} = \&DB::diesignal; } else { $SIG{SEGV} = $prevsegv; $SIG{BUS} = $prevbus; } } ## end if (@_) $signalLevel; } ## end sub signalLevel =head1 SUBROUTINE DECODING SUPPORT These subroutines are used during the C and C commands to try to produce as much information as possible about a code reference. They use L to try to find the glob in which this code reference lives (if it does) - this allows us to actually code references which correspond to named subroutines (including those aliased via glob assignment). =head2 C Wrapper for C; tries to get the name of a reference via that routine. If this fails, return the reference again (when the reference is stringified, it'll come out as C). =cut sub CvGV_name { my $in = shift; my $name = CvGV_name_or_bust($in); defined $name ? $name : $in; } =head2 C I Calls L to try to find the glob the ref lives in; returns C if L can't be loaded, or if C can't find a glob for this ref. Returns C<< I::I >> if the code ref is found in a glob. =cut sub CvGV_name_or_bust { my $in = shift; return if $skipCvGV; # Backdoor to avoid problems if XS broken... return unless ref $in; $in = \&$in; # Hard reference... eval { require Devel::Peek; 1 } or return; my $gv = Devel::Peek::CvGV($in) or return; *$gv{PACKAGE} . '::' . *$gv{NAME}; } ## end sub CvGV_name_or_bust =head2 C A utility routine used in various places; finds the file where a subroutine was defined, and returns that filename and a line-number range. Tries to use C<@sub> first; if it can't find it there, it tries building a reference to the subroutine and uses C to locate it, loading it into C<@sub> as a side effect (XXX I think). If it can't find it this way, it brute-force searches C<%sub>, checking for identical references. =cut sub find_sub { my $subr = shift; $sub{$subr} or do { return unless defined &$subr; my $name = CvGV_name_or_bust($subr); my $data; $data = $sub{$name} if defined $name; return $data if defined $data; # Old stupid way... $subr = \&$subr; # Hard reference my $s; for ( keys %sub ) { $s = $_, last if $subr eq \&$_; } $sub{$s} if $s; } ## end do } ## end sub find_sub =head2 C A subroutine that uses the utility function C to find all the methods in the class corresponding to the current reference and in C. =cut sub methods { # Figure out the class - either this is the class or it's a reference # to something blessed into that class. my $class = shift; $class = ref $class if ref $class; local %seen; # Show the methods that this class has. methods_via( $class, '', 1 ); # Show the methods that UNIVERSAL has. methods_via( 'UNIVERSAL', 'UNIVERSAL', 0 ); } ## end sub methods =head2 C C does the work of crawling up the C<@ISA> tree and reporting all the parent class methods. C<$class> is the name of the next class to try; C<$prefix> is the message prefix, which gets built up as we go up the C<@ISA> tree to show parentage; C<$crawl_upward> is 1 if we should try to go higher in the C<@ISA> tree, 0 if we should stop. =cut sub methods_via { # If we've processed this class already, just quit. my $class = shift; return if $seen{$class}++; # This is a package that is contributing the methods we're about to print. my $prefix = shift; my $prepend = $prefix ? "via $prefix: " : ''; my @to_print; # Extract from all the symbols in this class. while (my ($name, $glob) = each %{"${class}::"}) { # references directly in the symbol table are Proxy Constant # Subroutines, and are by their very nature defined # Otherwise, check if the thing is a typeglob, and if it is, it decays # to a subroutine reference, which can be tested by defined. # $glob might also be the value -1 (from sub foo;) # or (say) '$$' (from sub foo ($$);) # \$glob will be SCALAR in both cases. if ((ref $glob || ($glob && ref \$glob eq 'GLOB' && defined &$glob)) && !$seen{$name}++) { push @to_print, "$prepend$name\n"; } } { local $\ = ''; local $, = ''; print $DB::OUT $_ foreach sort @to_print; } # If the $crawl_upward argument is false, just quit here. return unless shift; # $crawl_upward true: keep going up the tree. # Find all the classes this one is a subclass of. for $name ( @{"${class}::ISA"} ) { # Set up the new prefix. $prepend = $prefix ? $prefix . " -> $name" : $name; # Crawl up the tree and keep trying to crawl up. methods_via( $name, $prepend, 1 ); } } ## end sub methods_via =head2 C - figure out which command to use to show documentation Just checks the contents of C<$^O> and sets the C<$doccmd> global accordingly. =cut sub setman { $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s ? "man" # O Happy Day! : "perldoc"; # Alas, poor unfortunates } ## end sub setman =head2 C - run the appropriate command to show documentation Accepts a man page name; runs the appropriate command to display it (set up during debugger initialization). Uses C to avoid mucking up the program's STDIN and STDOUT. =cut sub runman { my $page = shift; unless ($page) { &system("$doccmd $doccmd"); return; } # this way user can override, like with $doccmd="man -Mwhatever" # or even just "man " to disable the path check. unless ( $doccmd eq 'man' ) { &system("$doccmd $page"); return; } $page = 'perl' if lc($page) eq 'help'; require Config; my $man1dir = $Config::Config{'man1dir'}; my $man3dir = $Config::Config{'man3dir'}; for ( $man1dir, $man3dir ) { s#/[^/]*\z## if /\S/ } my $manpath = ''; $manpath .= "$man1dir:" if $man1dir =~ /\S/; $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir; chop $manpath if $manpath; # harmless if missing, I figure my $oldpath = $ENV{MANPATH}; $ENV{MANPATH} = $manpath if $manpath; my $nopathopt = $^O =~ /dunno what goes here/; if ( CORE::system( $doccmd, # I just *know* there are men without -M ( ( $manpath && !$nopathopt ) ? ( "-M", $manpath ) : () ), split ' ', $page ) ) { unless ( $page =~ /^perl\w/ ) { # do it this way because its easier to slurp in to keep up to date - clunky though. my @pods = qw( 5004delta 5005delta 561delta 56delta 570delta 571delta 572delta 573delta 58delta 581delta 582delta 583delta 584delta 590delta 591delta 592delta aix amiga apio api apollo artistic beos book boot bot bs2000 call ce cheat clib cn compile cygwin data dbmfilter debguts debtut debug delta dgux diag doc dos dsc ebcdic embed epoc faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 faq filter fork form freebsd func gpl guts hack hist hpux hurd intern intro iol ipc irix jp ko lexwarn locale lol machten macos macosx mint modinstall modlib mod modstyle mpeix netware newmod number obj opentut op os2 os390 os400 othrtut packtut plan9 pod podspec port qnx ref reftut re requick reref retut run sec solaris style sub syn thrtut tie toc todo tooc toot trap tru64 tw unicode uniintro util uts var vmesa vms vos win32 xs xstut ); if (grep { $page eq $_ } @pods) { $page =~ s/^/perl/; CORE::system( $doccmd, ( ( $manpath && !$nopathopt ) ? ( "-M", $manpath ) : () ), $page ); } ## end if (grep { $page eq $_... } ## end unless ($page =~ /^perl\w/) } ## end if (CORE::system($doccmd... if ( defined $oldpath ) { $ENV{MANPATH} = $manpath; } else { delete $ENV{MANPATH}; } } ## end sub runman #use Carp; # This did break, left for debugging =head1 DEBUGGER INITIALIZATION - THE SECOND BEGIN BLOCK Because of the way the debugger interface to the Perl core is designed, any debugger package globals that C requires have to be defined before any subroutines can be called. These are defined in the second C block. This block sets things up so that (basically) the world is sane before the debugger starts executing. We set up various variables that the debugger has to have set up before the Perl core starts running: =over 4 =item * The debugger's own filehandles (copies of STD and STDOUT for now). =item * Characters for shell escapes, the recall command, and the history command. =item * The maximum recursion depth. =item * The size of a C command's window. =item * The before-this-line context to be printed in a C (view a window around this line) command. =item * The fact that we're not in a sub at all right now. =item * The default SIGINT handler for the debugger. =item * The appropriate value of the flag in C<$^D> that says the debugger is running =item * The current debugger recursion level =item * The list of postponed items and the C<$single> stack (XXX define this) =item * That we want no return values and no subroutine entry/exit trace. =back =cut # The following BEGIN is very handy if debugger goes havoc, debugging debugger? BEGIN { # This does not compile, alas. (XXX eh?) $IN = \*STDIN; # For bugs before DB::OUT has been opened $OUT = \*STDERR; # For errors before DB::OUT has been opened # Define characters used by command parsing. $sh = '!'; # Shell escape (does not work) $rc = ','; # Recall command (does not work) @hist = ('?'); # Show history (does not work) @truehist = (); # Can be saved for replay (per session) # This defines the point at which you get the 'deep recursion' # warning. It MUST be defined or the debugger will not load. $deep = 100; # Number of lines around the current one that are shown in the # 'w' command. $window = 10; # How much before-the-current-line context the 'v' command should # use in calculating the start of the window it will display. $preview = 3; # We're not in any sub yet, but we need this to be a defined value. $sub = ''; # Set up the debugger's interrupt handler. It simply sets a flag # ($signal) that DB::DB() will check before each command is executed. $SIG{INT} = \&DB::catch; # The following lines supposedly, if uncommented, allow the debugger to # debug itself. Perhaps we can try that someday. # This may be enabled to debug debugger: #$warnLevel = 1 unless defined $warnLevel; #$dieLevel = 1 unless defined $dieLevel; #$signalLevel = 1 unless defined $signalLevel; # This is the flag that says "a debugger is running, please call # DB::DB and DB::sub". We will turn it on forcibly before we try to # execute anything in the user's context, because we always want to # get control back. $db_stop = 0; # Compiler warning ... $db_stop = 1 << 30; # ... because this is only used in an eval() later. # This variable records how many levels we're nested in debugging. Used # Used in the debugger prompt, and in determining whether it's all over or # not. $level = 0; # Level of recursive debugging # "Triggers bug (?) in perl if we postpone this until runtime." # XXX No details on this yet, or whether we should fix the bug instead # of work around it. Stay tuned. @postponed = @stack = (0); # Used to track the current stack depth using the auto-stacked-variable # trick. $stack_depth = 0; # Localized repeatedly; simple way to track $#stack # Don't print return values on exiting a subroutine. $doret = -2; # No extry/exit tracing. $frame = 0; } ## end BEGIN BEGIN { $^W = $ini_warn; } # Switch warnings back =head1 READLINE SUPPORT - COMPLETION FUNCTION =head2 db_complete C support - adds command completion to basic C. Returns a list of possible completions to C when invoked. C will print the longest common substring following the text already entered. If there is only a single possible completion, C will use it in full. This code uses C and C heavily to create lists of possible completion. Think LISP in this section. =cut sub db_complete { # Specific code for b c l V m f O, &blah, $blah, @blah, %blah # $text is the text to be completed. # $line is the incoming line typed by the user. # $start is the start of the text to be completed in the incoming line. my ( $text, $line, $start ) = @_; # Save the initial text. # The search pattern is current package, ::, extract the next qualifier # Prefix and pack are set to undef. my ( $itext, $search, $prefix, $pack ) = ( $text, "^\Q${'package'}::\E([^:]+)\$" ); =head3 C =over 4 =item * Find all the subroutines that might match in this package =item * Add C, C, and C as possibles (we may be completing the keyword itself) =item * Include all the rest of the subs that are known =item * C out the ones that match the text we have so far =item * Return this as the list of possible completions =back =cut return sort grep /^\Q$text/, ( keys %sub ), qw(postpone load compile), # subroutines ( map { /$search/ ? ($1) : () } keys %sub ) if ( substr $line, 0, $start ) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/; =head3 C Get all the possible files from C<@INC> as it currently stands and select the ones that match the text so far. =cut return sort grep /^\Q$text/, values %INC # files if ( substr $line, 0, $start ) =~ /^\|*b\s+load\s+$/; =head3 C (list variable) and C (list modules) There are two entry points for these commands: =head4 Unqualified package names Get the top-level packages and grab everything that matches the text so far. For each match, recursively complete the partial packages to get all possible matching packages. Return this sorted list. =cut return sort map { ( $_, db_complete( $_ . "::", "V ", 2 ) ) } grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : () } keys %:: # top-packages if ( substr $line, 0, $start ) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/; =head4 Qualified package names Take a partially-qualified package and find all subpackages for it by getting all the subpackages for the package so far, matching all the subpackages against the text, and discarding all of them which start with 'main::'. Return this list. =cut return sort map { ( $_, db_complete( $_ . "::", "V ", 2 ) ) } grep !/^main::/, grep /^\Q$text/, map { /^(.*)::$/ ? ( $prefix . "::$1" ) : () } keys %{ $prefix . '::' } if ( substr $line, 0, $start ) =~ /^\|*[Vm]\s+$/ and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1; =head3 C - switch files Here, we want to get a fully-qualified filename for the C command. Possibilities are: =over 4 =item 1. The original source file itself =item 2. A file from C<@INC> =item 3. An C (the debugger gets a C<(eval N)> fake file for each C). =back =cut if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files # We might possibly want to switch to an eval (which has a "filename" # like '(eval 9)'), so we may need to clean up the completion text # before proceeding. $prefix = length($1) - length($text); $text = $1; =pod Under the debugger, source files are represented as C<_E/fullpath/to/file> (Cs are C<_E(eval NNN)>) keys in C<%main::>. We pull all of these out of C<%main::>, add the initial source file, and extract the ones that match the completion text so far. =cut return sort map { substr $_, 2 + $prefix } grep /^_<\Q$text/, ( keys %main:: ), $0; } ## end if ($line =~ /^\|*f\s+(.*)/) =head3 Subroutine name completion We look through all of the defined subs (the keys of C<%sub>) and return both all the possible matches to the subroutine name plus all the matches qualified to the current package. =cut if ( ( substr $text, 0, 1 ) eq '&' ) { # subroutines $text = substr $text, 1; $prefix = "&"; return sort map "$prefix$_", grep /^\Q$text/, ( keys %sub ), ( map { /$search/ ? ($1) : () } keys %sub ); } ## end if ((substr $text, 0, ... =head3 Scalar, array, and hash completion: partially qualified package Much like the above, except we have to do a little more cleanup: =cut if ( $text =~ /^[\$@%](.*)::(.*)/ ) { # symbols in a package =pod =over 4 =item * Determine the package that the symbol is in. Put it in C<::> (effectively C) if no package is specified. =cut $pack = ( $1 eq 'main' ? '' : $1 ) . '::'; =pod =item * Figure out the prefix vs. what needs completing. =cut $prefix = ( substr $text, 0, 1 ) . $1 . '::'; $text = $2; =pod =item * Look through all the symbols in the package. C out all the possible hashes/arrays/scalars, and then C the possible matches out of those. C the prefix onto all the possibilities. =cut my @out = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack; =pod =item * If there's only one hit, and it's a package qualifier, and it's not equal to the initial text, re-complete it using the symbol we actually found. =cut if ( @out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext ) { return db_complete( $out[0], $line, $start ); } # Return the list of possibles. return sort @out; } ## end if ($text =~ /^[\$@%](.*)::(.*)/) =pod =back =head3 Symbol completion: current package or package C

. =cut if ( $text =~ /^[\$@%]/ ) { # symbols (in $package + packages in main) =pod =over 4 =item * If it's C
, delete main to just get C<::> leading. =cut $pack = ( $package eq 'main' ? '' : $package ) . '::'; =pod =item * We set the prefix to the item's sigil, and trim off the sigil to get the text to be completed. =cut $prefix = substr $text, 0, 1; $text = substr $text, 1; =pod =item * If the package is C<::> (C
), create an empty list; if it's something else, create a list of all the packages known. Append whichever list to a list of all the possible symbols in the current package. C out the matches to the text entered so far, then C the prefix back onto the symbols. =cut my @out = map "$prefix$_", grep /^\Q$text/, ( grep /^_?[a-zA-Z]/, keys %$pack ), ( $pack eq '::' ? () : ( grep /::$/, keys %:: ) ); =item * If there's only one hit, it's a package qualifier, and it's not equal to the initial text, recomplete using this symbol. =back =cut if ( @out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext ) { return db_complete( $out[0], $line, $start ); } # Return the list of possibles. return sort @out; } ## end if ($text =~ /^[\$@%]/) =head3 Options We use C to look up the current value of the option. If there's only a single value, we complete the command in such a way that it is a complete command for setting the option in question. If there are multiple possible values, we generate a command consisting of the option plus a trailing question mark, which, if executed, will list the current value of the option. =cut if ( ( substr $line, 0, $start ) =~ /^\|*[oO]\b.*\s$/ ) { # Options after space # We look for the text to be matched in the list of possible options, # and fetch the current value. my @out = grep /^\Q$text/, @options; my $val = option_val( $out[0], undef ); # Set up a 'query option's value' command. my $out = '? '; if ( not defined $val or $val =~ /[\n\r]/ ) { # There's really nothing else we can do. } # We have a value. Create a proper option-setting command. elsif ( $val =~ /\s/ ) { # XXX This may be an extraneous variable. my $found; # We'll want to quote the string (because of the embedded # whtespace), but we want to make sure we don't end up with # mismatched quote characters. We try several possibilities. foreach $l ( split //, qq/\"\'\#\|/ ) { # If we didn't find this quote character in the value, # quote it using this quote character. $out = "$l$val$l ", last if ( index $val, $l ) == -1; } } ## end elsif ($val =~ /\s/) # Don't need any quotes. else { $out = "=$val "; } # If there were multiple possible values, return '? ', which # makes the command into a query command. If there was just one, # have readline append that. $rl_attribs->{completer_terminator_character} = ( @out == 1 ? $out : '? ' ); # Return list of possibilities. return sort @out; } ## end if ((substr $line, 0, ... =head3 Filename completion For entering filenames. We simply call C's C method with the completion text to get the possible completions. =cut return $term->filename_list($text); # filenames } ## end sub db_complete =head1 MISCELLANEOUS SUPPORT FUNCTIONS Functions that possibly ought to be somewhere else. =head2 end_report Say we're done. =cut sub end_report { local $\ = ''; print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"; } =head2 clean_ENV If we have $ini_pids, save it in the environment; else remove it from the environment. Used by the C (restart) command. =cut sub clean_ENV { if ( defined($ini_pids) ) { $ENV{PERLDB_PIDS} = $ini_pids; } else { delete( $ENV{PERLDB_PIDS} ); } } ## end sub clean_ENV # PERLDBf_... flag names from perl.h our ( %DollarCaretP_flags, %DollarCaretP_flags_r ); BEGIN { %DollarCaretP_flags = ( PERLDBf_SUB => 0x01, # Debug sub enter/exit PERLDBf_LINE => 0x02, # Keep line # PERLDBf_NOOPT => 0x04, # Switch off optimizations PERLDBf_INTER => 0x08, # Preserve more data PERLDBf_SUBLINE => 0x10, # Keep subr source lines PERLDBf_SINGLE => 0x20, # Start with single-step on PERLDBf_NONAME => 0x40, # For _SUB: no name of the subr PERLDBf_GOTO => 0x80, # Report goto: call DB::goto PERLDBf_NAMEEVAL => 0x100, # Informative names for evals PERLDBf_NAMEANON => 0x200, # Informative names for anon subs PERLDBf_SAVESRC => 0x400, # Save source lines into @{"_<$filename"} PERLDB_ALL => 0x33f, # No _NONAME, _GOTO ); # PERLDBf_LINE also enables the actions of PERLDBf_SAVESRC, so the debugger # doesn't need to set it. It's provided for the benefit of profilers and # other code analysers. %DollarCaretP_flags_r = reverse %DollarCaretP_flags; } sub parse_DollarCaretP_flags { my $flags = shift; $flags =~ s/^\s+//; $flags =~ s/\s+$//; my $acu = 0; foreach my $f ( split /\s*\|\s*/, $flags ) { my $value; if ( $f =~ /^0x([[:xdigit:]]+)$/ ) { $value = hex $1; } elsif ( $f =~ /^(\d+)$/ ) { $value = int $1; } elsif ( $f =~ /^DEFAULT$/i ) { $value = $DollarCaretP_flags{PERLDB_ALL}; } else { $f =~ /^(?:PERLDBf_)?(.*)$/i; $value = $DollarCaretP_flags{ 'PERLDBf_' . uc($1) }; unless ( defined $value ) { print $OUT ( "Unrecognized \$^P flag '$f'!\n", "Acceptable flags are: " . join( ', ', sort keys %DollarCaretP_flags ), ", and hexadecimal and decimal numbers.\n" ); return undef; } } $acu |= $value; } $acu; } sub expand_DollarCaretP_flags { my $DollarCaretP = shift; my @bits = ( map { my $n = ( 1 << $_ ); ( $DollarCaretP & $n ) ? ( $DollarCaretP_flags_r{$n} || sprintf( '0x%x', $n ) ) : () } 0 .. 31 ); return @bits ? join( '|', @bits ) : 0; } =over 4 =item rerun Rerun the current session to: rerun current position rerun 4 command number 4 rerun -4 current command minus 4 (go back 4 steps) Whether this always makes sense, in the current context is unknowable, and is in part left as a useful exersize for the reader. This sub returns the appropriate arguments to rerun the current session. =cut sub rerun { my $i = shift; my @args; pop(@truehist); # strim unless (defined $truehist[$i]) { print "Unable to return to non-existent command: $i\n"; } else { $#truehist = ($i < 0 ? $#truehist + $i : $i > 0 ? $i : $#truehist); my @temp = @truehist; # store push(@DB::typeahead, @truehist); # saved @truehist = @hist = (); # flush @args = &restart(); # setup &get_list("PERLDB_HIST"); # clean &set_list("PERLDB_HIST", @temp); # reset } return @args; } =item restart Restarting the debugger is a complex operation that occurs in several phases. First, we try to reconstruct the command line that was used to invoke Perl and the debugger. =cut sub restart { # I may not be able to resurrect you, but here goes ... print $OUT "Warning: some settings and command-line options may be lost!\n"; my ( @script, @flags, $cl ); # If warn was on before, turn it on again. push @flags, '-w' if $ini_warn; # Rebuild the -I flags that were on the initial # command line. for (@ini_INC) { push @flags, '-I', $_; } # Turn on taint if it was on before. push @flags, '-T' if ${^TAINT}; # Arrange for setting the old INC: # Save the current @init_INC in the environment. set_list( "PERLDB_INC", @ini_INC ); # If this was a perl one-liner, go to the "file" # corresponding to the one-liner read all the lines # out of it (except for the first one, which is going # to be added back on again when 'perl -d' runs: that's # the 'require perl5db.pl;' line), and add them back on # to the command line to be executed. if ( $0 eq '-e' ) { for ( 1 .. $#{'::_<-e'} ) { # The first line is PERL5DB chomp( $cl = ${'::_<-e'}[$_] ); push @script, '-e', $cl; } } ## end if ($0 eq '-e') # Otherwise we just reuse the original name we had # before. else { @script = $0; } =pod After the command line has been reconstructed, the next step is to save the debugger's status in environment variables. The C routine is used to save aggregate variables (both hashes and arrays); scalars are just popped into environment variables directly. =cut # If the terminal supported history, grab it and # save that in the environment. set_list( "PERLDB_HIST", $term->Features->{getHistory} ? $term->GetHistory : @hist ); # Find all the files that were visited during this # session (i.e., the debugger had magic hashes # corresponding to them) and stick them in the environment. my @had_breakpoints = keys %had_breakpoints; set_list( "PERLDB_VISITED", @had_breakpoints ); # Save the debugger options we chose. set_list( "PERLDB_OPT", %option ); # set_list( "PERLDB_OPT", options2remember() ); # Save the break-on-loads. set_list( "PERLDB_ON_LOAD", %break_on_load ); =pod The most complex part of this is the saving of all of the breakpoints. They can live in an awful lot of places, and we have to go through all of them, find the breakpoints, and then save them in the appropriate environment variable via C. =cut # Go through all the breakpoints and make sure they're # still valid. my @hard; for ( 0 .. $#had_breakpoints ) { # We were in this file. my $file = $had_breakpoints[$_]; # Grab that file's magic line hash. *dbline = $main::{ '_<' . $file }; # Skip out if it doesn't exist, or if the breakpoint # is in a postponed file (we'll do postponed ones # later). next unless %dbline or $postponed_file{$file}; # In an eval. This is a little harder, so we'll # do more processing on that below. ( push @hard, $file ), next if $file =~ /^\(\w*eval/; # XXX I have no idea what this is doing. Yet. my @add; @add = %{ $postponed_file{$file} } if $postponed_file{$file}; # Save the list of all the breakpoints for this file. set_list( "PERLDB_FILE_$_", %dbline, @add ); } ## end for (0 .. $#had_breakpoints) # The breakpoint was inside an eval. This is a little # more difficult. XXX and I don't understand it. for (@hard) { # Get over to the eval in question. *dbline = $main::{ '_<' . $_ }; my ( $quoted, $sub, %subs, $line ) = quotemeta $_; for $sub ( keys %sub ) { next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/; $subs{$sub} = [ $1, $2 ]; } unless (%subs) { print $OUT "No subroutines in $_, ignoring breakpoints.\n"; next; } LINES: for $line ( keys %dbline ) { # One breakpoint per sub only: my ( $offset, $sub, $found ); SUBS: for $sub ( keys %subs ) { if ( $subs{$sub}->[1] >= $line # Not after the subroutine and ( not defined $offset # Not caught or $offset < 0 ) ) { # or badly caught $found = $sub; $offset = $line - $subs{$sub}->[0]; $offset = "+$offset", last SUBS if $offset >= 0; } ## end if ($subs{$sub}->[1] >=... } ## end for $sub (keys %subs) if ( defined $offset ) { $postponed{$found} = "break $offset if $dbline{$line}"; } else { print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n"; } } ## end for $line (keys %dbline) } ## end for (@hard) # Save the other things that don't need to be # processed. set_list( "PERLDB_POSTPONE", %postponed ); set_list( "PERLDB_PRETYPE", @$pretype ); set_list( "PERLDB_PRE", @$pre ); set_list( "PERLDB_POST", @$post ); set_list( "PERLDB_TYPEAHEAD", @typeahead ); # We are oficially restarting. $ENV{PERLDB_RESTART} = 1; # We are junking all child debuggers. delete $ENV{PERLDB_PIDS}; # Restore ini state # Set this back to the initial pid. $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids; =pod After all the debugger status has been saved, we take the command we built up and then return it, so we can C it. The debugger will spot the C environment variable and realize it needs to reload its state from the environment. =cut # And run Perl again. Add the "-d" flag, all the # flags we built up, the script (whether a one-liner # or a file), add on the -emacs flag for a slave editor, # and then the old arguments. return ($^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS); }; # end restart =back =head1 END PROCESSING - THE C BLOCK Come here at the very end of processing. We want to go into a loop where we allow the user to enter commands and interact with the debugger, but we don't want anything else to execute. First we set the C<$finished> variable, so that some commands that shouldn't be run after the end of program quit working. We then figure out whether we're truly done (as in the user entered a C command, or we finished execution while running nonstop). If we aren't, we set C<$single> to 1 (causing the debugger to get control again). We then call C, which returns the C message and returns control to the debugger. Repeat. When the user finally enters a C command, C<$fall_off_end> is set to 1 and the C block simply exits with C<$single> set to 0 (don't break, run to completion.). =cut END { $finished = 1 if $inhibit_exit; # So that some commands may be disabled. $fall_off_end = 1 unless $inhibit_exit; # Do not stop in at_exit() and destructors on exit: if ($fall_off_end or $runnonstop) { &save_hist(); } else { $DB::single = 1; DB::fake::at_exit(); } } ## end END =head1 PRE-5.8 COMMANDS Some of the commands changed function quite a bit in the 5.8 command realignment, so much so that the old code had to be replaced completely. Because we wanted to retain the option of being able to go back to the former command set, we moved the old code off to this section. There's an awful lot of duplicated code here. We've duplicated the comments to keep things clear. =head2 Null command Does nothing. Used to I commands. =cut sub cmd_pre580_null { # do nothing... } =head2 Old C command. This version added actions if you supplied them, and deleted them if you didn't. =cut sub cmd_pre580_a { my $xcmd = shift; my $cmd = shift; # Argument supplied. Add the action. if ( $cmd =~ /^(\d*)\s*(.*)/ ) { # If the line isn't there, use the current line. $i = $1 || $line; $j = $2; # If there is an action ... if ( length $j ) { # ... but the line isn't breakable, skip it. if ( $dbline[$i] == 0 ) { print $OUT "Line $i may not have an action.\n"; } else { # ... and the line is breakable: # Mark that there's an action in this file. $had_breakpoints{$filename} |= 2; # Delete any current action. $dbline{$i} =~ s/\0[^\0]*//; # Add the new action, continuing the line as needed. $dbline{$i} .= "\0" . action($j); } } ## end if (length $j) # No action supplied. else { # Delete the action. $dbline{$i} =~ s/\0[^\0]*//; # Mark as having no break or action if nothing's left. delete $dbline{$i} if $dbline{$i} eq ''; } } ## end if ($cmd =~ /^(\d*)\s*(.*)/) } ## end sub cmd_pre580_a =head2 Old C command Add breakpoints. =cut sub cmd_pre580_b { my $xcmd = shift; my $cmd = shift; my $dbline = shift; # Break on load. if ( $cmd =~ /^load\b\s*(.*)/ ) { my $file = $1; $file =~ s/\s+$//; &cmd_b_load($file); } # b compile|postpone [] # The interpreter actually traps this one for us; we just put the # necessary condition in the %postponed hash. elsif ( $cmd =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ ) { # Capture the condition if there is one. Make it true if none. my $cond = length $3 ? $3 : '1'; # Save the sub name and set $break to 1 if $1 was 'postpone', 0 # if it was 'compile'. my ( $subname, $break ) = ( $2, $1 eq 'postpone' ); # De-Perl4-ify the name - ' separators to ::. $subname =~ s/\'/::/g; # Qualify it into the current package unless it's already qualified. $subname = "${'package'}::" . $subname unless $subname =~ /::/; # Add main if it starts with ::. $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::"; # Save the break type for this sub. $postponed{$subname} = $break ? "break +0 if $cond" : "compile"; } ## end elsif ($cmd =~ ... # b [] elsif ( $cmd =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ ) { my $subname = $1; my $cond = length $2 ? $2 : '1'; &cmd_b_sub( $subname, $cond ); } # b []. elsif ( $cmd =~ /^(\d*)\s*(.*)/ ) { my $i = $1 || $dbline; my $cond = length $2 ? $2 : '1'; &cmd_b_line( $i, $cond ); } } ## end sub cmd_pre580_b =head2 Old C command. Delete all breakpoints unconditionally. =cut sub cmd_pre580_D { my $xcmd = shift; my $cmd = shift; if ( $cmd =~ /^\s*$/ ) { print $OUT "Deleting all breakpoints...\n"; # %had_breakpoints lists every file that had at least one # breakpoint in it. my $file; for $file ( keys %had_breakpoints ) { # Switch to the desired file temporarily. local *dbline = $main::{ '_<' . $file }; my $max = $#dbline; my $was; # For all lines in this file ... for ( $i = 1 ; $i <= $max ; $i++ ) { # If there's a breakpoint or action on this line ... if ( defined $dbline{$i} ) { # ... remove the breakpoint. $dbline{$i} =~ s/^[^\0]+//; if ( $dbline{$i} =~ s/^\0?$// ) { # Remove the entry altogether if no action is there. delete $dbline{$i}; } } ## end if (defined $dbline{$i... } ## end for ($i = 1 ; $i <= $max... # If, after we turn off the "there were breakpoints in this file" # bit, the entry in %had_breakpoints for this file is zero, # we should remove this file from the hash. if ( not $had_breakpoints{$file} &= ~1 ) { delete $had_breakpoints{$file}; } } ## end for $file (keys %had_breakpoints) # Kill off all the other breakpoints that are waiting for files that # haven't been loaded yet. undef %postponed; undef %postponed_file; undef %break_on_load; } ## end if ($cmd =~ /^\s*$/) } ## end sub cmd_pre580_D =head2 Old C command Print help. Defaults to printing the long-form help; the 5.8 version prints the summary by default. =cut sub cmd_pre580_h { my $xcmd = shift; my $cmd = shift; # Print the *right* help, long format. if ( $cmd =~ /^\s*$/ ) { print_help($pre580_help); } # 'h h' - explicitly-requested summary. elsif ( $cmd =~ /^h\s*/ ) { print_help($pre580_summary); } # Find and print a command's help. elsif ( $cmd =~ /^h\s+(\S.*)$/ ) { my $asked = $1; # for proper errmsg my $qasked = quotemeta($asked); # for searching # XXX: finds CR but not if ( $pre580_help =~ /^ is not a debugger command.\n"); } } ## end elsif ($cmd =~ /^h\s+(\S.*)$/) } ## end sub cmd_pre580_h =head2 Old C command CexprE> adds a watch expression, C deletes them all. =cut sub cmd_pre580_W { my $xcmd = shift; my $cmd = shift; # Delete all watch expressions. if ( $cmd =~ /^$/ ) { # No watching is going on. $trace &= ~2; # Kill all the watch expressions and values. @to_watch = @old_watch = (); } # Add a watch expression. elsif ( $cmd =~ /^(.*)/s ) { # add it to the list to be watched. push @to_watch, $1; # Get the current value of the expression. # Doesn't handle expressions returning list values! $evalarg = $1; my ($val) = &eval; $val = ( defined $val ) ? "'$val'" : 'undef'; # Save it. push @old_watch, $val; # We're watching stuff. $trace |= 2; } ## end elsif ($cmd =~ /^(.*)/s) } ## end sub cmd_pre580_W =head1 PRE-AND-POST-PROMPT COMMANDS AND ACTIONS The debugger used to have a bunch of nearly-identical code to handle the pre-and-post-prompt action commands. C and C unify all this into one set of code to handle the appropriate actions. =head2 C A small wrapper around C; it makes sure that the default doesn't do something destructive. In pre 5.8 debuggers, the default action was to delete all the actions. =cut sub cmd_pre590_prepost { my $cmd = shift; my $line = shift || '*'; my $dbline = shift; return &cmd_prepost( $cmd, $line, $dbline ); } ## end sub cmd_pre590_prepost =head2 C Actually does all the handling for C>, C>, C<{{>, C<{>, etc. Since the lists of actions are all held in arrays that are pointed to by references anyway, all we have to do is pick the right array reference and then use generic code to all, delete, or list actions. =cut sub cmd_prepost { my $cmd = shift; # No action supplied defaults to 'list'. my $line = shift || '?'; # Figure out what to put in the prompt. my $which = ''; # Make sure we have some array or another to address later. # This means that if ssome reason the tests fail, we won't be # trying to stash actions or delete them from the wrong place. my $aref = []; # < - Perl code to run before prompt. if ( $cmd =~ /^\ - Perl code to run after prompt. elsif ( $cmd =~ /^\>/o ) { $which = 'post-perl'; $aref = $post; } # { - first check for properly-balanced braces. elsif ( $cmd =~ /^\{/o ) { if ( $cmd =~ /^\{.*\}$/o && unbalanced( substr( $cmd, 1 ) ) ) { print $OUT "$cmd is now a debugger command\nuse `;$cmd' if you mean Perl code\n"; } # Properly balanced. Pre-prompt debugger actions. else { $which = 'pre-debugger'; $aref = $pretype; } } ## end elsif ( $cmd =~ /^\{/o ) # Did we find something that makes sense? unless ($which) { print $OUT "Confused by command: $cmd\n"; } # Yes. else { # List actions. if ( $line =~ /^\s*\?\s*$/o ) { unless (@$aref) { # Nothing there. Complain. print $OUT "No $which actions.\n"; } else { # List the actions in the selected list. print $OUT "$which commands:\n"; foreach my $action (@$aref) { print $OUT "\t$cmd -- $action\n"; } } ## end else } ## end if ( $line =~ /^\s*\?\s*$/o) # Might be a delete. else { if ( length($cmd) == 1 ) { if ( $line =~ /^\s*\*\s*$/o ) { # It's a delete. Get rid of the old actions in the # selected list.. @$aref = (); print $OUT "All $cmd actions cleared.\n"; } else { # Replace all the actions. (This is a <, >, or {). @$aref = action($line); } } ## end if ( length($cmd) == 1) elsif ( length($cmd) == 2 ) { # Add the action to the line. (This is a <<, >>, or {{). push @$aref, action($line); } else { # <<<, >>>>, {{{{{{ ... something not a command. print $OUT "Confused by strange length of $which command($cmd)...\n"; } } ## end else [ if ( $line =~ /^\s*\?\s*$/o) } ## end else } ## end sub cmd_prepost =head1 C Contains the C routine that the debugger uses to issue the C message after the program completes. See the C block documentation for more details. =cut package DB::fake; sub at_exit { "Debugged program terminated. Use `q' to quit or `R' to restart."; } package DB; # Do not trace this 1; below! 1; PDL-2.074/Doc/0000755000175000017500000000000014200406301012566 5ustar osboxesosboxesPDL-2.074/Doc/scantree.pl0000644000175000017500000000461314160015533014743 0ustar osboxesosboxesuse PDL::Doc; use Getopt::Std; use Config; use Cwd; require PDL; # always needed to pick up PDL::VERSION $opt_v = 0; getopts('v'); $dirarg = shift @ARGV; $outdb = shift @ARGV; $outindex = shift @ARGV; unless (defined $dirarg) { ($dirarg = $INC{'PDL.pm'}) =~ s/PDL\.pm$//i; umask 0022; print "DIR = $dirarg\n"; } my @dirs = split /,/,$dirarg; unless (defined $outdb) { $outdb = "$dirs[0]/PDL/pdldoc.db"; print "DB = $outdb\n"; } $currdir = getcwd; unlink $outdb if -e $outdb; $onldc = new PDL::Doc(); $onldc->outfile($outdb); foreach $dir (@dirs) { chdir $dir or die "can't change to $dir"; $dir = getcwd; $onldc->scantree($dir."/PDL",$opt_v); $onldc->scan($dir."/PDL.pm",$opt_v) if (-s $dir."/PDL.pm"); chdir $currdir; } print STDERR "saving...\n"; $onldc->savedb(); @mods = $onldc->search('module:',['Ref'],1); @mans = $onldc->search('manual:',['Ref'],1); @scripts = $onldc->search('script:',['Ref'],1); $outdir = "$dirs[0]/PDL"; # ($outdir = $INC{'PDL.pm'}) =~ s/\.pm$//i; $outindex="$outdir/Index.pod" unless (defined $outindex); unlink $outindex if -e $outindex; # Handle read only file open my $podfh, ">", $outindex or die "couldn't open $outindex: $!"; print $podfh <<'EOPOD'; =head1 NAME PDL::Index - an index of PDL documentation =head1 DESCRIPTION A meta document listing the documented PDL modules and the PDL manual documents =head1 PDL manuals EOPOD print $podfh "=over 4\n\n"; for (@mans) { my $ref = $_->[2]->{Ref}; $ref =~ s/Manual:/L<$_->[0]> -/; print $podfh "=item *\n\n$ref\n\n"; } print $podfh << 'EOPOD'; =back =head1 PDL scripts EOPOD print $podfh "=over 4\n\n"; for (@scripts) { my $ref = $_->[2]->{Ref}; $ref =~ s/Script:/L<$_->[0]|PDL::$_->[0]> -/; print $podfh "=item *\n\n$ref\n\n"; } print $podfh << 'EOPOD'; =back =head1 PDL modules EOPOD print $podfh "=over 4\n\n"; for (@mods) { my $ref = $_->[2]->{Ref}; next unless $_->[0] =~ /^PDL/; if( $_->[0] eq 'PDL'){ # special case needed to find the main PDL.pm file. $ref =~ s/Module:/L -/; print $podfh "=item *\n\n$ref\n\n"; next; } $ref =~ s/Module:/L<$_->[0]> -/; print $podfh "=item *\n\n$ref\n\n"; } print $podfh << "EOPOD"; =back =head1 HISTORY Automatically generated by scantree.pl for PDL version $PDL::VERSION. EOPOD close $podfh; #add the newly-created PDL::Index to the doc database $onldc->scan($outindex,$opt_v) if (-s $outindex); $onldc->savedb(); 1; PDL-2.074/Doc/Doc.pm0000644000175000017500000006754514167671466013706 0ustar osboxesosboxes# the filter for the PDL pod format (which is a valid general perl # pod format but with special interpretation of some =for directives) package PDL::PodParser; use strict; use warnings; use PDL::Core ''; use Pod::Select; use File::Spec; use File::Basename; our @ISA = qw(Pod::Select); our %Title = ('Example' => 'Example', 'Ref' => 'Reference', 'Sig' => 'Signature', 'Opt' => 'Options', 'Usage' => 'Usage', 'Bad' => 'Bad value support', ); sub new { my $class = shift; my $parser = $class->SUPER::new(@_); bless $parser,$class; # just in case $parser->select("METHODS|OPERATORS|CONTRUCTORS|FUNCTIONS|NAME"); $parser->{CURFUNC} = undef; $parser->{SYMHASH} = {}; $parser->{INBLOCK} = 0; $parser->{Mode} = ""; $parser->{verbose} = 0; $parser->{NAME} = 'UNKNOWN'; return $parser; } sub command { my ($this,$cmd,$txt,$line_num,$pod_para) = @_; $this->{Parmode} = 'Body'; if ($cmd eq 'head1') { $this->{Mode} = $txt; $this->{Parmode} = 'Body'; $this->{Parmode} = 'NAME' if $txt =~ /NAME/; } elsif ($this->{Mode} =~ /NAME/) { # do nothing (was 'last' but that was probably a mistake) } elsif ($cmd eq 'head2') { # A function can have multiple names (ex: zeros and zeroes), # so split at the commas my @funcs = split(',',$txt); # Remove parentheses (so myfunc and myfunc() both work) my @names = map {$1 if m/\s*([^\s(]+)\s*/} @funcs; barf "error parsing function list '$txt'" unless $#funcs == $#names; # check for signatures my $sym = $this->{SYMHASH}; for (@funcs) { $sym->{$1}->{Module} = $this->{NAME} if m/\s*([^\s(]+)\s*/; $sym->{$1}->{Sig} = $2 if m/\s*([^\s(]+)\s*\(\s*(.+)\s*\)\s*$/; } # make the first one the current function $sym->{$names[0]}->{Names} = join(',',@names) if $#names > 0; my $name = shift @names; # Make the other names cross-reference the first name $sym->{$_}->{Crossref} = $name for (@names); my $sig = $sym->{$name}->{Sig}; # diagnostic output print "\nFunction '".join(',',($name,@names))."'\n" if $this->{verbose}; print "\n\tSignature: $sig\n" if defined $sig && $this->{verbose}; $this->{CURFUNC} = $name; } elsif ($cmd eq 'for') { $this->check_for_mode($txt,$pod_para) if $cmd eq 'for'; } local $this->{Parmode} = 'Body'; $this->SUPER::command($cmd,$txt,$line_num,$pod_para); } sub check_for_mode { my ($this,$txt,$pod_para) = @_; if ($txt =~ /^(sig|example|ref|opt|usage|bad|body)/i) { $this->{Parmode} = ucfirst lc $1; print "switched now to '$1' mode\n" if $this->{VERBOSE}; print "\n\t$Title{$this->{Parmode}}\n" unless $this->{Parmode} =~ /Body/ || !$this->{verbose}; } } sub textblock { my $this = shift; my $txt = shift; $this->checkmode($txt); local $this->{INBLOCK} = 1; $this->SUPER::textblock($txt,@_); $this->{Parmode} = 'Body'; # and reset parmode } sub checkmode { my ($this,$txt,$verbatim) = @_; if ($this->{Mode} =~ /NAME/ && $this->{Parmode} =~ /NAME/) { $this->{NAME} = $1 if $this->trim($txt) =~ /^\s*(\S+)\s*/; print "\nNAME\t$this->{NAME}\n" if $this->{verbose}; $this->{Parmode} = 'Body'; return; } unless ($this->{Parmode} =~ /Body/ || $this->{INBLOCK}) { my $func = $this->{CURFUNC}; barf "no function defined" unless defined $func; local $this->{INBLOCK} = 1; # can interpolate call textblock? my $itxt = $verbatim ? $txt : $this->interpolate($txt); $this->{SYMHASH}->{$func}->{$this->{Parmode}} .= $this->trim($itxt,$verbatim); my $cr = ($verbatim && $this->{Parmode} ne 'Sig') ? "\n" : ""; my $out = "\n\t\t$cr".$this->trim($itxt,$verbatim); print "$out\n$cr" if $this->{verbose}; } $this->{Parmode} = 'Body'; } sub verbatim { my $this = shift; my $txt = shift; $this->checkmode($txt,1); $this->SUPER::verbatim($txt,@_); } # this needs improvement # and any formatting information should be removed? # it probably depends sub trim { my ($this,$txt,$verbatim) = @_; my $ntxt = ""; $txt =~ s/(signature|usage):\s*//i if $this->{Parmode} eq 'Sig' || $this->{Parmode} eq 'Usage'; if ($this->{Parmode} eq 'Sig') { $txt =~ s/^\s*//; $txt =~ s/\s*$//; while( $txt =~ s/^\((.*)\)$/$1/ ) {}; # Strip BALANCED brackets } for (split "\n", $txt) { s/^\s*(.*)\s*$/$1/ unless $verbatim; $ntxt .= "$_\n" unless m/^\s*$/; } # $txt =~ s/^\s*(.*)\s*$/$1/; chomp $ntxt; return $ntxt; } =head1 NAME PDL::Doc - support for PDL online documentation =head1 SYNOPSIS use PDL::Doc; $onlinedc = new PDL::Doc ($docfile); @match = $onlinedc->search('m/slice|clump/'); =head1 DESCRIPTION An implementation of online docs for PDL. =head1 Using PDL documentation PDL::Doc's main use is in the "help" (synonym "?") and "apropos" (synonym "??") commands in the perldl shell. PDL::Doc provides the infrastrucure to index and access PDL's documentation through these commands. There is also an API for direct access to the documentation database (see below). The PDL doc system is built on Perl's pod (Plain Old Documentation), included inline with each module. The PDL core modules are automatically indexed when PDL is built and installed, and there is provision for indexing external modules as well. To include your module's pod into the Perl::Doc index, you should follow the documentation conventions below. =head1 PDL documentation conventions For a package like PDL that has I of functions it is very desirable to have some form of online help to make it easy for the user to remind himself of names, calling conventions and typical usage of the multitude of functions at his disposal. To make it straightforward to extract the relevant information from the POD documentation in source files that make up the PDL distribution certain conventions have been adopted in formatting this documentation. The first convention says that all documentation for PDL functions appears in the POD section introduced by one of the following: =head1 FUNCTIONS =head1 OPERATORS =head1 METHODS =head1 CONSTRUCTORS If you're documenting an object-oriented interface to a class that your module defines, you should use METHODS and CONSTRUCTORS as appropriate. If you are simply adding functions to PDL, use FUNCTIONS and OPERATORS as appropriate. Individual functions or methods in these section are introduced by =head2 funcname where signature is the argumentlist for a PP defined function as explained in L. Generally, PDL documentation is in valid POD format (see L) but uses the C<=for> directive in a special way. The C<=for> directive is used to flag to the PDL Pod parser that information is following that will be used to generate online help. The PDL Pod parser recognises the following C<=for> directives: =over 5 =item Ref indicates that the one line reference for this function follows, e.g., =for ref Returns an ndarray of lags to parent. =item Sig the signature for the current function follows, e.g., =for sig Signature: (a(n), [o]b(), [t]tmp(n)) =item Usage an indication of the possible calling conventions for the current function, e.g., =for usage wpic($pdl,$filename[,{ options... }]) =item Opt lists options for the current function, e.g., =for options CONVERTER => 'ppmtogif', # explicitly specify pbm converter FLAGS => '-interlaced -transparent 0', # flags for converter IFORM => 'PGM', # explicitly specify intermediate format XTRAFLAGS => '-imagename iris', # additional flags to defaultflags FORMAT => 'PCX', # explicitly specify output image format COLOR => 'bw', # specify color conversion LUT => $lut, # use color table information =item Example gives examples of typical usage for the current function: =for example wpic $pdl, $file; $im->wpic('web.gif',{LUT => $lut}); for (@images) { $_->wpic($name[0],{CONVERTER => 'ppmtogif'}) } =item Bad provides information on how the function handles bad values. The documentation under this directive should indicate if this function accepts ndarrays with bad values and under what circumstances this function might return ndarrays with bad values. =back The PDL podparser is implemented as a simple state machine. Any of the above C<=for> statements switches the podparser into a state where the following paragraph is accepted as information for the respective field (C, C, C, C or C). Only the text up to the end of the current paragraph is accepted, for example: =for example ($x,$y) = $z->func(1,3); # this is part of the accepted info $x = func($z,0,1); # this as well $x = func($c,$d); # but this isn't To make the resulting pod documentation also easily digestible for the existing pod filters (pod2man, pod2text, pod2html, etc) the actual textblock of information must be separated from the C<=for> directive by at least one blank line. Otherwise, the textblock will be lost in the translation process when the "normal" podformatters are used. The general idea behind this format is that it should be easy to extract the information for online documentation, automatic generation of a reference card, etc but at the same time the documentation should be translated by the standard podformatters without loss of contents (and without requiring any changes in the existing POD format). The preceding explanations should be further explained by the following example (extracted from PDL/IO/Misc/misc.pd): =head2 rcols() =for ref Read ASCII whitespaced cols from file into ndarrays efficiently. If no columns are specified all are assumed Will optionally only process lines matching a pattern. Can take file name or *HANDLE. =for usage Usage: ($x,$y,...) = rcols(*HANDLE|"filename", ["/pattern/",$col1, $col2,] ...) e.g., =for example ($x,$y) = rcols 'file1' ($x,$y,$z) = rcols 'file2', "/foo/",3,4 $x = PDL->rcols 'file1'; Note: currently quotes are required on the pattern. which is translated by, e.g, the standard C converter into: rcols() Read ASCII whitespaced cols from file into ndarrays efficiently. If no columns are specified all are assumed Will optionally only process lines matching a pattern. Can take file name or *HANDLE. Usage: ($x,$y,...) = rcols(*HANDLE|"filename", ["/pattern/",$col1, $col2,] ...) e.g., ($x,$y) = rcols 'file1' ($x,$y,$z) = rcols 'file2', "/foo/",3,4 $x = PDL->rcols 'file1'; Note: currently quotes are required on the pattern. It should be clear from the preceding example that readable output can be obtained from this format using the standard converters and the reader will hopefully get a feeling how he can easily intersperse the special C<=for> directives with the normal POD documentation. =head2 Which directives should be contained in the documentation The module documentation should start with the =head1 NAME PDL::Modulename -- do something with ndarrays section (as anyway required by C) since the PDL podparser extracts the name of the module this function belongs to from that section. Each function that is I only for internal use by the module should be documented, introduced with the C<=head2> directive in the C<=head1 FUNCTIONS> section. The only field that every function documented along these lines should have is the I field preceding a one line description of its intended functionality (suitable for inclusion in a concise reference card). PP defined functions (see L) should have a I field stating their signature. To facilitate maintenance of this documentation for such functions the 'Doc' field has been introduced into the definition of C (see again L) which will take care that name and signature of the so defined function are documented in this way (for examples of this usage see, for example, the PDL::Slices module, especially F and the resulting F). Similarly, the 'BadDoc' field provides a means of specifying information on how the routine handles the presence of bad values: this will be autpmatically created if C is not supplied, or set to C. Furthermore, the documentation for each function should contain at least one of the I or I fields. Depending on the calling conventions for the function under consideration presence of both fields may be warranted. If a function has options that should be given as a hash reference in the form {Option => Value, ...} then the possible options (and aproppriate values) should be explained in the textblock following the C<=for Opt> directive (see example above and, e.g., PDL::IO::Pic). It is well possible that some of these conventions appear to be clumsy at times and the author is keen to hear of any suggestions for better alternatives. =cut package PDL::Doc; use PDL::Core ''; use File::Basename; use PDL::Doc::Config; =head1 INSTANCE METHODS =head2 new $onlinedc = new PDL::Doc ('file.pdl',[more files]); =cut sub new { my ($type,@files) = @_; my $this = bless {},$type; $this->{File} = [@files]; $this->{Scanned} = []; $this->{Outfile} = $files[0]; return $this; } =head2 addfiles add another file to the online database associated with this object. =cut sub addfiles { my ($this,@files) = @_; push @{$this->{File}}, @files; } =head2 outfile set the name of the output file for this online db =cut sub outfile { my ($this,$file) = @_; $this->{Outfile} = $file if defined $file; return $this->{Outfile}; } =head2 ensuredb Make sure that the database is slurped in =cut sub ensuredb { my ($this) = @_; while (my $fi = pop @{$this->{File}}) { open IN, $fi or barf "can't open database $fi, scan docs first"; binmode IN; my ($plen,$txt); while (read IN, $plen,2) { my ($len) = unpack "S", $plen; read IN, $txt, $len; my (@a) = split chr(0), $txt; my $module = splice @a,1,1; push(@a, "") unless(@a % 2); # Add null string at end if necessary -- solves bug with missing REF section. my ($sym, %hash) = @a; $hash{Dbfile} = $fi; # keep the origin pdldoc.db path $this->{SYMS}->{$sym}->{$module} = {%hash}; } close IN; push @{$this->{Scanned}}, $fi; } return $this->{SYMS}; } =head2 savedb save the database (i.e., the hash of PDL symbols) to the file associated with this object. =cut sub savedb { my ($this) = @_; my $hash = $this->ensuredb(); open my $fh, '>', $this->{Outfile} or barf "can't write to symdb $this->{Outfile}: $!"; binmode $fh; while (my ($name,$mods_hash) = each %$hash) { next if 0 == scalar(%$mods_hash); while (my ($module,$val) = each %$mods_hash){ my $fi = $val->{File}; if (File::Spec->file_name_is_absolute($fi) && -f $fi) { #store paths to *.pm files relative to pdldoc.db $val->{File} = File::Spec->abs2rel($fi, dirname($this->{Outfile})) ; } delete $val->{Dbfile}; # no need to store Dbfile my $txt = join(chr(0),$name,$module,%$val); print $fh pack("S",length($txt)).$txt; } } } =head2 gethash Return the PDL symhash (e.g. for custom search operations) The symhash is a multiply nested hash ref with the following structure: $symhash = { function_name => { module::name => { Module => 'module::name', Sig => 'signature string', Bad => 'bad documentation string', ... }, }, function_name => { module::name => { Module => 'module::name', Sig => 'signature string', Bad => 'bad documentation string', ... }, }, } The three-layer structure is designed to allow the symhash (and the underlying database) to handle functions that have the same name but reside in different module namespaces. The possible keys for each function/module entry include: Module - module name Sig - signature Crossref - the function name for the documentation, if it has multiple names (ex: the documentation for zeros is under zeroes) Names - a comma-separated string of all the function's names Example - example text (optional) Ref - one-line reference string Opt - options Usage - short usage explanation Bad - explanation of behavior when it encounters bad values =cut sub gethash { return $_[0]->ensuredb(); } =head2 search Search a PDL symhash =for usage $onldc->search($regex, $fields [, $sort]) Searching is by default case insensitive. Other flags can be given by specifying the regexp in the form C where C can be replaced with any other non-alphanumeric character. $fields is an array reference for all hash fields (or simply a string if you only want to search one field) that should be matched against the regex. Valid fields are Name, # name of the function Module, # module the function belongs to Ref, # the one-line reference description Example, # the example for this function Opt, # options File, # the path to the source file these docs have been extracted from If you wish to have your results sorted by function name, pass a true value for C<$sort>. The results will be returned as an array of triplets in the form @results = ( [funcname, module, {SYMHASH_ENTRY}], [funcname, module, {SYMHASH_ENTRY}], ... ); See the example at the end of the documentation to see how you might use this. =cut sub search { my ($this,$pattern,$fields,$sort) = @_; $sort = 0 unless defined $sort; my $hash = $this->ensuredb; my @match = (); # Make a single scalar $fields work $fields = [$fields] if ref($fields) eq ''; $pattern = $this->checkregex($pattern); while (my ($name,$mods_hash) = each %$hash) { while (my ($module,$val) = each %$mods_hash){ FIELD: for (@$fields) { if ($_ eq 'Name' and $name =~ /$pattern/i or defined $val->{$_} and $val->{$_} =~ /$pattern/i) { $val = $hash->{$val->{Crossref}}->{$module} #we're going to assume that any Crossref'd documentation is also in this module if defined $val->{Crossref} && defined $hash->{$val->{Crossref}}->{$module}; push @match, [$name,$module,$val]; last FIELD; } } } } @match = sort {$a->[0] cmp $b->[0]} @match if (@match && $sort); return @match; } # parse a regexp in the form # m/^[a-z]+/ismx # where the pairs of '/' can be replaced by any other pair of matching # characters # if the expression doesn't start with 'm' followed by a nonalphanumeric # character, return as-is sub checkregex { my ($this,$regex) = @_; return "(?i)$regex" unless $regex =~ /^m[^a-z,A-Z,0-9]/; my $sep = substr($regex,1,1); substr($regex,0,2) = ''; $sep = '(?', \(my $outfile_text); # Handle RPM etc. case where we are building away from the final # location. Alright it's a hack - KGB my $file2 = $file; $file2 =~ s/^$ENV{BUILDROOTPREFIX}// if $ENV{BUILDROOTPREFIX}; my $parser = new PDL::PodParser; $parser->{verbose} = $verbose; eval { $parser->parse_from_filehandle($infile,$outfile) }; warn "cannot parse '$file'" if $@; $this->{SYMS} = {} unless defined $this->{SYMS}; my $hash = $this->{SYMS}; my @stats = stat $file; $this->{FTIME}->{$file2} = $stats[9]; # store last mod time # print "mtime of $file: $stats[9]\n"; my $phash = $parser->{SYMHASH}; my $n = 0; while (my ($key,$val) = each %$phash) { $n++; $val->{File} = $file2; #set up the 3-layer hash/database structure: $hash->{funcname}->{PDL::SomeModule} = $val if (defined($val->{Module})){ $hash->{$key}->{$val->{Module}} = $val; } else { warn "no Module for $key in $file2\n"; } } # KGB pass2 - scan for module name and function # alright I admit this is kludgy but it works # and one can now find modules with 'apropos' open $infile, '<', $file; $outfile_text = ''; $parser = new PDL::PodParser; $parser->select('NAME'); eval { $parser->parse_from_filehandle($infile,$outfile) }; warn "cannot parse '$file'" if $@; my @namelines = split("\n",$outfile_text); my ($name,$does); for (@namelines) { if (/^(PDL) (-) (.*)/ or /^\s*(Inline::Pdlpp)\s*(-*)?\s*(.*)\s*$/ or /\s*(PDL::[\w:]*)\s*(-*)?\s*(.*)\s*$/) { $name = $1; $does = $3; } if (/^\s*([a-z][a-z0-9]*) (-+) (.*)/) { # lowercase shell script name $name = $1; $does = $3; ($name,$does) = (undef,undef) unless $does =~ /shell|script/i; } } $does = 'Hmmm ????' if $does and $does =~ /^\s*$/; my $type = ($file =~ /\.pod$/ ? ($does =~ /shell|script/i && $name =~ /^[a-z][a-z0-9]*$/) ? 'Script:' : 'Manual:' : 'Module:'); $hash->{$name}{$name} = {Ref=>"$type $does",File=>$file2} if $name and $name !~ /^\s*$/; return $n; } =head2 scantree Scan whole directory trees for online documentation in C<.pm> (module definition) and C<*.pod> (general documentation) files (using the File::Find module). =cut sub scantree { my ($this,$dir,$verbose) = @_; $verbose = 0 unless defined $verbose; require File::Find; print "Scanning $dir ... \n\n"; my $ntot = 0; my $sub = sub { if (($File::Find::name =~ /[.]pm$/ && $File::Find::name !~ /PP.pm/ && $File::Find::name !~ m|Pod/Parser.pm| && $File::Find::dir !~ m#/PP|/Gen#) or ( $File::Find::name =~ /[.]pod$/ && $File::Find::name !~ /Index[.]pod$/)){ printf "%-20s", $_.'...'; my $n = $this->scan($File::Find::name,$verbose); # bind $this lexically print "\t$n functions\n"; $ntot += $n; } }; File::Find::find($sub,$dir); print "\n\nfound $ntot functions\n"; } =head2 funcdocs extract the complete documentation about a function from its source file using the PDL::Pod::Parser filter. =cut sub funcdocs { my ($this,$func,$module,$fout) = @_; my $hash = $this->ensuredb; barf "unknown function '$func'" unless defined($hash->{$func}); barf "funcdocs now requires 3 arguments" if defined fileno $module; my $file = $hash->{$func}->{$module}->{File}; my $dbf = $hash->{$func}->{$module}->{Dbfile}; if (!File::Spec->file_name_is_absolute($file) && $dbf) { $file = File::Spec->rel2abs($file, dirname($dbf)); } funcdocs_fromfile($func,$file,$fout); } =head1 FUNCTIONS =cut sub funcdocs_fromfile { my ($func,$file) = @_; barf "can't find file '$file'" unless -f $file; local $SIG{PIPE}= sub {}; # Prevent crashing if user exits the pager open my $in, '<', $file or barf "can't open file $file"; my $out = $_[2]; open $out, "| pod2text | $PDL::Doc::pager" if !defined $out; barf "can't open output handle" unless $out; getfuncdocs($func,$in,$out); print $out "Docs from $file\n\n"; } sub extrdoc { my ($func,$file) = @_; open my $out, '>', \(my $out_text); funcdocs_fromfile($func,$file,$out); return $out_text; } sub getfuncdocs { my ($func,$in,$out) = @_; my $parser = Pod::Select->new; # $parser->select("\\(METHODS\\|OPERATORS\\|CONSTRUCTORS\\|FUNCTIONS\\|METHODS\\)/$func(\\(.*\\)*\\s*"); foreach my $foo(qw/FUNCTIONS OPERATORS CONSTRUCTORS METHODS/) { seek $in,0,0; $parser->select("$foo/(.*,\\s+)*$func(\\(.*\\))*(\\s*|,\\s+.*)"); $parser->parse_from_filehandle($in,$out); } } =head2 add_module =for usage use PDL::Doc; PDL::Doc::add_module("my::module"); =for ref The C function allows you to add POD from a particular Perl module that you've installed somewhere in @INC. It searches for the active PDL document database and the module's .pod and .pm files, and scans and indexes the module into the database. C is meant to be added to your module's Makefile as part of the installation script. =cut package PDL::Doc; sub add_module { my($module) = shift; use File::Copy qw{copy}; my($dir, $file, $pdldoc); local($_); DIRECTORY: for(@INC){ $dir = $_; $file = $dir."/PDL/pdldoc.db"; if( -f $file) { if(! -w "$dir/PDL") { die "No write permission at $dir/PDL - not updating docs database.\n"; } print "Found docs database $file\n"; $pdldoc = new ("PDL::Doc",($file)); last DIRECTORY; } } die "Unable to find docs database - therefore not updating it.\n" unless($pdldoc); my $mfile = $module; $mfile =~ s/\:\:/\//g; for(@INC){ my $postfix; my $hit = 0; for $postfix(".pm",".pod") { my $f = "$_/$mfile$postfix"; if( -e $f ){ $pdldoc->ensuredb(); $pdldoc->scan($f); eval { $pdldoc->savedb(); }; warn $@ if $@; print "PDL docs database updated - added $f.\n"; $hit = 1; } } return if($hit); } die "Unable to find a .pm or .pod file in \@INC for module $module\n"; } 1; =head1 PDL::DOC EXAMPLE Here's an example of how you might use the PDL Doc database in your own code. use PDL::Doc; # Find the pdl documentation my ($dir,$file,$pdldoc); DIRECTORY: for $dir (@INC) { $file = $dir."/PDL/pdldoc.db"; if (-f $file) { print "Found docs database $file\n"; $pdldoc = new PDL::Doc ($file); last DIRECTORY; } } die ("Unable to find docs database!\n") unless $pdldoc; # Print the reference line for zeroes: print map{$_->{Ref}} values %{$pdldoc->gethash->{zeroes}}; # Or, if you remember that zeroes is in PDL::Core: print $pdldoc->gethash->{zeroes}->{PDL::Core}->{Ref}; # Get info for all the functions whose examples use zeroes my @entries = $pdldoc->search('zeroes','Example',1); # All the functions that use zeroes in their example: print "Functions that use 'zeroes' in their examples include:\n"; foreach my $entry (@entries) { # Unpack the entry my ($func_name, $module, $sym_hash) = @$entry; print "$func_name\n"; } print "\n"; #Or, more concisely: print join("\n",map{$_->[0]}@entries); # Let's look at the function 'mpdl' @entries = $pdldoc->search('mpdl', 'Name'); # I know there's only one: my $entry = $entries[0]; my ($func_name, undef, $sym_hash) = @$entry; print "mpdl info:\n"; foreach my $key (sort keys %$sym_hash) { # Unpack the entry print "---$key---\n$sym_hash->{$key}\n"; } =head2 Finding Modules How can you tell if you've gotten a module for one of your entries? The Ref entry will begin with 'Module:' if it's a module. In code: # Prints: # Module: fundamental PDL functionality and vectorization/threading print $pdldoc->gethash->{'PDL::Core'}->{'PDL::Core'}->{Ref}, "\n" =head1 BUGS Quite a few shortcomings which will hopefully be fixed following discussions on the pdl-devel mailing list. =head1 AUTHOR Copyright 1997 Christian Soeller Ec.soeller@auckland.ac.nzE and Karl Glazebrook Ekgb@aaoepp.aao.gov.auE Further contributions copyright 2010 David Mertens Edcmertens.perl@gmail.comE Documentation database restructuring 2019 Derek Lamb 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 1; PDL-2.074/Doc/mkpdlfuncpod0000644000175000017500000000431713265417442015226 0ustar osboxesosboxesuse PDL::Doc; use PDL::Doc::Perldl; # @dontmod = qw/ PDL::Graphics::TriD::Tk /; %Category = ( IO => '^PDL::IO', Graphics => '^PDL::Graphics', Core => '^PDL::Core| ^PDL::Primitive| ^PDL::Slices| ^PDL::Math| ^PDL::Basic', Lib => '^PDL::Image |^PDL::Slatec |^PDL::FFT |^PDL::Filter |^PDL::Fit |^PDL::Gaussian |^PDL::GSL', Dev => '^PDL::Types |^PDL::Dbg |^PDL::Options |^PDL::Autoloader |^PDL::Callext |^PDL::Doc::Perldl', Derived => '^PDL::Complex |^PDL::Char |^PDL::Func', ); sub nofunc { my ($func,$hash) = @_; if ($func =~ /AUTOLOAD |MainLoop /xs || $hash->{Ref} =~ /^internal$/) { print STDERR "skipping $func\n"; return 1 } else { return 0 } } # a very simple script to generate a huge manpage of all documented # PDL functions # mainly to demonstrate what we can do with the new doc format print << 'EOD'; =head1 NAME pdlfunc - Functions in the PDL distribution =head1 DESCRIPTION This is a listing of all documented functions in the PDL distribution. =head2 Alphabetical Listing of PDL Functions =over 8 EOD $onldc = $PDL::onlinedoc; # new PDL::Doc ('/tmp/pdlhash.dbtxt'); $db = $onldc->ensuredb; while (my ($key,$val) = each %$db) { my $strip = $key; $strip =~ s/PDL.*::(.*)$/$1/; $val->{Stripped} = $strip; } @match = $onldc->search('.*',['Name'],1); @match = sort {lc $a->[1]->{Stripped} cmp lc $b->[1]->{Stripped}} @match; for (@match) { next if $_->[1]->{Ref} =~ /(Module|Manual):/ || nofunc $_->[1]->{Stripped}, $_->[1]; $sh = new StrHandle; print STDERR "function $_->[0] ($_->[1]->{Stripped})\n"; $onldc->funcdocs($_->[0],$sh); $mod = "\n\nModule: $_->[1]->{Module}\n\n"; $stripped = $_->[1]->{Stripped}; $txt = $sh->text; $txt =~ s/=head2 (.*)$/=item $stripped$mod/mg; $txt =~ s/^=cut\s*$//mg; $txt =~ s/^=for.*$//mg; $txt =~ s/Docs from .*$//mg; print $txt; } print <<'EOD'; =back EOD PDL-2.074/Doc/mkhtmldoc.pl0000644000175000017500000001657214167572110015136 0ustar osboxesosboxes # # Should be called like # # perl mkhtmldoc.pl [FULLPATH_TO_SOURCE] [FULLPATH_TO_HTMLDIR] # # for example # # perl mkhtmldoc.pl `pwd`/blib/lib `pwd`/html # # reverted to use Pod::Html from normal perl distrib # Christian # # (mod. by Tjl) use File::Find; use File::Basename; use File::Basename; use Getopt::Std; use Pod::Html; use Cwd; $opt_v = 0; $opt_s = ''; getopts('vs:'); my $verbose = $opt_v; my ($strip_path,$add_path) = split(/,/,$opt_s); ############################################################## ## Subroutines sub has_pod # does file contain HTML-able pod? { my $line; #mustn't clobber $_ during find open(POD,shift) || return 0; while ($line=) {return 1 if $line =~ /^=head/} # only a guess, avoids "=for nobody", etc. return 0; } sub mkdir_p ($$$) { return if -d $_[0]; # my @dirs = File::Spec->splitdir($_[0]); my @dirs = split '/', $_[0]; pop @dirs; if(!@dirs) {die "Couldn't create directory $_[2]"} # my $dir = File::Spec->catdir( @dirs ); my $dir = join '/', @dirs; mkdir_p ($dir, $_[1], $_[2]); print "Creating directory $_[0]\n" if $verbose; mkdir $_[0], $_[1] or die "Couldn't create directory $_[0]"; } sub fix_pdl_dot_html ($) { ##Links to PDL.html sensibly try to go up one too many directories ##(e.g., to "../PDL.html" instead of "PDL.html"). This hopefully ##fixes that. Shamelessly ripped off hack_html(). my $infile = shift; my $outfile = "${infile}.n"; open my $ifh, "<", $infile or die "ERROR: Unable to read from <$infile>: $!\n"; open my $ofh, ">", $outfile or die "ERROR: Unable to write to <$outfile>: $!\n"; # assume that links do not break across a line while ( <$ifh> ) { # fix the links s{\.\.\/PDL\.html}{PDL.html}g; print $ofh $_; } close $ifh; close $ofh; rename $outfile, $infile or die "ERROR: Unable to rename $outfile\n"; } sub fix_html_path ($) { my $infile = shift; my $outfile = "${infile}.n"; open my $ifh, "<", $infile or die "ERROR: Unable to read from <$infile>: $!\n"; open my $ofh, ">", $outfile or die "ERROR: Unable to write to <$outfile>: $!\n"; # assume that links do not break across a line while ( <$ifh> ) { # fix the links s{a href="$strip_path}{a href="$add_path}g; print $ofh $_; } close $ifh; close $ofh; rename $outfile, $infile or die "ERROR: Unable to rename $outfile\n"; } sub fix_pp_inline ($) { my $infile = shift; my $outfile = "${infile}.n"; open my $ifh, "<", $infile or die "ERROR: Unable to read from <$infile>: $!\n"; open my $ofh, ">", $outfile or die "ERROR: Unable to write to <$outfile>: $!\n"; # assume that links do not break across a line while ( <$ifh> ) { #fix the links s|a href="../Inline/Pdlpp.html"|a href="./PP-Inline.html"|g; print $ofh $_; } close $ifh; close $ofh; rename $outfile, $infile or die "ERROR: Unable to rename $outfile\n"; } ############################################################## ## Code $SIG{__DIE__} = sub {print Carp::longmess(@_); die;}; $back = getcwd; $startdir = shift @ARGV; #$ARGV[0]; unless (defined $startdir) { require PDL; ($startdir = $INC{'PDL.pm'}) =~ s/\.pm$//i; umask 0022; } die "couldn't find directory '$startdir'" unless -d $startdir; chdir $startdir or die "can't change to $startdir"; $startdir = getcwd; # Hack to get absolute pathname chdir $back; $htmldir = shift @ARGV; #$ARGV[1]; #$htmldir = File::Spec->catdir( $startdir, "HtmlDocs", "PDL" ) $htmldir = "${startdir}/HtmlDocs/PDL" unless defined $htmldir; mkdir_p $htmldir, 0777, $htmldir; chdir $htmldir or die "can't change to $htmldir"; $htmldir = getcwd; # Hack to get absolute pathname chdir $back; #my $updir = File::Spec->updir; print "Making HTML docs...\n\n"; print "Put HTML $htmldir\n" if $verbose; print "Scanning $startdir ... \n\n" if $verbose; $sub = sub { return unless $File::Find::name =~ /[.]pod$/ or ($File::Find::name =~ /[.]pm$/ and $File::Find::name !~ /PP.pm/ and $File::Find::dir !~ m{/PP|/Gen}); # if (($File::Find::name =~ /[.]pm$/ and # $File::Find::name !~ /PP.pm/ and # $File::Find::dir !~ m#/PP|/Gen#) or # $File::Find::name =~ /[.]pod$/) { if (!&has_pod($File::Find::name)) { printf STDERR "%-30s\n", $_ ."... skipped (no pod)" if $verbose; return; } my $re = "\Q$startdir\E"; # ach: '+' in $outdir here! my $outdir = $File::Find::dir; # $outdir =~ s/$re/$htmldir/; $outdir =~ s/$re//; $outdir =~ /(^\/)?(.*)$/; my $basename = basename($File::Find::name); my $outfi; # Special case for needed for PDL.pm file since it is in a # different location than the other .pm and pod files. if( $basename eq 'PDL.pm'){ $outfi = $basename; } else { $outfi = $2.($2 =~ /^\s*$/ ? '' : '/').$basename; # # with the following substitution, everything gets stored in the same directory - # so PDL/Graphics/LUT -> PDL_Graphics_LUT for example # #$outfi =~ s|/|_|g; } # create the output directory, if required if ( $outdir ne "" ) { # $outdir = File::Spec->catdir( $htmldir, $outdir ); $outdir = "${htmldir}/${outdir}"; mkdir_p $outdir, 0777, $outdir; } # print "outdir = $outdir, making $outfi\n"; return; # mkdir_p $outdir, 0777, $outdir; my $file = $File::Find::name; # my $outfile = File::Spec->catfile( $htmldir, $outfi ); my $outfile = "${htmldir}/${outfi}"; $outfile =~ s/[.](pm|pod)$//; $outfile .= ".html"; printf STDERR "%-30s\n", $_ ."..."; # > $outfile"; chdir $htmldir; # reuse our pod caches my $topPerlDir = $startdir; # get Directory just above PDL for podroot arg $topPerlDir = $1 if ($startdir =~ /^(.+?)\/PDL$/); print "startdir: $startdir, podroot: $topPerlDir\n" if $verbose; # instead of having htmlroot="../../.." # (or even File::Spec->catdir( $updir, $updir, $updir ) ) # calculate it from the known location of the # file we're creating my $htmlrootdir = $htmldir; $htmlrootdir =~ s|PDL$||; my $verbopts = $verbose ? "--verbose" : "--quiet"; my @pod2html_args = ( "--podpath=.", "--podroot=$topPerlDir", "--htmldir=$htmlrootdir", "--recurse", "--infile=$file", "--outfile=$outfile", $verbopts, ); if($] <= 5.015) { # With perl 5.15.x (for some value of x) and later, '--libpods' is invalid # and hence needs to be removed. # Beginning with 5.15.x, the generated PDL html docs are a little different # (missing some underlining of headings and some tagging), though # this appears to have nothing to do with the removal of --libpods. Rather, # it seems to be the result of some other change to pod2html. Perhaps this # can be addressed over time. SIS 23-Feb-2012 # Cut out "PDL" from the podpath as it crashes the podscan(!) - It doesn't # seem to help either -- it looks for cached docs in .../HtmlDocs/pdl/PDL, # which is silly. I left this note because pod paths are pretty arcane to # me. CED 11-Mar-2009 # pod2html("--podpath=PDL:.", unshift @pod2html_args, "--libpods=perlfaq"; } pod2html(@pod2html_args); fix_pdl_dot_html( $outfile); fix_html_path( $outfile); fix_pp_inline( $outfile); chdir $File::Find::dir; # don't confuse File::Find }; #File::Find::find($sub,$startdir,File::Spec->catdir( $startdir, $updir, "PDL.pm")); File::Find::find( $sub, $startdir, "${startdir}/../PDL.pm" ); ## End PDL-2.074/Doc/Doc/0000755000175000017500000000000014200406301013273 5ustar osboxesosboxesPDL-2.074/Doc/Doc/Perldl.pm0000644000175000017500000004664214167572110015105 0ustar osboxesosboxes=head1 NAME PDL::Doc::Perldl - commands for accessing PDL doc database from 'perldl' shell =head1 DESCRIPTION This module provides a set of functions to access the PDL documentation database, for use from the I or I shells as well as the I command-line program. Autoload files are also matched, via a search of the PDLLIB autoloader tree. That behavior can be switched off with the variable C<$PERLDL::STRICT_DOCS> (true: don't search autoload tree; false: search the autoload tree.) In the interest of brevity, functions that print module names (at the moment just L and L) use some shorthand notation for module names. Currently-implemented shorthands are =over 3 =item * P:: (short for PDL::) =item * P::G:: (short for PDL::Graphics::) =back To turn this feature off, set the variable $PERLDL::long_mod_names to a true value. The feature is assumed to be on for the purposes of this documentation. =head1 SYNOPSIS use PDL::Doc::Perldl; # Load all documentation functions =head1 FUNCTIONS =cut package PDL::Doc::Perldl; use Exporter; use strict; use warnings; our @ISA = qw(Exporter); our @EXPORT = qw( apropos aproposover usage help sig badinfo whatis ); use PDL::Doc; use Pod::Select; use Pod::PlainText; use Term::ReadKey; #for GetTerminalSize $PDL::onlinedoc = undef; $PDL::onlinedoc = PDL::Doc->new(FindStdFile()); # Find std file sub FindStdFile { my ($d,$f); for $d (@INC) { $f = $d."/PDL/pdldoc.db"; if (-f $f) { print "Found docs database $f\n" if $PDL::verbose; print "Type 'help' for online help\n" if $PDL::verbose; return $f; } } warn "Unable to find PDL/pdldoc.db in ".join(":",@INC)."\n"; } # used to find out how wide the screen should be # for printmatch() - really should check for a # sensible lower limit (for printmatch >~ 40 # would be my guess) # # taken from Pod::Text (v1.0203), then hacked to get it # to work (at least on my solaris and linux # machines) # sub screen_width() { return ( ( GetTerminalSize(\*STDOUT) )[0] // 72); } sub printmatch { my @match = @_; if (@match) { foreach my $t ( format_ref( @_ ) ) { print $t; } } else { print "no match\n\n"; } } # sub: print_match() # given a long module name, return the (perhaps shortened) module name. sub shortmod { my $module = shift; $module =~ s/::$//; unless ($PERLDL::long_mod_names && $PERLDL::long_mod_names){ # silence warn $module =~ s/^PDL::/P::/; $module =~ s/^P::Graphics::/P::G::/; #additional abbreviation substitutions go here } return $module; } # return a string containing a formated version of the Ref string # for the given matches # sub format_ref { my @match = @_; my @text = (); #finding the max width before doing the printing means looping through @match an extra time; so be it. my @module_shorthands = map { shortmod($_->[1]) } @match; my $max_mod_length = -1; map {$max_mod_length = length if (length>$max_mod_length) } @module_shorthands; my $width = screen_width()-17-1-$max_mod_length; my $parser = new Pod::PlainText( width => $width, indent => 0, sentence => 0 ); for my $m (@match) { my $ref = $m->[2]{Ref} || ( (defined $m->[2]{CustomFile}) ? "[No ref avail. for `".$m->[2]{CustomFile}."']" : "[No reference available]" ); my $name = $m->[0]; my $module = shortmod($m->[1]); $ref = $parser->interpolate( $ref ); $ref = $parser->reformat( $ref ); # remove last new lines (so substitution doesn't append spaces at end of text) $ref =~ s/\n*$//; $ref =~ s/\n/"\n ".' 'x($max_mod_length+2)/eg; $ref =~ s/^\s*//; if ( length($name) > 15 ) { push @text, sprintf "%s ...\n " . ' 'x15 . "%-*s %s\n", $name, $max_mod_length, $module, $ref; } else { push @text, sprintf "%-15s %-*s %s\n", $name, $max_mod_length, $module, $ref; } } return wantarray ? @text : $text[0]; } # sub: format_ref() =head2 apropos =for ref Regex search PDL documentation database =for usage apropos 'text' =for example pdl> apropos 'pic' PDL::IO::Pic P::IO::Pic Module: image I/O for PDL grabpic3d P::G::TriD Grab a 3D image from the screen. rim P::IO::Pic Read images in most formats, with improved RGB handling. rpic P::IO::Pic Read images in many formats with automatic format detection. rpiccan P::IO::Pic Test which image formats can be read/written wim P::IO::Pic Write a pdl to an image file with selected type (or using filename extensions) wmpeg P::IO::Pic Write an image sequence (a (3,x,y,n) byte pdl) as an animation. wpic P::IO::Pic Write images in many formats with automatic format selection. wpiccan P::IO::Pic Test which image formats can be read/written To find all the manuals that come with PDL, try apropos 'manual:' and to get quick info about PDL modules say apropos 'module:' You get more detailed info about a PDL function/module/manual with the C function =cut sub aproposover { die "Usage: aproposover \$funcname\n" unless $#_>-1; die "no online doc database" unless defined $PDL::onlinedoc; my $func = shift; $func =~ s:\/:\\\/:g; search_docs("m/$func/",['Name','Ref','Module'],1); } sub apropos { die "Usage: apropos \$funcname\n" unless $#_>-1; die "no online doc database" unless defined $PDL::onlinedoc; my $func = shift; printmatch aproposover $func; } =head2 PDL::Doc::Perldl::search_docs =for ref Internal routine to search docs database and autoload files =cut sub search_docs { my ($func,$types,$sortflag,$exact) = @_; my @match; @match = $PDL::onlinedoc->search($func,$types,$sortflag); push(@match,find_autodoc( $func, $exact ) ); @match; } =head2 PDL::Doc::Perldl::finddoc =for ref Internal interface to the PDL documentation searcher =cut sub finddoc { local $SIG{PIPE}= sub {}; # Prevent crashing if user exits the pager die 'Usage: doc $topic' unless $#_>-1; die "no online doc database" unless defined $PDL::onlinedoc; my $topic = shift; # See if it matches a PDL function name my $subfield = $1 if( $topic =~ s/\[(\d*)\]$// ); #does it end with a number in square brackets? (my $t2 = $topic) =~ s/([^a-zA-Z0-9_])/\\$1/g; #$t2 is a copy of $topic with escaped non-word characters my @match = search_docs("m/^(PDL::)?".$t2."\$/",['Name'],0) ; #matches: ^PDL::topic$ or ^topic$ unless(@match) { print "No PDL docs for '$topic'. Using 'whatis'. (Try 'apropos $topic'?)\n\n"; whatis($topic); return; } # print out the matches open my $out, "| pod2text | $PDL::Doc::pager"; if($subfield) { if($subfield <= @match) { @match = ($match[$subfield-1]); $subfield = 0; } else { print $out "\n\n=head1 PDL HELP: Ignoring out-of-range selector $subfield\n\n=head1\n\n=head1 --------------------------------\n\n"; $subfield = undef; } } my $num_pdl_pod_matches = scalar @match; my $pdl_pod_matchnum = 0; while (@match) { $pdl_pod_matchnum++; if ( @match > 1 and !$subfield and $pdl_pod_matchnum==1 ) { print $out "\n\n=head1 MULTIPLE MATCHES FOR HELP TOPIC '$topic':\n\n=head1\n\n=over 3\n\n"; my $i=0; for my $m ( @match ) { printf $out "\n=item [%d]\t%-30s %s%s\n\n", ++$i, $m->[0], $m->[2]{Module} && "in ", $m->[2]{CustomFile} || $m->[2]{Module}; } print $out "\n=back\n\n=head1\n\n To see item number \$n, use 'help ${topic}\[\$n\]'. \n\n=cut\n\n"; } if (@match > 0 and $num_pdl_pod_matches > 1) { print $out "\n=head1 Displaying item $pdl_pod_matchnum:\n\n=head1 --------------------------------------\n\n=cut\n\n"; } my $m = shift @match; my $Ref = $m->[2]{Ref}; if ( $Ref =~ /^(Module|Manual|Script): / ) { # We've got a file name and we have to open it. With the relocatable db, we have to reconstitute the absolute pathname. my $relfile = $m->[2]{File}; my $absfile = undef; my @scnd = @{$PDL::onlinedoc->{Scanned}}; for my $dbf(@scnd){ $dbf =~ s:\/[^\/]*$::; # Trim file name off the end of the database file to get just the directory $dbf .= "/$relfile"; $absfile = $dbf if( -e $dbf ); } unless ($absfile) { die "Documentation error: couldn't find absolute path to $relfile\n"; } open my $in, "<", $absfile; print $out join("",<$in>); } else { if(defined $m->[2]{CustomFile}) { my $parser= Pod::Select->new; print $out "=head1 Autoload file \"".$m->[2]{CustomFile}."\"\n\n"; $parser->parse_from_file($m->[2]{CustomFile},$out); print $out "\n\n=head2 Docs from\n\n".$m->[2]{CustomFile}."\n\n"; } else { print $out "=head1 Module ",$m->[2]{Module}, "\n\n"; # print STDERR "calling funcdocs(" . $m->[0] . ", " . $m->[1] . ")\n"; $PDL::onlinedoc->funcdocs($m->[0],$m->[1],$out); } } } } =head2 find_autodoc =for ref Internal routine that finds and returns documentation in the PDL::AutoLoader path, if it exists. You feed in a topic and it searches for the file "${topic}.pdl". If that exists, then the filename gets returned in a match structure appropriate for the rest of finddoc. =cut # Yuck. Sorry. At least it works. -CED sub find_autodoc { my $topic = shift; my $exact = shift; my $matcher; # Fix up regexps and exact matches for the special case of # searching the autoload dirs... if($exact) { $topic =~ s/\(\)$//; # "func()" -> "func" $topic .= ".pdl" unless $topic =~ m/\.pdl$/; } else { $topic =~ s:([^\$])(.)$:$1\.\*\$$2:; # Include explicit ".*$" at end of # vague matches -- so that we can # make it a ".*\.pdl$" below. $topic =~ s:\$(.)$:\.pdl\$$1:; # Force ".pdl" at end of file match $matcher = eval "sub { ${topic}i && \$\_ };"; # Avoid multiple compiles } my @out; return unless(@main::PDLLIB); @main::PDLLIB_EXPANDED = PDL::AutoLoader::expand_path(@main::PDLLIB) unless(@main::PDLLIB_EXPANDED); for my $dir(@main::PDLLIB_EXPANDED) { if($exact) { my $file = $dir . "/" . "$topic"; push(@out, [$file, undef, {CustomFile => "$file", Module => "file '$file'"}] ) if(-e $file); } else { opendir(FOO,$dir) || next; my @dir = readdir(FOO); closedir(FOO); for my $file( grep( &$matcher, @dir ) ) { push(@out, [$file, undef, {CustomFile => "$dir/$file", Module => "file '$dir/$file'"}] ); } } } @out; } =head2 usage =for ref Prints usage information for a PDL function =for usage Usage: usage 'func' =for example pdl> usage 'inner' inner P::Primitive Inner product over one dimension Signature: inner(a(n); b(n); [o]c()) =cut sub usage { die 'Usage: usage $funcname' unless $#_>-1; die "no online doc database" unless defined $PDL::onlinedoc; print usage_string(@_); } sub usage_string{ my $func = shift; my $str = ""; my @match = search_docs("m/^(PDL::)?$func\$|\:\:$func\$/",['Name']); my $count = @match; unless ($count) { $str = "\n no match\n" } else { #this sorts by namespace depth by counting colons in the name. #PDL::Ufunc::max comes before PDL::GSL::RNG::max, for example. foreach my $m(sort { scalar(()=$a->[1]=~/\:/g) <=> scalar(()=$b->[1]=~/\:/g) } @match){ $str .= "\n" . format_ref( $m ); my ($name,$module,$hash) = @{$m}; #$str .= sprintf ( (' 'x16)."(Module %s)\n\n", $hash->{Module} ); $str.="\n"; die "No usage info found for $func\n" if (!defined $hash->{Example} && !defined $hash->{Sig} && !defined $hash->{Usage}); $str .= " Signature: $name($hash->{Sig})\n\n" if defined $hash->{Sig}; for (['Usage','Usage'],['Opt','Options'],['Example','Example']) { $str .= " $_->[1]:\n".&allindent($hash->{$_->[0]},10)."\n" if defined $hash->{$_->[0]}; } $str .= '='x20 unless 1==$count--; } } return $str; } =head2 sig =for ref prints signature of PDL function =for usage sig 'func' The signature is the normal dimensionality of the function's arguments. Calling with different dimensions doesn't break -- it causes threading. See L for details. =for example pdl> sig 'outer' Signature: outer(a(n); b(m); [o]c(n,m)) =cut sub sig { die "Usage: sig \$funcname\n" unless $#_>-1; die "no online doc database" unless defined $PDL::onlinedoc; my $func = shift; my @match = search_docs("m/^(PDL::)?$func\$|\:\:$func\$/",['Name']); my $count = @match; unless (@match) { print "\n no match\n" } else { foreach my $m(sort { scalar(()=$a->[1]=~/\:/g) <=> scalar(()=$b->[1]=~/\:/g) } @match){ my ($name,$module,$hash) = @{$m}; die "No signature info found for $func\n" if !defined $hash->{Sig}; print " Signature: $name($hash->{Sig})\n" if defined $hash->{Sig}; print '='x20 unless 1==$count--; } } } sub allindent { my ($txt,$n) = @_; my ($ntxt,$tspc) = ($txt,' 'x8); $ntxt =~ s/^\s*$//mg; $ntxt =~ s/\t/$tspc/g; my $minspc = length $txt; for (split '\n', $txt) { if (/^(\s*)/) { $minspc = length $1 if length $1 < $minspc } } $n -= $minspc; $tspc = ' 'x abs($n); $ntxt =~ s/^/$tspc/mg if $n > 0; return $ntxt; } =head2 whatis =for ref Describe a perl and/or PDL variable or expression. Useful for determining the type of an expression, identifying the keys in a hash or a data structure, or examining WTF an unknown object is. =for usage Usage: whatis $var whatis =cut sub whatis { my $topic; if(@_ > 1) { whatis_r('',0,[@_]); } else { whatis_r('',0,shift); } } $PDL::Doc::Perldl::max_strlen = 55; $PDL::Doc::Perldl::max_arraylen = 1; $PDL::Doc::Perldl::max_keylen = 8; $PDL::Doc::Perldl::array_indent=5; $PDL::Doc::Perldl::hash_indent=3; sub whatis_r { my $prefix = shift; my $indent = shift; my $x = shift; unless(defined $x) { print $prefix,"\n"; return; } unless(ref $x) { print "${prefix}'". substr($x,0,$PDL::Doc::Perldl::max_strlen). "'".((length $x > $PDL::Doc::Perldl::max_strlen) && '...'). "\n"; return; } if(ref $x eq 'ARRAY') { print "${prefix}Array (".scalar(@$x)." elements):\n"; my($el); for $el(0..$#$x) { my $pre = sprintf("%s %2d: "," "x$indent,$el); whatis_r($pre,$indent + $PDL::Doc::Perldl::array_indent, $x->[$el]); last if($el == $PDL::Doc::Perldl::max_arraylen); } printf "%s ... \n"," " x $indent if($#$x > $PDL::Doc::Perldl::max_arraylen); return; } if(ref $x eq 'HASH') { print "${prefix}Hash (".scalar(keys %$x)." elements)\n"; my $key; for $key(sort keys %$x) { my $pre = " " x $indent . " $key: " . (" "x($PDL::Doc::Perldl::max_keylen - length($key))) ; whatis_r($pre,$indent + $PDL::Doc::Perldl::hash_indent, $x->{$key}); } return; } if(ref $x eq 'CODE') { print "${prefix}Perl CODE ref\n"; return; } if(ref $x eq 'SCALAR' | ref $x eq 'REF') { whatis_r($prefix." Ref -> ",$indent+8,$$x); return; } if(UNIVERSAL::can($x,'px')) { my $y; local $PDL::debug = 1; $y = ( (UNIVERSAL::isa($x,'PDL') && $x->nelem < 5 && $x->ndims < 2) ? ": $x" : ": *****" ); $x->px($prefix.(ref $x)." %7T (%D) ".$y); } else { print "${prefix}Object: ".ref($x)."\n"; } } =head2 help =for ref print documentation about a PDL function or module or show a PDL manual In the case of multiple matches, the first command found is printed out, and the remaining commands listed, along with the names of their modules. =for usage Usage: help 'func' =for example pdl> help 'PDL::Tutorials' # show the guide to PDL tutorials pdl> help 'PDL::Slices' # show the docs in the PDL::Slices module pdl> help 'slice' # show docs on the 'slice' function =cut sub help_url { local $_; foreach(@INC) { my $x = "$_/PDL/HtmlDocs/PDL/Index.html"; if(-e $x) { return "file://$x"; } } } sub help { if ($#_>-1) { require PDL::Dbg; my $topic = shift; if (PDL::Core::blessed($topic) && $topic->can('px')) { local $PDL::debug = 1; $topic->px('This variable is'); } else { $topic = 'PDL::Doc::Perldl' if $topic =~ /^\s*help\s*$/i; if ($topic =~ /^\s*vars\s*$/i) { PDL->px((caller)[0]); } elsif($topic =~ /^\s*url\s*/i) { my $x = help_url(); if($x) { print $x; } else { print "Hmmm. Curious: I couldn't find the HTML docs anywhere in \@INC...\n"; } } elsif($topic =~ /^\s*www(:([^\s]+))?\s*/i) { my $browser; my $url = help_url(); if($2) { $browser = $2; } elsif($ENV{PERLDL_WWW}) { $browser = $ENV{PERLDL_WWW}; } else { $browser = 'mozilla'; } chomp($browser = `which $browser`); if(-e $browser && -x $browser) { print "Spawning \"$browser $url\"...\n"; `$browser $url`; } } else { finddoc($topic); } } } else { print <<'EOH'; The following commands support online help in the perldl shell: help 'thing' -- print docs on 'thing' (func, module, manual, autoload-file) help vars -- print information about all current ndarrays help url -- locate the HTML version of the documentation help www -- View docs with default web browser (set by env: PERLDL_WWW) whatis -- Describe the type and structure of an expression or ndarray. apropos 'word' -- search for keywords/function names usage -- print usage information for a given PDL function sig -- print signature of PDL function badinfo -- information on the support for bad values ('?' is an alias for 'help'; '??' is an alias for 'apropos'.) Quick start: apropos 'manual:' -- Find all the manual documents apropos 'module:' -- Quick summary of all PDL modules help 'help' -- details about PDL help system help 'perldl' -- help about this shell EOH } } =head2 badinfo =for ref provides information on the bad-value support of a function And has a horrible name. =for usage badinfo 'func' =for example pdl> badinfo 'inner' Bad value support for inner (in module PDL::Primitive) If "a() * b()" contains only bad data, "c()" is set bad. Otherwise "c()" will have its bad flag cleared, as it will not contain any bad values. =cut # need to get this to format the output - want a format_bad() # subroutine that's like - but much simpler - than format_ref() # sub badinfo { my $func = shift; die "Usage: badinfo \$funcname\n" unless defined $func; die "no online doc database" unless defined $PDL::onlinedoc; local $SIG{PIPE}= sub {}; # Prevent crashing if user exits the pager my @match = search_docs("m/^(PDL::)?$func\$|\:\:$func\$/",['Name']); my $count = @match; if ( $count ) { my ($pagerstr, $noinfostr); foreach my $m(@match) { my ($name,$module,$hash) = @{$m}; my $info = $hash->{Bad}; if ( defined $info ) { $name=~s/^(.*)\:\:(\w*)$/$2/; $pagerstr .= "=head1 Bad value support for $name (in module $module)\n\n$info\n"; } else { $noinfostr .= "\n No information on bad-value support found for $func (in module $module)\n"; } } if ($pagerstr){ open my $out, "| pod2text | $PDL::Doc::pager"; print $out $pagerstr, $noinfostr; } else { print $noinfostr; } } else { print "\n no match\n"; } } # sub: badinfo() 1; # OK PDL-2.074/Doc/Doc/Config.pm.PL0000644000175000017500000000253114146003631015361 0ustar osboxesosboxes#!/usr/local/bin/perl use Config; use File::Basename qw(&basename &dirname); # List explicitly here the variables you want Configure to # generate. Metaconfig only looks for shell variables, so you # have to mention them as if they were shell variables, not # %Config entries. Thus you write # $startperl # to ensure Configure will look for $Config{startperl}. # This forces PL files to create target in same directory as PL file. # This is so that make depend always knows where to find PL derivatives. chdir(dirname($0)); ($file = basename($0)) =~ s/\.PL$//; $file =~ s/\.pl$// if ($Config{'osname'} eq 'VMS' or $Config{'osname'} eq 'OS2'); # "case-forgiving" open OUT,">$file" or die "Can't create $file: $!"; print "Extracting $file (with variable substitutions)\n"; chmod 0644, $file; # In this section, perl variables will be expanded during extraction. # You can use $Config{...} to use Configure variables. print OUT "# automatically built from ".basename($0)."\n"; print OUT "# don't modify, all changes will be lost !!!!\n"; print OUT <<'!NO!SUBS!'; package PDL::Doc::Config; !NO!SUBS! print OUT <<"EOC"; \$PDL::Doc::pager = \'$Config{'pager'}\'; \$PDL::Doc::pager = \$ENV{PAGER} if defined \$ENV{PAGER}; \$PDL::Doc::pager = \$ENV{PERLDOC_PAGER} if defined \$ENV{PERLDOC_PAGER}; \$PDL::Doc::DefaultFile = \'$Config{'man1direxp'}\'; 1; EOC PDL-2.074/Doc/TODO0000644000175000017500000000024713265417442013303 0ustar osboxesosboxes- rearrange hash structure to root->{Module}->{Funcname} to avoid name clashes - warn about duplicate documentation - policy to integrate with build process PDL-2.074/Doc/README0000644000175000017500000000576213265417442013502 0ustar osboxesosboxesThis is a first try to get something like online help for PDL. Building proceeds as usual: perl Makefile.PL make Then there are a few things you should try: 1) Scan the current PDL distribution (PDL-1.94_05 + PATCHES) for online help info: perl -Mblib scantree.pl and specify the location of your *installed* PDL distribution (either the default or YOUR_PDL_DIR/blib/lib/PDL if you haven't installed it) when asked to do so. 2) Try the online doc support from within perldl (in the root directory of the PDL-Doc distribution): perldl and at the perldl prompt, type 'help': perldl> help and proceed from there. For details check the supplied file 'local.perldlrc'. 3) If you want to see which info has been picked from your POD documentation try perl -Mblib docscan in the root directory of the PDL-Doc distribution. 4) Once you have built the online info database (see step 1) try the example that builds a 'pdlfunc' manpage by saying: perl -Mblib mkpdlfuncpod >pdlfunc.pod This is just a demonstration of what should become possible once the online docs work correctly. 5) If you prefer the itemised listing of PDL functions in the manpage version, try perl -Mblib pdlhead2item > pod2man | nroff -man | more that translates the <=head2> directives into an itemised list. This is again just a demo what can be done. For info about the POD format conventions used by the PDL podparser to identify the online documentation check the docs in Doc.pm. There are still quite a few shortcomings in the implementation: 1) the podparser code is currently a bit messy 2) scanning is done very naively. No real checks are made if a function is documented in several files, etc. Needs to be done once integerated with the PDL distrib. 3) Scanning and database updating should be integerated with the build process. An updating policy should be developed. 4) The PP changes to support the new doc style are poorly documented, for the moment refer to the examples supplied in the patches to PDL-1.94_05. Briefly, the 'Doc' key has been introduced and PP will generate the =head2 funcname =for sig Signature: (...) entries automatically. No docs are generated if you say pp_def('XXXXfunc', Doc => 'internal',... ); pp_addpm has been changed to optionally accept an option hash ref to specify if the pm text should be inserted at the top, in the middle or at the bottom. I'm not sure of this is necessary/a good solution yet. 6) If the symhash should grow beyond the point where it is practical to hold it all in memory the implementation should use some kind of cached AnyDBM inplementation. 7) and probably lots of other things... Christian Soeller Changes for intergration in to PDL distribution - changed scantree.pl to take args for directory, database. - moved local.perldlrc into PDL::Doc::Perldl module - Made "borrowed" Pod:: stuff into PDL::Pod:: for now. Karl Glazebrook PDL-2.074/Doc/Makefile.PL0000644000175000017500000000207214146003631014551 0ustar osboxesosboxesuse strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'PDL::Doc', 'VERSION_FROM' => '../Basic/PDL.pm', 'LIBS' => [''], # e.g., '-lm' 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' 'INC' => '', # e.g., '-I/usr/include/other' 'dist' => { SUFFIX => "gz", COMPRESS => "gzip -f"}, 'PM' => { 'Doc.pm' => '$(INST_LIBDIR)$(DFSEP)Doc.pm', 'Doc$(DFSEP)Config.pm' => '$(INST_LIBDIR)$(DFSEP)Doc$(DFSEP)Config.pm', # left side must be same as PL_FILES right side 'Doc$(DFSEP)Perldl.pm' => '$(INST_LIBDIR)$(DFSEP)Doc$(DFSEP)Perldl.pm', }, 'PL_FILES' => {q[Doc$(DFSEP)Config.pm.PL]=>q[Doc$(DFSEP)Config.pm]}, 'clean' => { 'FILES' => q[Doc/Config.pm] }, NO_MYMETA => 1, ); package MY; # this corrects EUMM not knowing about subdirs separated by $(DFSEP) sub init_MANPODS { my ($self) = @_; $self->SUPER::init_MANPODS; for my $doc (sort keys %{ $self->{MAN3PODS} }) { $self->{MAN3PODS}->{$doc} =~ s#\Q$(DFSEP)\E#::#g; } } PDL-2.074/GENERATED/0000755000175000017500000000000014200406302013360 5ustar osboxesosboxesPDL-2.074/GENERATED/PDL/0000755000175000017500000000000014200406317014005 5ustar osboxesosboxesPDL-2.074/GENERATED/PDL/Fit/0000755000175000017500000000000014200406311014521 5ustar osboxesosboxesPDL-2.074/GENERATED/PDL/Fit/Gaussian.pm0000644000175000017500000000772314200406311016642 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::Fit::Gaussian; our @EXPORT_OK = qw(fitgauss1d fitgauss1dr ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Fit::Gaussian ; #line 5 "gaussian.pd" =head1 NAME PDL::Fit::Gaussian - routines for fitting gaussians =head1 DESCRIPTION This module contains some custom gaussian fitting routines. These were developed in collaboration with Alison Offer, they do a reasonably robust job and are quite useful. Gaussian fitting is something I do a lot of, so I figured it was worth putting in my special code. Note it is not clear to me that this code is fully debugged. The reason I say that is because I tried using the internal linear eqn solving C routines called elsewhere and they were giving erroneous results. So steal from this code with caution! However it does give good fits to reasonable looking gaussians and tests show correct parameters. KGB 29/Oct/2002 =head1 SYNOPSIS use PDL; use PDL::Fit::Gaussian; ($cen, $pk, $fwhm, $back, $err, $fit) = fitgauss1d($x, $data); ($pk, $fwhm, $back, $err, $fit) = fitgauss1dr($r, $data); =head1 FUNCTIONS =head2 fitgauss1d =for ref Fit 1D Gassian to data ndarray =for example ($cen, $pk, $fwhm, $back, $err, $fit) = fitgauss1d($x, $data); =for usage ($cen, $pk, $fwhm, $back, $err, $fit) = fitgauss1d($x, $data); =for signature xval(n); data(n); [o]xcentre();[o]peak_ht(); [o]fwhm(); [o]background();int [o]err(); [o]datafit(n); [t]sig(n); [t]ytmp(n); [t]yytmp(n); [t]rtmp(n); Fits a 1D Gaussian robustly free parameters are the centre, peak height, FWHM. The background is NOT fit, because I find this is generally unreliable, rather a median is determined in the 'outer' 10% of pixels (i.e. those at the start/end of the data ndarray). The initial estimate of the FWHM is the length of the ndarray/3, so it might fail if the ndarray is too long. (This is non-robust anyway). Most data does just fine and this is a good default gaussian fitter. SEE ALSO: fitgauss1dr() for fitting radial gaussians =head2 fitgauss1dr =for ref Fit 1D Gassian to radial data ndarray =for example ($pk, $fwhm2, $back, $err, $fit) = fitgauss1dr($r, $data); =for usage ($pk, $fwhm2, $back, $err, $fit) = fitgauss1dr($r, $data); =for signature xval(n); data(n); [o]peak_ht(); [o]fwhm(); [o]background();int [o]err(); [o]datafit(n); [t]sig(n); [t]ytmp(n); [t]yytmp(n); [t]rtmp(n); Fits a 1D radial Gaussian robustly free parameters are the peak height, FWHM. Centre is assumed to be X=0 (i.e. start of ndarray). The background is NOT fit, because I find this is generally unreliable, rather a median is determined in the 'outer' 10% of pixels (i.e. those at the end of the data ndarray). The initial estimate of the FWHM is the length of the ndarray/3, so it might fail if the ndarray is too long. (This is non-robust anyway). Most data does just fine and this is a good default gaussian fitter. SEE ALSO: fitgauss1d() to fit centre as well. =cut use strict; use warnings; #line 122 "Gaussian.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *fitgauss1d = \&PDL::fitgauss1d; #line 132 "Gaussian.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *fitgauss1dr = \&PDL::fitgauss1dr; #line 138 "Gaussian.pm" #line 192 "gaussian.pd" =head1 BUGS May not converge for weird data, still pretty good! =head1 AUTHOR This file copyright (C) 1999, Karl Glazebrook (kgb@aaoepp.aao.gov.au), Gaussian fitting code by Alison Offer (aro@aaocbn.aao.gov.au). 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 #line 158 "Gaussian.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/Image2D.pm0000644000175000017500000011045214200406316015555 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::Image2D; our @EXPORT_OK = qw( conv2d med2d med2df box2d patch2d patchbad2d max2d_ind centroid2d cc8compt cc4compt ccNcompt polyfill pnpoly polyfillv rotnewsz rot2d bilin2d rescale2d fitwarp2d applywarp2d warp2d warp2d_kernel warp2d_kernel ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Image2D ; #line 5 "image2d.pd" use strict; use warnings; =head1 NAME PDL::Image2D - Miscellaneous 2D image processing functions =head1 DESCRIPTION Miscellaneous 2D image processing functions - for want of anywhere else to put them. =head1 SYNOPSIS use PDL::Image2D; =cut use PDL; # ensure qsort routine available use PDL::Math; use Carp; #line 47 "Image2D.pm" =head1 FUNCTIONS =cut #line 1061 "../../blib/lib/PDL/PP.pm" #line 62 "Image2D.pm" #line 1061 "../../blib/lib/PDL/PP.pm" #line 67 "Image2D.pm" #line 1061 "../../blib/lib/PDL/PP.pm" #line 72 "Image2D.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 conv2d =for sig Signature: (a(m,n); kern(p,q); [o]b(m,n); int opt) =for ref 2D convolution of an array with a kernel (smoothing) For large kernels, using a FFT routine, such as L in C, will be quicker. =for usage $new = conv2d $old, $kernel, {OPTIONS} =for example $smoothed = conv2d $image, ones(3,3), {Boundary => Reflect} =for options Boundary - controls what values are assumed for the image when kernel crosses its edge: => Default - periodic boundary conditions (i.e. wrap around axis) => Reflect - reflect at boundary => Truncate - truncate at boundary => Replicate - repeat boundary pixel values =for bad Unlike the FFT routines, conv2d is able to process bad values. =cut #line 119 "Image2D.pm" #line 1060 "../../blib/lib/PDL/PP.pm" sub PDL::conv2d { my $opt; $opt = pop @_ if ref($_[$#_]) eq 'HASH'; die 'Usage: conv2d( a(m,n), kern(p,q), [o]b(m,n), {Options} )' if $#_<1 || $#_>2; my($x,$kern) = @_; my $c = $#_ == 2 ? $_[2] : $x->nullcreate; &PDL::_conv2d_int($x,$kern,$c, (!(defined $opt && exists $$opt{Boundary}))?0: (($$opt{Boundary} eq "Reflect") + 2*($$opt{Boundary} eq "Truncate") + 3*($$opt{Boundary} eq "Replicate"))); return $c; } #line 139 "Image2D.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *conv2d = \&PDL::conv2d; #line 145 "Image2D.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 med2d =for sig Signature: (a(m,n); kern(p,q); [o]b(m,n); int opt) =for ref 2D median-convolution of an array with a kernel (smoothing) Note: only points in the kernel E0 are included in the median, other points are weighted by the kernel value (medianing lots of zeroes is rather pointless) =for usage $new = med2d $old, $kernel, {OPTIONS} =for example $smoothed = med2d $image, ones(3,3), {Boundary => Reflect} =for options Boundary - controls what values are assumed for the image when kernel crosses its edge: => Default - periodic boundary conditions (i.e. wrap around axis) => Reflect - reflect at boundary => Truncate - truncate at boundary => Replicate - repeat boundary pixel values =for bad Bad values are ignored in the calculation. If all elements within the kernel are bad, the output is set bad. =cut #line 192 "Image2D.pm" #line 1060 "../../blib/lib/PDL/PP.pm" sub PDL::med2d { my $opt; $opt = pop @_ if ref($_[$#_]) eq 'HASH'; die 'Usage: med2d( a(m,n), kern(p,q), [o]b(m,n), {Options} )' if $#_<1 || $#_>2; my($x,$kern) = @_; croak "med2d: kernel must contain some positive elements.\n" if all( $kern <= 0 ); my $c = $#_ == 2 ? $_[2] : $x->nullcreate; &PDL::_med2d_int($x,$kern,$c, (!(defined $opt && exists $$opt{Boundary}))?0: (($$opt{Boundary} eq "Reflect") + 2*($$opt{Boundary} eq "Truncate") + 3*($$opt{Boundary} eq "Replicate"))); return $c; } #line 214 "Image2D.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *med2d = \&PDL::med2d; #line 220 "Image2D.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 med2df =for sig Signature: (a(m,n); [o]b(m,n); int __p_size; int __q_size; int opt) =for ref 2D median-convolution of an array in a pxq window (smoothing) Note: this routine does the median over all points in a rectangular window and is not quite as flexible as C in this regard but slightly faster instead =for usage $new = med2df $old, $xwidth, $ywidth, {OPTIONS} =for example $smoothed = med2df $image, 3, 3, {Boundary => Reflect} =for options Boundary - controls what values are assumed for the image when kernel crosses its edge: => Default - periodic boundary conditions (i.e. wrap around axis) => Reflect - reflect at boundary => Truncate - truncate at boundary => Replicate - repeat boundary pixel values =for bad med2df does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 268 "Image2D.pm" #line 1060 "../../blib/lib/PDL/PP.pm" sub PDL::med2df { my $opt; $opt = pop @_ if ref($_[$#_]) eq 'HASH'; die 'Usage: med2df( a(m,n), [o]b(m,n), p, q, {Options} )' if $#_<2 || $#_>3; my($x,$p,$q) = @_; croak "med2df: kernel must contain some positive elements.\n" if $p == 0 && $q == 0; my $c = $#_ == 3 ? $_[3] : $x->nullcreate; &PDL::_med2df_int($x,$c,$p,$q, (!(defined $opt && exists $$opt{Boundary}))?0: (($$opt{Boundary} eq "Reflect") + 2*($$opt{Boundary} eq "Truncate") + 3*($$opt{Boundary} eq "Replicate"))); return $c; } #line 290 "Image2D.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *med2df = \&PDL::med2df; #line 296 "Image2D.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 box2d =for sig Signature: (a(n,m); [o] b(n,m); int wx; int wy; int edgezero) =for ref fast 2D boxcar average =for example $smoothim = $im->box2d($wx,$wy,$edgezero=1); The edgezero argument controls if edge is set to zero (edgezero=1) or just keeps the original (unfiltered) values. C should be updated to support similar edge options as C and C etc. Boxcar averaging is a pretty crude way of filtering. For serious stuff better filters are around (e.g., use L with the appropriate kernel). On the other hand it is fast and computational cost grows only approximately linearly with window size. =for bad box2d does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 338 "Image2D.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *box2d = \&PDL::box2d; #line 344 "Image2D.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 patch2d =for sig Signature: (a(m,n); int bad(m,n); [o]b(m,n)) =for ref patch bad pixels out of 2D images using a mask =for usage $patched = patch2d $data, $bad; C<$bad> is a 2D mask array where 1=bad pixel 0=good pixel. Pixels are replaced by the average of their non-bad neighbours; if all neighbours are bad, the original data value is copied across. =for bad This routine does not handle bad values - use L instead =cut #line 378 "Image2D.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *patch2d = \&PDL::patch2d; #line 384 "Image2D.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 patchbad2d =for sig Signature: (a(m,n); [o]b(m,n)) =for ref patch bad pixels out of 2D images containing bad values =for usage $patched = patchbad2d $data; Pixels are replaced by the average of their non-bad neighbours; if all neighbours are bad, the output is set bad. If the input ndarray contains I bad values, then a straight copy is performed (see L). =for bad patchbad2d handles bad values. The output ndarray I contain bad values, depending on the pattern of bad values in the input ndarray. =cut #line 419 "Image2D.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *patchbad2d = \&PDL::patchbad2d; #line 425 "Image2D.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 max2d_ind =for sig Signature: (a(m,n); [o]val(); int [o]x(); int[o]y()) =for ref Return value/position of maximum value in 2D image Contributed by Tim Jeness =for bad Bad values are excluded from the search. If all pixels are bad then the output is set bad. =cut #line 455 "Image2D.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *max2d_ind = \&PDL::max2d_ind; #line 461 "Image2D.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 centroid2d =for sig Signature: (im(m,n); x(); y(); box(); [o]xcen(); [o]ycen()) =for ref Refine a list of object positions in 2D image by centroiding in a box C<$box> is the full-width of the box, i.e. the window is C<+/- $box/2>. =for bad Bad pixels are excluded from the centroid calculation. If all elements are bad (or the pixel sum is 0 - but why would you be centroiding something with negatives in...) then the output values are set bad. =cut #line 493 "Image2D.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *centroid2d = \&PDL::centroid2d; #line 499 "Image2D.pm" #line 941 "image2d.pd" =head2 cc8compt =for ref Connected 8-component labeling of a binary image. Connected 8-component labeling of 0,1 image - i.e. find separate segmented objects and fill object pixels with object number. 8-component labeling includes all neighboring pixels. This is just a front-end to ccNcompt. See also L. =for example $segmented = cc8compt( $image > $threshold ); =head2 cc4compt =for ref Connected 4-component labeling of a binary image. Connected 4-component labeling of 0,1 image - i.e. find separate segmented objects and fill object pixels with object number. 4-component labling does not include the diagonal neighbors. This is just a front-end to ccNcompt. See also L. =for example $segmented = cc4compt( $image > $threshold ); =cut sub PDL::cc8compt{ return ccNcompt(shift,8); } *cc8compt = \&PDL::cc8compt; sub PDL::cc4compt{ return ccNcompt(shift,4); } *cc4compt = \&PDL::cc4compt; #line 546 "Image2D.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 ccNcompt =for sig Signature: (a(m,n); int+ [o]b(m,n); int con) =for ref Connected component labeling of a binary image. Connected component labeling of 0,1 image - i.e. find separate segmented objects and fill object pixels with object number. See also L and L. The connectivity parameter must be 4 or 8. =for example $segmented = ccNcompt( $image > $threshold, 4); $segmented2 = ccNcompt( $image > $threshold, 8); where the second parameter specifies the connectivity (4 or 8) of the labeling. =for bad ccNcompt ignores the bad-value flag of the input ndarrays. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 588 "Image2D.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *ccNcompt = \&PDL::ccNcompt; #line 594 "Image2D.pm" #line 1110 "image2d.pd" =head2 polyfill =for ref fill the area of the given polygon with the given colour. This function works inplace, i.e. modifies C. =for usage polyfill($im,$ps,$colour,[\%options]); The default method of determining which points lie inside of the polygon used is not as strict as the method used in L. Often, it includes vertices and edge points. Set the C option to change this behaviour. =for option Method - Set the method used to determine which points lie in the polygon. => Default - internal PDL algorithm => pnpoly - use the L algorithm =for example # Make a convex 3x3 square of 1s in an image using the pnpoly algorithm $ps = pdl([3,3],[3,6],[6,6],[6,3]); polyfill($im,$ps,1,{'Method' =>'pnpoly'}); =cut sub PDL::polyfill { my $opt; $opt = pop @_ if ref($_[-1]) eq 'HASH'; barf('Usage: polyfill($im,$ps,$colour,[\%options])') unless @_==3; my ($im,$ps,$colour) = @_; if($opt) { use PDL::Options qw(); my $parsed = PDL::Options->new({'Method' => undef}); $parsed->options($opt); if( $parsed->current->{'Method'} eq 'pnpoly' ) { PDL::pnpolyfill_pp($im,$ps,$colour); } } else { PDL::polyfill_pp($im,$ps,$colour); } return $im; } *polyfill = \&PDL::polyfill; #line 651 "Image2D.pm" #line 1167 "image2d.pd" =head2 pnpoly =for ref 'points in a polygon' selection from a 2-D ndarray =for usage $mask = $img->pnpoly($ps); # Old style, do not use $mask = pnpoly($x, $y, $px, $py); For a closed polygon determined by the sequence of points in {$px,$py} the output of pnpoly is a mask corresponding to whether or not each coordinate (x,y) in the set of test points, {$x,$y}, is in the interior of the polygon. This is the 'points in a polygon' algorithm from L and vectorized for PDL by Karl Glazebrook. =for example # define a 3-sided polygon (a triangle) $ps = pdl([3, 3], [20, 20], [34, 3]); # $tri is 0 everywhere except for points in polygon interior $tri = $img->pnpoly($ps); With the second form, the x and y coordinates must also be specified. B< I >. $px = pdl( 3, 20, 34 ); $py = pdl( 3, 20, 3 ); $x = $img->xvals; # get x pixel coords $y = $img->yvals; # get y pixel coords # $tri is 0 everywhere except for points in polygon interior $tri = pnpoly($x,$y,$px,$py); =cut # From: http://www.ecse.rpi.edu/Homepages/wrf/Research/Short_Notes/pnpoly.html # # Fixes needed to pnpoly code: # # Use topdl() to ensure ndarray args # # Add POD docs for usage # # Calculate first term in & expression to use to fix divide-by-zero when # the test point is in line with a vertical edge of the polygon. # By adding the value of $mask we prevent a divide-by-zero since the & # operator does not "short circuit". sub PDL::pnpoly { barf('Usage: $mask = pnpoly($img, $ps);') unless(@_==2 || @_==4); my ($tx, $ty, $vertx, $verty) = @_; # if only two inputs, use the pure PP version unless( defined $vertx ) { barf("ps must contain pairwise points.\n") unless $ty->getdim(0) == 2; # Input mapping: $img => $tx, $ps => $ty return PDL::pnpoly_pp($tx,$ty); } my $testx = PDL::Core::topdl($tx)->dummy(0); my $testy = PDL::Core::topdl($ty)->dummy(0); my $vertxj = PDL::Core::topdl($vertx)->rotate(1); my $vertyj = PDL::Core::topdl($verty)->rotate(1); my $mask = ( ($verty>$testy) == ($vertyj>$testy) ); my $c = sumover( ! $mask & ( $testx < ($vertxj-$vertx) * ($testy-$verty) / ($vertyj-$verty+$mask) + $vertx) ) % 2; return $c; } *pnpoly = \&PDL::pnpoly; #line 734 "Image2D.pm" #line 1250 "image2d.pd" =head2 polyfillv =for ref return the (dataflowed) area of an image described by a polygon =for usage polyfillv($im,$ps,[\%options]); The default method of determining which points lie inside of the polygon used is not as strict as the method used in L. Often, it includes vertices and edge points. Set the C option to change this behaviour. =for option Method - Set the method used to determine which points lie in the polygon. => Default - internal PDL algorithm => pnpoly - use the L algorithm =for example # increment intensity in area bounded by $poly using the pnpoly algorithm $im->polyfillv($poly,{'Method'=>'pnpoly'})++; # legal in perl >= 5.6 # compute average intensity within area bounded by $poly using the default algorithm $av = $im->polyfillv($poly)->avg; =cut sub PDL::polyfillv :lvalue { my $opt; $opt = pop @_ if ref($_[-1]) eq 'HASH'; barf('Usage: polyfillv($im,$ps,[\%options])') unless @_==2; my ($im,$ps) = @_; barf("ps must contain pairwise points.\n") unless $ps->getdim(0) == 2; if($opt) { use PDL::Options qw(); my $parsed = PDL::Options->new({'Method' => undef}); $parsed->options($opt); return $im->where(PDL::pnpoly_pp($im, $ps)) if $parsed->current->{'Method'} eq 'pnpoly'; } my $msk = zeroes(long,$im->dims); PDL::polyfill_pp($msk, $ps, 1); return $im->where($msk); } *polyfillv = \&PDL::polyfillv; #line 790 "Image2D.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 rot2d =for sig Signature: (im(m,n); float angle(); bg(); int aa(); [o] om(p,q)) =for ref rotate an image by given C =for example # rotate by 10.5 degrees with antialiasing, set missing values to 7 $rot = $im->rot2d(10.5,7,1); This function rotates an image through an C between -90 and + 90 degrees. Uses/doesn't use antialiasing depending on the C flag. Pixels outside the rotated image are set to C. Code modified from pnmrotate (Copyright Jef Poskanzer) with an algorithm based on "A Fast Algorithm for General Raster Rotation" by Alan Paeth, Graphics Interface '86, pp. 77-81. Use the C function to find out about the dimension of the newly created image ($newcols,$newrows) = rotnewsz $oldn, $oldm, $angle; L offers a more general interface to distortions, including rotation, with various types of sampling; but rot2d is faster. =for bad rot2d ignores the bad-value flag of the input ndarrays. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 839 "Image2D.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *rot2d = \&PDL::rot2d; #line 845 "Image2D.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 bilin2d =for sig Signature: (Int(n,m); O(q,p)) =for ref Bilinearly maps the first ndarray in the second. The interpolated values are actually added to the second ndarray which is supposed to be larger than the first one. =for bad bilin2d ignores the bad-value flag of the input ndarrays. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 874 "Image2D.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *bilin2d = \&PDL::bilin2d; #line 880 "Image2D.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 rescale2d =for sig Signature: (Int(m,n); O(p,q)) =for ref The first ndarray is rescaled to the dimensions of the second (expanding or meaning values as needed) and then added to it in place. Nothing useful is returned. If you want photometric accuracy or automatic FITS header metadata tracking, consider using L instead: it does these things, at some speed penalty compared to rescale2d. =for bad rescale2d ignores the bad-value flag of the input ndarrays. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 914 "Image2D.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *rescale2d = \&PDL::rescale2d; #line 920 "Image2D.pm" #line 1570 "image2d.pd" =head2 fitwarp2d =for ref Find the best-fit 2D polynomial to describe a coordinate transformation. =for usage ( $px, $py ) = fitwarp2d( $x, $y, $u, $v, $nf, { options } ) Given a set of points in the output plane (C<$u,$v>), find the best-fit (using singular-value decomposition) 2D polynomial to describe the mapping back to the image plane (C<$x,$y>). The order of the fit is controlled by the C<$nf> parameter (the maximum power of the polynomial is C<$nf - 1>), and you can restrict the terms to fit using the C option. C<$px> and C<$py> are C by C element ndarrays which describe a polynomial mapping (of order C) from the I C<(u,v)> image to the I C<(x,y)> image: x = sum(j=0,np-1) sum(i=0,np-1) px(i,j) * u^i * v^j y = sum(j=0,np-1) sum(i=0,np-1) py(i,j) * u^i * v^j The transformation is returned for the reverse direction (ie output to input image) since that is what is required by the L routine. The L routine can be used to convert a set of C<$u,$v> points given C<$px> and C<$py>. Options: =for options FIT - which terms to fit? default ones(byte,$nf,$nf) =begin comment old option, caused trouble THRESH - in svd, remove terms smaller than THRESH * max value default is 1.0e-5 =end comment =over 4 =item FIT C allows you to restrict which terms of the polynomial to fit: only those terms for which the FIT ndarray evaluates to true will be evaluated. If a 2D ndarray is sent in, then it is used for the x and y polynomials; otherwise C<< $fit->slice(":,:,(0)") >> will be used for C<$px> and C<< $fit->slice(":,:,(1)") >> will be used for C<$py>. =begin comment =item THRESH Remove all singular values whose value is less than C times the largest singular value. =end comment =back The number of points must be at least equal to the number of terms to fit (C<$nf*$nf> points for the default value of C). =for example # points in original image $x = pdl( 0, 0, 100, 100 ); $y = pdl( 0, 100, 100, 0 ); # get warped to these positions $u = pdl( 10, 10, 90, 90 ); $v = pdl( 10, 90, 90, 10 ); # # shift of origin + scale x/y axis only $fit = byte( [ [1,1], [0,0] ], [ [1,0], [1,0] ] ); ( $px, $py ) = fitwarp2d( $x, $y, $u, $v, 2, { FIT => $fit } ); print "px = ${px}py = $py"; px = [ [-12.5 1.25] [ 0 0] ] py = [ [-12.5 0] [ 1.25 0] ] # # Compared to allowing all 4 terms ( $px, $py ) = fitwarp2d( $x, $y, $u, $v, 2 ); print "px = ${px}py = $py"; px = [ [ -12.5 1.25] [ 1.110223e-16 -1.1275703e-17] ] py = [ [ -12.5 1.6653345e-16] [ 1.25 -5.8546917e-18] ] # A higher-degree polynomial should not affect the answer much, but # will require more control points $x = $x->glue(0,pdl(50,12.5, 37.5, 12.5, 37.5)); $y = $y->glue(0,pdl(50,12.5, 37.5, 37.5, 12.5)); $u = $u->glue(0,pdl(73,20,40,20,40)); $v = $v->glue(0,pdl(29,20,40,40,20)); ( $px3, $py3 ) = fitwarp2d( $x, $y, $u, $v, 3 ); print "px3 =${px3}py3 =$py3"; px3 = [ [-6.4981162e+08 71034917 -726498.95] [ 49902244 -5415096.7 55945.388] [ -807778.46 88457.191 -902.51612] ] py3 = [ [-6.2732159e+08 68576392 -701354.77] [ 48175125 -5227679.8 54009.114] [ -779821.18 85395.681 -871.27997] ] #This illustrates an important point about singular value #decompositions that are used in fitwarp2d: like all SVDs, the #rotation matrices are not unique, and so the $px and $py returned #by fitwarp2d are not guaranteed to be the "simplest" solution. #They do still work, though: ($x3,$y3) = applywarp2d($px3,$py3,$u,$v); print approx $x3,$x,1e-4; [1 1 1 1 1 1 1 1 1] print approx $y3,$y; [1 1 1 1 1 1 1 1 1] =head2 applywarp2d =for ref Transform a set of points using a 2-D polynomial mapping =for usage ( $x, $y ) = applywarp2d( $px, $py, $u, $v ) Convert a set of points (stored in 1D ndarrays C<$u,$v>) to C<$x,$y> using the 2-D polynomial with coefficients stored in C<$px> and C<$py>. See L for more information on the format of C<$px> and C<$py>. =cut # use SVD to fit data. Assuming no errors. =pod =begin comment Some explanation of the following three subroutines (_svd, _mkbasis, and fitwarp2d): See Wolberg 1990 (full ref elsewhere in this documentation), Chapter 3.6 "Polynomial Transformations". The idea is that, given a set of control points in the input and output images denoted by coordinates (x,y) and (u,v), we want to create a polynomial transformation that relates u to linear combinations of powers of x and y, and another that relates v to powers of x and y. The transformations used here and by Wolberg differ slightly, but the basic idea is something like this. For each u and each v, define a transform: u = (sum over j) (sum over i) a_{ij} x**i * y**j , (eqn 1) v = (sum over j) (sum over i) b_{ij} x**i * y**j . (eqn 2) We can write this in matrix notation. Given that there are M control points, U is a column vector with M rows. A and B are vectors containing the N coefficients (related to the degree of the polynomial fit). W is an MxN matrix of the basis row-vectors (the x**i y**j). The matrix equations we are trying to solve are U = W A , (eqn 3) V = W B . (eqn 4) We need to find the A and B column vectors, those are the coefficients of the polynomial terms in W. W is not square, so it has no inverse. But is has a pseudo-inverse W^+ that is NxM. We are going to use that pseudo-inverse to isolate A and B, like so: W^+ U = W^+ W A = A (eqn 5) W^+ V = W^+ W B = B (eqn 6) We are going to get W^+ by performing a singular value decomposition of W (to use some of the variable names below): W = $svd_u x SIGMA x $svd_v->transpose (eqn 7) W^+ = $svd_v x SIGMA^+ x $svd_u->transpose . (eqn 8) Here SIGMA is a square diagonal matrix that contains the singular values of W that are in the variable $svd_w. SIGMA^+ is the pseudo-inverse of SIGMA, which is calculated by replacing the non-zero singular values with their reciprocals, and then taking the transpose of the matrix (which is a no-op since the matrix is square and diagonal). So the code below does this: _mkbasis computes the matrix W, given control coordinates u and v and the maximum degree of the polynomial (and the terms to use). _svd takes the svd of W, computes the pseudo-inverse of W, and then multiplies that with the U vector (there called $y). The output of _svd is the A or B vector in eqns 5 & 6 above. Rarely is the matrix multiplication explicit, unfortunately, so I have added EXPLANATIONs below. =end comment =cut sub _svd ($$) { my $basis = shift; my $y = shift; # my $thresh = shift; # if we had errors for these points, would normalise the # basis functions, and the output array, by these errors here # perform the SVD my ( $svd_u, $svd_w, $svd_v ) = svd( $basis ); # DAL, 09/2017: the reason for removing ANY singular values, much less #the smallest ones, is not clear. I commented the line below since this #actually removes the LARGEST values in SIGMA^+. # $svd_w *= ( $svd_w >= ($svd_w->max * $thresh ) ); # The line below would instead remove the SMALLEST values in SIGMA^+, but I can see no reason to include it either. # $svd_w *= ( $svd_w <= ($svd_w->min / $thresh ) ); # perform the back substitution # EXPLANATION: same thing as $svd_u->transpose x $y->transpose. my $tmp = $y x $svd_u; #EXPLANATION: the division by (the non-zero elements of) $svd_w (the singular values) is #equivalent to $sigma_plus x $tmp, so $tmp is now SIGMA^+ x $svd_u x $y $tmp /= $svd_w->setvaltobad(0.0); $tmp->inplace->setbadtoval(0.0); #EXPLANATION: $svd_v x SIGMA^+ x $svd_u x $y return sumover( $svd_v * $tmp ); } # sub: _svd() #_mkbasis returns an ndarray in which the k(=j*n+i)_th column is v**j * u**i #k=0 j=0 i=0 #k=1 j=0 i=1 #k=2 j=0 i=2 #k=3 j=1 i=0 # ... #each row corresponds to a control point #and the rows for each of the control points look like this, e.g.: # (1) (u) (u**2) (v) (vu) (v(u**2)) (v**2) ((v**2)u) ((v**2)(u**2)) # and so on for the next control point. sub _mkbasis ($$$$) { my $fit = shift; my $npts = shift; my $u = shift; my $v = shift; my $n = $fit->getdim(0) - 1; my $ncoeff = sum( $fit ); my $basis = zeroes( $u->type, $ncoeff, $npts ); my $k = 0; foreach my $j ( 0 .. $n ) { my $tmp_v = $v**$j; foreach my $i ( 0 .. $n ) { if ( $fit->at($i,$j) ) { my $tmp = $basis->slice("($k),:"); $tmp .= $tmp_v * $u**$i; $k++; } } } return $basis; } # sub: _mkbasis() sub PDL::fitwarp2d { croak "Usage: (\$px,\$py) = fitwarp2d(x(m);y(m);u(m);v(m);\$nf; { options })" if $#_ < 4 or ( $#_ >= 5 and ref($_[5]) ne "HASH" ); my $x = shift; my $y = shift; my $u = shift; my $v = shift; my $nf = shift; my $opts = PDL::Options->new( { FIT => ones(byte,$nf,$nf) } ); #, THRESH => 1.0e-5 } ); $opts->options( $_[0] ) if $#_ > -1; my $oref = $opts->current(); # safety checks my $npts = $x->nelem; croak "fitwarp2d: x, y, u, and v must be the same size (and 1D)" unless $npts == $y->nelem and $npts == $u->nelem and $npts == $v->nelem and $x->getndims == 1 and $y->getndims == 1 and $u->getndims == 1 and $v->getndims == 1; # my $svd_thresh = $$oref{THRESH}; # croak "fitwarp2d: THRESH option must be >= 0." # if $svd_thresh < 0; my $fit = $$oref{FIT}; my $fit_ndim = $fit->getndims(); croak "fitwarp2d: FIT option must be sent a (\$nf,\$nf[,2]) element ndarray" unless UNIVERSAL::isa($fit,"PDL") and ($fit_ndim == 2 or ($fit_ndim == 3 and $fit->getdim(2) == 2)) and $fit->getdim(0) == $nf and $fit->getdim(1) == $nf; # how many coeffs to fit (first we ensure $fit is either 0 or 1) $fit = convert( $fit != 0, byte ); my ( $fitx, $fity, $ncoeffx, $ncoeffy, $ncoeff ); if ( $fit_ndim == 2 ) { $fitx = $fit; $fity = $fit; $ncoeff = $ncoeffx = $ncoeffy = sum( $fit ); } else { $fitx = $fit->slice(",,(0)"); $fity = $fit->slice(",,(1)"); $ncoeffx = sum($fitx); $ncoeffy = sum($fity); $ncoeff = $ncoeffx > $ncoeffy ? $ncoeffx : $ncoeffy; } croak "fitwarp2d: number of points ($npts) must be >= \$ncoeff ($ncoeff)" unless $npts >= $ncoeff; # create the basis functions for the SVD fitting my ( $basisx, $basisy ); $basisx = _mkbasis( $fitx, $npts, $u, $v ); if ( $fit_ndim == 2 ) { $basisy = $basisx; } else { $basisy = _mkbasis( $fity, $npts, $u, $v ); } my $px = _svd( $basisx, $x ); # $svd_thresh); my $py = _svd( $basisy, $y ); # $svd_thresh); # convert into $nf x $nf element ndarrays, if necessary my $nf2 = $nf * $nf; return ( $px->reshape($nf,$nf), $py->reshape($nf,$nf) ) if $ncoeff == $nf2 and $ncoeffx == $ncoeffy; # re-create the matrix my $xtmp = zeroes( $nf, $nf ); my $ytmp = zeroes( $nf, $nf ); my $kx = 0; my $ky = 0; foreach my $i ( 0 .. ($nf - 1) ) { foreach my $j ( 0 .. ($nf - 1) ) { if ( $fitx->at($i,$j) ) { $xtmp->set($i,$j, $px->at($kx) ); $kx++; } if ( $fity->at($i,$j) ) { $ytmp->set($i,$j, $py->at($ky) ); $ky++; } } } return ( $xtmp, $ytmp ) } # sub: fitwarp2d *fitwarp2d = \&PDL::fitwarp2d; sub PDL::applywarp2d { # checks croak "Usage: (\$x,\$y) = applywarp2d(px(nf,nf);py(nf,nf);u(m);v(m);)" if $#_ != 3; my $px = shift; my $py = shift; my $u = shift; my $v = shift; my $npts = $u->nelem; # safety check croak "applywarp2d: u and v must be the same size (and 1D)" unless $npts == $u->nelem and $npts == $v->nelem and $u->getndims == 1 and $v->getndims == 1; my $nf = $px->getdim(0); my $nf2 = $nf * $nf; # could remove terms with 0 coeff here # (would also have to remove them from px/py for # the matrix multiplication below) # my $mat = _mkbasis( ones(byte,$nf,$nf), $npts, $u, $v ); my $x = reshape( $mat x $px->clump(-1)->transpose(), $npts ); my $y = reshape( $mat x $py->clump(-1)->transpose(), $npts ); return ( $x, $y ); } # sub: applywarp2d *applywarp2d = \&PDL::applywarp2d; #line 1348 "Image2D.pm" #line 2005 "image2d.pd" =head2 warp2d =for sig Signature: (img(m,n); double px(np,np); double py(np,np); [o] warp(m,n); { options }) =for ref Warp a 2D image given a polynomial describing the I mapping. =for usage $out = warp2d( $img, $px, $py, { options } ); Apply the polynomial transformation encoded in the C<$px> and C<$py> ndarrays to warp the input image C<$img> into the output image C<$out>. The format for the polynomial transformation is described in the documentation for the L routine. At each point C, the closest 16 pixel values are combined with an interpolation kernel to calculate the value at C. The interpolation is therefore done in the image, rather than Fourier, domain. By default, a C kernel is used, but this can be changed using the C option discussed below (the choice of kernel depends on the frequency content of the input image). The routine is based on the C command from the Eclipse data-reduction package - see http://www.eso.org/eclipse/ - and for further details on image resampling see Wolberg, G., "Digital Image Warping", 1990, IEEE Computer Society Press ISBN 0-8186-8944-7). Currently the output image is the same size as the input one, which means data will be lost if the transformation reduces the pixel scale. This will (hopefully) be changed soon. =for example $img = rvals(byte,501,501); imag $img, { JUSTIFY => 1 }; # # use a not-particularly-obvious transformation: # x = -10 + 0.5 * $u - 0.1 * $v # y = -20 + $v - 0.002 * $u * $v # $px = pdl( [ -10, 0.5 ], [ -0.1, 0 ] ); $py = pdl( [ -20, 0 ], [ 1, 0.002 ] ); $wrp = warp2d( $img, $px, $py ); # # see the warped image imag $warp, { JUSTIFY => 1 }; The options are: =for options KERNEL - default value is tanh NOVAL - default value is 0 C is used to specify which interpolation kernel to use (to see what these kernels look like, use the L routine). The options are: =over 4 =item tanh Hyperbolic tangent: the approximation of an ideal box filter by the product of symmetric tanh functions. =item sinc For a correctly sampled signal, the ideal filter in the fourier domain is a rectangle, which produces a C interpolation kernel in the spatial domain: sinc(x) = sin(pi * x) / (pi * x) However, it is not ideal for the C<4x4> pixel region used here. =item sinc2 This is the square of the sinc function. =item lanczos Although defined differently to the C kernel, the result is very similar in the spatial domain. The Lanczos function is defined as L(x) = sinc(x) * sinc(x/2) if abs(x) < 2 = 0 otherwise =item hann This kernel is derived from the following function: H(x) = a + (1-a) * cos(2*pi*x/(N-1)) if abs(x) < 0.5*(N-1) = 0 otherwise with C and N currently equal to 2001. =item hamming This kernel uses the same C as the Hann filter, but with C. =back C gives the value used to indicate that a pixel in the output image does not map onto one in the input image. =cut # support routine { my %warp2d = map { ($_,1) } qw( tanh sinc sinc2 lanczos hamming hann ); # note: convert to lower case sub _check_kernel ($$) { my $kernel = lc shift; my $code = shift; barf "Unknown kernel $kernel sent to $code\n" . "\tmust be one of [" . join(',',keys %warp2d) . "]\n" unless exists $warp2d{$kernel}; return $kernel; } } #line 1484 "Image2D.pm" #line 1060 "../../blib/lib/PDL/PP.pm" sub PDL::warp2d { my $opts = PDL::Options->new( { KERNEL => "tanh", NOVAL => 0 } ); $opts->options( pop(@_) ) if ref($_[$#_]) eq "HASH"; die "Usage: warp2d( in(m,n), px(np,np); py(np,np); [o] out(m,n), {Options} )" if $#_<2 || $#_>3; my $img = shift; my $px = shift; my $py = shift; my $out = $#_ == -1 ? PDL->null() : shift; # safety checks my $copt = $opts->current(); my $kernel = _check_kernel( $$copt{KERNEL}, "warp2d" ); &PDL::_warp2d_int( $img, $px, $py, $out, $kernel, $$copt{NOVAL} ); return $out; } #line 1509 "Image2D.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *warp2d = \&PDL::warp2d; #line 1515 "Image2D.pm" #line 2319 "image2d.pd" =head2 warp2d_kernel =for ref Return the specified kernel, as used by L =for usage ( $x, $k ) = warp2d_kernel( $name ) The valid values for C<$name> are the same as the C option of L. =for example line warp2d_kernel( "hamming" ); =cut #line 1540 "Image2D.pm" #line 1060 "../../blib/lib/PDL/PP.pm" sub PDL::warp2d_kernel ($) { my $kernel = _check_kernel( shift, "warp2d_kernel" ); my $nelem = _get_kernel_size(); my $x = zeroes( $nelem ); my $k = zeroes( $nelem ); &PDL::_warp2d_kernel_int( $x, $k, $kernel ); return ( $x, $k ); # return _get_kernel( $kernel ); } *warp2d_kernel = \&PDL::warp2d_kernel; #line 1560 "Image2D.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *warp2d_kernel = \&PDL::warp2d_kernel; #line 1566 "Image2D.pm" #line 30 "image2d.pd" =head1 AUTHORS Copyright (C) Karl Glazebrook 1997 with additions by Robin Williams (rjrw@ast.leeds.ac.uk), Tim Jeness (timj@jach.hawaii.edu), and Doug Burke (burke@ifa.hawaii.edu). 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 #line 1587 "Image2D.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/FFT.pm0000644000175000017500000002422014200406311014754 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::FFT; our @EXPORT_OK = qw(fft ifft fftnd ifftnd fftconvolve realfft realifft kernctr ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::FFT ; #line 7 "fft.pd" =head1 NAME PDL::FFT - FFTs for PDL =head1 DESCRIPTION !!!!!!!!!!!!!!!!!!!!!!!!!!WARNING!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! As of PDL-2.006_04, the direction of the FFT/IFFT has been reversed to match the usage in the FFTW library and the convention in use generally. !!!!!!!!!!!!!!!!!!!!!!!!!!WARNING!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! FFTs for PDL. These work for arrays of any dimension, although ones with small prime factors are likely to be the quickest. The forward FFT is unnormalized while the inverse FFT is normalized so that the IFFT of the FFT returns the original values. For historical reasons, these routines work in-place and do not recognize the in-place flag. That should be fixed. =head1 SYNOPSIS use PDL::FFT qw/:Func/; fft($real, $imag); ifft($real, $imag); realfft($real); realifft($real); fftnd($real,$imag); ifftnd($real,$imag); $kernel = kernctr($image,$smallk); fftconvolve($image,$kernel); =head1 DATA TYPES The underlying C library upon which this module is based performs FFTs on both single precision and double precision floating point ndarrays. The PP functions are defined to only take those data types. Therefore, if you pass in an ndarray of integer datatype (byte, short, ushort, long) to any of the routines in PDL::FFT, your data will be promoted to a double-precision ndarray. If you pass in a float, the single-precision FFT will be performed. =head1 FREQUENCIES For even-sized input arrays, the frequencies are packed like normal for FFTs (where N is the size of the array and D is the physical step size between elements): 0, 1/ND, 2/ND, ..., (N/2-1)/ND, 1/2D, -(N/2-1)/ND, ..., -1/ND. which can easily be obtained (taking the Nyquist frequency to be positive) using C<< $kx = $real->xlinvals(-($N/2-1)/$N/$D,1/2/$D)->rotate(-($N/2 -1)); >> For odd-sized input arrays the Nyquist frequency is not directly acessible, and the frequencies are 0, 1/ND, 2/ND, ..., (N/2-0.5)/ND, -(N/2-0.5)/ND, ..., -1/ND. which can easily be obtained using C<< $kx = $real->xlinvals(-($N/2-0.5)/$N/$D,($N/2-0.5)/$N/$D)->rotate(-($N-1)/2); >> =head1 ALTERNATIVE FFT PACKAGES Various other modules - such as L and L - contain FFT routines. However, unlike PDL::FFT, these modules are optional, and so may not be installed. =cut #line 102 "FFT.pm" =head1 FUNCTIONS =cut #line 1059 "../../blib/lib/PDL/PP.pm" =head2 fft =for sig Signature: ([io]real(n); [io]imag(n)) =for ref Complex 1-D FFT of the "real" and "imag" arrays [inplace]. A single cfloat/cdouble input ndarray can also be used. =for usage fft($real,$imag); fft($complex); =for bad fft does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 143 "FFT.pm" #line 1060 "../../blib/lib/PDL/PP.pm" sub PDL::fft { # Convert the first argument to decimal and check for trouble. my ($re, $im) = @_; if (!$re->type->real) { $im=$re->im; $re=$re->re; } eval { todecimal($re); }; if ($@) { $@ =~ s/ at .*//s; barf("Error in FFT with first argument: $@"); } # Convert the second argument to decimal and check for trouble. eval { todecimal($im); }; if ($@) { $@ =~ s/ at .*//s; my $message = "Error in FFT with second argument: $@"; $message .= '. Did you forget to supply the second (imaginary) ndarray?' if ($message =~ /undefined value/); barf($message); } PDL::_fft_int($re,$im); if (!$_[0]->type->real) { $_[0]= czip($re, $im); } else { $_[0]=$re,$_[1]=$im; } } #line 176 "FFT.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *fft = \&PDL::fft; #line 182 "FFT.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 ifft =for sig Signature: ([io]real(n); [io]imag(n)) =for ref Complex inverse 1-D FFT of the "real" and "imag" arrays [inplace]. A single cfloat/cdouble input ndarray can also be used. =for usage ifft($real,$imag); ifft($complex); =for bad ifft does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 213 "FFT.pm" #line 1060 "../../blib/lib/PDL/PP.pm" sub PDL::ifft { # Convert the first argument to decimal and check for trouble. my ($re, $im) = @_; if (!$re->type->real) { $im=$re->im; $re=$re->re; } eval { todecimal($re); }; if ($@) { $@ =~ s/ at .*//s; barf("Error in FFT with first argument: $@"); } # Convert the second argument to decimal and check for trouble. eval { todecimal($im); }; if ($@) { $@ =~ s/ at .*//s; my $message = "Error in FFT with second argument: $@"; $message .= '. Did you forget to supply the second (imaginary) ndarray?' if ($message =~ /undefined value/); barf($message); } PDL::_ifft_int($re,$im); if (!$_[0]->type->real) { $_[0]= czip($re, $im); } else { $_[0]=$re,$_[1]=$im; } } #line 246 "FFT.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *ifft = \&PDL::ifft; #line 252 "FFT.pm" #line 186 "fft.pd" use Carp; use PDL::Core qw/:Func/; use PDL::Basic qw/:Func/; use PDL::Types; use PDL::ImageND qw/kernctr/; # moved to ImageND since FFTW uses it too use PDL::Ops qw/czip/; sub todecimal { my ($arg) = @_; $arg = $arg->double if $arg->type->integer; $_[0] = $arg; 1;} =head2 realfft() =for ref One-dimensional FFT of real function [inplace]. The real part of the transform ends up in the first half of the array and the imaginary part of the transform ends up in the second half of the array. =for usage realfft($real); =cut *realfft = \&PDL::realfft; sub PDL::realfft { barf("Usage: realfft(real(*)") if $#_ != 0; my ($x) = @_; todecimal($x); # FIX: could eliminate $y my ($y) = 0*$x; fft($x,$y); my ($n) = int((($x->dims)[0]-1)/2); my($t); ($t=$x->slice("-$n:-1")) .= $y->slice("1:$n"); undef; } =head2 realifft() =for ref Inverse of one-dimensional realfft routine [inplace]. =for usage realifft($real); =cut *realifft = \&PDL::realifft; sub PDL::realifft { use PDL::Ufunc 'max'; barf("Usage: realifft(xfm(*)") if $#_ != 0; my ($x) = @_; todecimal($x); my ($n) = int((($x->dims)[0]-1)/2); my($t); # FIX: could eliminate $y my ($y) = 0*$x; ($t=$y->slice("1:$n")) .= $x->slice("-$n:-1"); ($t=$x->slice("-$n:-1")) .= $x->slice("$n:1"); ($t=$y->slice("-$n:-1")) .= -$y->slice("$n:1"); ifft($x,$y); # Sanity check -- shouldn't happen carp "Bad inverse transform in realifft" if max(abs($y)) > 1e-6*max(abs($x)); undef; } =head2 fftnd() =for ref N-dimensional FFT over all pdl dims of input (inplace) =for example fftnd($real,$imag); =cut *fftnd = \&PDL::fftnd; sub PDL::fftnd { my ($r,$i) = @_; barf "Must have real and imaginary parts or complex for fftnd" if $r->type->real and @_ != 2; if (!$r->type->real) { $i=$r->im; $r=$r->re; } my ($n) = $r->getndims; barf "Dimensions of real and imag must be the same for fft" if ($n != $i->getndims); $n--; todecimal($r); todecimal($i); # need the copy in case $r and $i point to same memory $i = $i->copy; foreach (0..$n) { fft($r,$i); $r = $r->mv(0,$n); $i = $i->mv(0,$n); } if (!$_[0]->type->real) { $_[0]= czip($r, $i); } else { $_[0] = $r; $_[1] = $i; } undef; } =head2 ifftnd() =for ref N-dimensional inverse FFT over all pdl dims of input (inplace) =for example ifftnd($real,$imag); =cut *ifftnd = \&PDL::ifftnd; sub PDL::ifftnd { my ($r,$i) = @_; barf "Must have real and imaginary parts or complex for ifftnd" if $r->type->real and @_ != 2; if (!$r->type->real) { $i=$r->im; $r=$r->re; } my ($n) = $r->getndims; barf "Dimensions of real and imag must be the same for ifft" if ($n != $i->getndims); todecimal($r); todecimal($i); # need the copy in case $r and $i point to same memory $i = $i->copy; $n--; foreach (0..$n) { ifft($r,$i); $r = $r->mv(0,$n); $i = $i->mv(0,$n); } if (!$_[0]->type->real) { $_[0]= czip($r, $i); } else { $_[0] = $r; $_[1] = $i; } undef; } =head2 fftconvolve() =for ref N-dimensional convolution with periodic boundaries (FFT method) =for usage $kernel = kernctr($image,$smallk); fftconvolve($image,$kernel); fftconvolve works inplace, and returns an error array in kernel as an accuracy check -- all the values in it should be negligible. See also L, which performs speed-optimized convolution with a variety of boundary conditions. The sizes of the image and the kernel must be the same. L centres a small kernel to emulate the behaviour of the direct convolution routines. The speed cross-over between using straight convolution (L) and these fft routines is for kernel sizes roughly 7x7. =cut *fftconvolve = \&PDL::fftconvolve; sub PDL::fftconvolve { barf "Must have image & kernel for fftconvolve" if $#_ != 1; my ($im, $k) = map $_->r2C, @_; fftnd($im); fftnd($k); my $c = $im * $k; ifftnd($c); $_[0] = $c->re->sever; $_[1] = $c->im->sever; @_; } #line 457 "FFT.pm" #line 389 "fft.pd" =head1 BUGS Where the source is marked `FIX', could re-implement using phase-shift factors on the transforms and some real-space bookkeeping, to save some temporary space and redundant transforms. =head1 AUTHOR This file copyright (C) 1997, 1998 R.J.R. Williams (rjrw@ast.leeds.ac.uk), Karl Glazebrook (kgb@aaoepp.aao.gov.au), Tuomas J. Lukka, (lukka@husc.harvard.edu). 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 #line 481 "FFT.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GIS/0000755000175000017500000000000014200406311014421 5ustar osboxesosboxesPDL-2.074/GENERATED/PDL/GIS/Proj.pm0000644000175000017500000001220314200406311015667 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GIS::Proj; our @EXPORT_OK = qw( get_proj_info fwd_transform inv_transform load_projection_descriptions proj_version load_projection_information ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GIS::Proj ; #line 20 "Proj.pd" use strict; use warnings; =head1 NAME PDL::GIS::Proj - PDL interface to the PROJ projection library. =head1 DESCRIPTION For more information on the PROJ library, see: L #line 36 "Proj.pm" =head1 FUNCTIONS =cut #line 65 "Proj.pd" =head2 get_proj_info($params_string) Returns a string with information about what parameters proj will actually use, this includes defaults, and +init=file stuff. It's the same as running 'proj -v'. It uses the proj command line, so it might not work with all shells. I've tested it with bash. =cut sub get_proj_info { my $params = shift; my @a = split(/\n/, `echo | proj -v $params`); pop(@a); return join("\n", @a); } # End of get_proj_info()... #line 67 "Proj.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 fwd_transform =for sig Signature: (lonlat(n=2); [o] xy(n); char* params) =for ref PROJ forward transformation $params is a string of the projection transformation parameters. Returns a pdl with x, y values at positions 0, 1. The units are dependent on PROJ behavior. They will be PDL->null if an error has occurred. =for bad Ignores bad elements of $lat and $lon, and sets the corresponding elements of $x and $y to BAD =for bad fwd_transform processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 101 "Proj.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *fwd_transform = \&PDL::fwd_transform; #line 107 "Proj.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 inv_transform =for sig Signature: (xy(n=2); [o] lonlat(n); char* params) =for ref PROJ inverse transformation $params is a string of the projection transformation parameters. Returns a pdl with lon, lat values at positions 0, 1. The units are dependent on PROJ behavior. They will be PDL->null if an error has occurred. =for bad Ignores bad elements of $lat and $lon, and sets the corresponding elements of $x and $y to BAD =for bad inv_transform processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 142 "Proj.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *inv_transform = \&PDL::inv_transform; #line 148 "Proj.pm" #line 221 "Proj.pd" =head2 proj_version Returns a 3-element list with PROJ major, minor, patch version-numbers. =cut my %SKIP = map +($_=>1), qw( and or Special for Madagascar fixed Earth For CH1903 ); sub load_projection_information { my $descriptions = PDL::GIS::Proj::load_projection_descriptions(); my $info = {}; foreach my $projection ( sort keys %$descriptions ) { my $description = $descriptions->{$projection}; my $hash = {CODE => $projection}; my @lines = split( /\n/, $description ); chomp @lines; # Full name of this projection: ($hash->{NAME}, my $temp) = splice @lines, 0, 2; if ($temp) { # The second line is usually a list of projection types this one is: $temp =~ s/no inv\.*,*//; $temp =~ s/or//; my @temp_types = split(/[,&\s]/, $temp ); my @types = grep( /.+/, @temp_types ); $hash->{CATEGORIES} = \@types; } # If there's more than 2 lines, then it usually is a listing of parameters: # General parameters for all projections: $hash->{PARAMS}->{GENERAL} = [ qw( x_0 y_0 lon_0 units init no_defs geoc over ) ]; # Earth Figure Parameters: $hash->{PARAMS}->{EARTH} = [ qw( ellps b f rf e es R R_A R_V R_a R_g R_h R_lat_g ) ]; # Projection Specific Parameters: $hash->{PARAMS}{PROJ} = [ grep !$SKIP{$_}, map {s/=//; s/[,\[\]]//sg; $_} grep length, map split(/\s+/), @lines ]; # Can this projection do inverse? $hash->{INVERSE} = ( $description =~ /no inv/ ) ? 0 : 1; $info->{$projection} = $hash; } # A couple of overrides: # $info->{ob_tran}{PARAMS}{PROJ} = [ 'o_proj', 'o_lat_p', 'o_lon_p', 'o_alpha', 'o_lon_c', 'o_lat_c', 'o_lon_1', 'o_lat_1', 'o_lon_2', 'o_lat_2' ]; $info->{nzmg}{CATEGORIES} = [ 'fixed Earth' ]; return $info; } # End of load_projection_information()... #line 209 "Proj.pm" #line 33 "Proj.pd" =head1 AUTHOR Judd Taylor, Orbital Systems, Ltd. judd dot t at orbitalsystems dot com =head1 COPYRIGHT NOTICE Copyright 2003 Judd Taylor, USF Institute for Marine Remote Sensing (judd@marine.usf.edu). GPL Now! This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. =cut #line 232 "Proj.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/Bad.pm0000644000175000017500000004460614200406302015035 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::Bad; our @EXPORT_OK = qw(badflag check_badflag badvalue orig_badvalue nbad nbadover ngood ngoodover setbadat isbad isgood nbadover ngoodover setbadif setvaltobad setnantobad setinftobad setnonfinitetobad setbadtonan setbadtoval copybad locf ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Bad ; #line 21 "bad.pd" =head1 NAME PDL::Bad - PDL always processes bad values =head1 DESCRIPTION This module is loaded when you do C, C or C. Implementation details are given in L. =head1 SYNOPSIS use PDL::Bad; print "\nBad value per PDL support in PDL is turned " . $PDL::Bad::PerPdl ? "on" : "off" . ".\n"; =head1 VARIABLES =over 4 =item $PDL::Bad::UseNaN Set to 0 as of PDL 2.040, as no longer available, though NaN can be used as a badvalue for a given PDL object. =item $PDL::Bad::PerPdl Set to 1 as of PDL 2.040 as always available. =item $PDL::Bad::Status Set to 1 as of PDL 2.035 as always available. =back =cut #line 65 "Bad.pm" =head1 FUNCTIONS =cut #line 64 "bad.pd" # really should be constants $PDL::Bad::Status = 1; $PDL::Bad::UseNaN = 0; $PDL::Bad::PerPdl = 1; use strict; use PDL::Types; use PDL::Primitive; ############################################################ ############################################################ #line 93 "Bad.pm" #line 115 "bad.pd" ############################################################ ############################################################ *badflag = \&PDL::badflag; *badvalue = \&PDL::badvalue; *orig_badvalue = \&PDL::orig_badvalue; ############################################################ ############################################################ =head2 badflag =for ref getter/setter for the bad data flag =for example if ( $x->badflag() ) { print "Data may contain bad values.\n"; } $x->badflag(1); # set bad data flag $x->badflag(0); # unset bad data flag When called as a setter, this modifies the ndarray on which it is called. This always returns a Perl scalar with the final value of the bad flag. A return value of 1 does not guarantee the presence of bad data in an ndarray; all it does is say that we need to I for the presence of such beasties. To actually find out if there are any bad values present in an ndarray, use the L method. =for bad This function works with ndarrays that have bad values. It always returns a Perl scalar, so it never returns bad values. =head2 badvalue =for ref returns the value used to indicate a missing (or bad) element for the given ndarray type. You can give it an ndarray, a PDL::Type object, or one of C<$PDL_B>, C<$PDL_S>, etc. =for example $badval = badvalue( float ); $x = ones(ushort,10); print "The bad data value for ushort is: ", $x->badvalue(), "\n"; This can act as a setter (e.g. C<< $x->badvalue(23) >>), including with the value C for floating-point types. Note that this B. That is, if C<$x> already has bad values, they will not be changed to use the given number and if any elements of C<$x> have that value, they will unceremoniously be marked as bad data. See L, L, and L for ways to actually modify the data in ndarrays It is possible to change the bad value on a per-ndarray basis, so $x = sequence (10); $x->badvalue (3); $x->badflag (1); $y = sequence (10); $y->badvalue (4); $y->badflag (1); will set $x to be C<[0 1 2 BAD 4 5 6 7 8 9]> and $y to be C<[0 1 2 3 BAD 5 6 7 8 9]>. =for bad This method does not care if you call it on an input ndarray that has bad values. It always returns a Perl scalar with the current or new bad value. =head2 orig_badvalue =for ref returns the original value used to represent bad values for a given type. This routine operates the same as L, except you can not change the values. It also has an I name. =for example $orig_badval = orig_badvalue( float ); $x = ones(ushort,10); print "The original bad data value for ushort is: ", $x->orig_badvalue(), "\n"; =for bad This method does not care if you call it on an input ndarray that has bad values. It always returns a Perl scalar with the original bad value for the associated type. =head2 check_badflag =for ref Clear the bad-value flag of an ndarray if it does not contain any bad values Given an ndarray whose bad flag is set, check whether it actually contains any bad values and, if not, clear the flag. It returns the final state of the bad-value flag. =for example print "State of bad flag == ", $pdl->check_badflag; =for bad This method accepts ndarrays with or without bad values. It returns an ndarray with the final bad-value. =cut *check_badflag = \&PDL::check_badflag; sub PDL::check_badflag { my $pdl = shift; $pdl->badflag(0) if $pdl->badflag and $pdl->nbad == 0; return $pdl->badflag; } # sub: check_badflag() #line 231 "Bad.pm" #line 326 "bad.pd" # note: # if sent an ndarray, we have to change its bad values # (but only if it contains bad values) # - there's a slight overhead in that the badflag is # cleared and then set (hence propagating to all # children) but we'll ignore that) # - we can ignore this for float/double types # since we can't change the bad value # sub PDL::badvalue { no strict 'refs'; my ( $self, $val ) = @_; my $num; if ( UNIVERSAL::isa($self,"PDL") ) { $num = $self->get_datatype; if ( $num < $PDL_F && defined($val) && $self->badflag ) { $self->inplace->setbadtoval( $val ); $self->badflag(1); } return PDL::_badvalue_per_pdl_int($self, $val, $num); } elsif ( UNIVERSAL::isa($self,"PDL::Type") ) { $num = $self->enum; } else { # assume it's a number $num = $self; } PDL::_badvalue_int( $val, $num ); } sub PDL::orig_badvalue { no strict 'refs'; my $self = shift; my $num; if ( UNIVERSAL::isa($self,"PDL") ) { $num = $self->get_datatype; } elsif ( UNIVERSAL::isa($self,"PDL::Type") ) { $num = $self->enum; } else { # assume it's a number $num = $self; } PDL::_default_badvalue_int($num); } ############################################################ ############################################################ #line 283 "Bad.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 isbad =for sig Signature: (a(); int [o]b()) =for ref Returns a binary mask indicating which values of the input are bad values Returns a 1 if the value is bad, 0 otherwise. Similar to L. =for example $x = pdl(1,2,3); $x->badflag(1); set($x,1,$x->badvalue); $y = isbad($x); print $y, "\n"; [0 1 0] =for bad This method works with input ndarrays that are bad. The output ndarray will never contain bad values, but its bad value flag will be the same as the input ndarray's flag. =cut #line 322 "Bad.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *isbad = \&PDL::isbad; #line 328 "Bad.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 isgood =for sig Signature: (a(); int [o]b()) =for ref Is a value good? Returns a 1 if the value is good, 0 otherwise. Also see L. =for example $x = pdl(1,2,3); $x->badflag(1); set($x,1,$x->badvalue); $y = isgood($x); print $y, "\n"; [1 0 1] =for bad This method works with input ndarrays that are bad. The output ndarray will never contain bad values, but its bad value flag will be the same as the input ndarray's flag. =cut #line 366 "Bad.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *isgood = \&PDL::isgood; #line 372 "Bad.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 nbadover =for sig Signature: (a(n); indx [o] b()) =for ref Find the number of bad elements along the 1st dimension. This function reduces the dimensionality of an ndarray by one by finding the number of bad elements along the 1st dimension. In this sense it shares much in common with the functions defined in L. In particular, by using L and similar dimension rearranging methods, it is possible to perform this calculation over I dimension. =for usage $x = nbadover($y); =for example $spectrum = nbadover $image->transpose =for bad nbadover processes input values that are bad. The output ndarray will not have any bad values, but the bad flag will be set if the input ndarray had its bad flag set. =cut #line 412 "Bad.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *nbadover = \&PDL::nbadover; #line 418 "Bad.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 ngoodover =for sig Signature: (a(n); indx [o] b()) =for ref Find the number of good elements along the 1st dimension. This function reduces the dimensionality of an ndarray by one by finding the number of good elements along the 1st dimension. By using L etc. it is possible to use I dimension. =for usage $x = ngoodover($y); =for example $spectrum = ngoodover $image->transpose =for bad ngoodover processes input values that are bad. The output ndarray will not have any bad values, but the bad flag will be set if the input ndarray had its bad flag set. =cut #line 459 "Bad.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *ngoodover = \&PDL::ngoodover; #line 465 "Bad.pm" #line 561 "bad.pd" *nbad = \&PDL::nbad; sub PDL::nbad { my($x) = @_; my $tmp; $x->clump(-1)->nbadover($tmp=PDL->nullcreate($x) ); return $tmp; } #line 477 "Bad.pm" #line 561 "bad.pd" *ngood = \&PDL::ngood; sub PDL::ngood { my($x) = @_; my $tmp; $x->clump(-1)->ngoodover($tmp=PDL->nullcreate($x) ); return $tmp; } #line 489 "Bad.pm" #line 573 "bad.pd" =head2 nbad =for ref Returns the number of bad values in an ndarray =for usage $x = nbad($data); =for bad Accepts good and bad input ndarrays; output is a Perl scalar and therefore is always good. =head2 ngood =for ref Returns the number of good values in an ndarray =for usage $x = ngood($data); =for bad Accepts good and bad input ndarrays; output is a Perl scalar and therefore is always good. =head2 setbadat =for ref Set the value to bad at a given position. =for usage setbadat $ndarray, @position C<@position> is a coordinate list, of size equal to the number of dimensions in the ndarray. This is a wrapper around L and is probably mainly useful in test scripts! =for example pdl> $x = sequence 3,4 pdl> $x->setbadat 2,1 pdl> p $x [ [ 0 1 2] [ 3 4 BAD] [ 6 7 8] [ 9 10 11] ] =for bad This method can be called on ndarrays that have bad values. The remainder of the arguments should be Perl scalars indicating the position to set as bad. The output ndarray will have bad values and will have its badflag turned on. =cut *setbadat = \&PDL::setbadat; sub PDL::setbadat { barf 'Usage: setbadat($pdl, $x, $y, ...)' if $#_<1; my $self = shift; PDL::Core::set_c ($self, [@_], $self->badvalue); $self->badflag(1); return $self; } #line 569 "Bad.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 setbadif =for sig Signature: (a(); int mask(); [o]b()) =for ref Set elements bad based on the supplied mask, otherwise copy across the data. =for example pdl> $x = sequence(5,5) pdl> $x = $x->setbadif( $x % 2 ) pdl> p "a badflag: ", $x->badflag, "\n" a badflag: 1 pdl> p "a is\n$x" [ [ 0 BAD 2 BAD 4] [BAD 6 BAD 8 BAD] [ 10 BAD 12 BAD 14] [BAD 16 BAD 18 BAD] [ 20 BAD 22 BAD 24] ] Unfortunately, this routine can I be run inplace, since the current implementation can not handle the same ndarray used as C and C (eg C<< $x->inplace->setbadif($x%2) >> fails). Even more unfortunate: we can't catch this error and tell you. =for bad The output always has its bad flag set, even if it does not contain any bad values (use L to check whether there are any bad values in the output). The input ndarray can have bad values: any bad values in the input ndarrays are copied across to the output ndarray. Also see L and L. =cut #line 620 "Bad.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *setbadif = \&PDL::setbadif; #line 626 "Bad.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 setvaltobad =for sig Signature: (a(); [o]b(); double value) =for ref Set bad all those elements which equal the supplied value. =for example $x = sequence(10) % 3; $x->inplace->setvaltobad( 0 ); print "$x\n"; [BAD 1 2 BAD 1 2 BAD 1 2 BAD] This is a simpler version of L, but this function can be done inplace. See L if you want to convert NaN to the bad value. =for bad The output always has its bad flag set, even if it does not contain any bad values (use L to check whether there are any bad values in the output). Any bad values in the input ndarrays are copied across to the output ndarray. =cut #line 664 "Bad.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *setvaltobad = \&PDL::setvaltobad; #line 670 "Bad.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 setnantobad =for sig Signature: (a(); [o]b()) =for ref Sets NaN values (for complex, where either is NaN) in the input ndarray bad (only relevant for floating-point ndarrays). Can be done inplace. =for usage $y = $x->setnantobad; $x->inplace->setnantobad; =for bad This method can process ndarrays with bad values: those bad values are propagated into the output ndarray. Any value that is not a number (before version 2.040 the test was for "not finite") is also set to bad in the output ndarray. If all values from the input ndarray are good, the output ndarray will B have its bad flag set. =cut #line 706 "Bad.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *setnantobad = \&PDL::setnantobad; #line 712 "Bad.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 setinftobad =for sig Signature: (a(); [o]b()) =for ref Sets non-finite values (for complex, where either is non-finite) in the input ndarray bad (only relevant for floating-point ndarrays). Can be done inplace. =for usage $y = $x->setinftobad; $x->inplace->setinftobad; =for bad This method can process ndarrays with bad values: those bad values are propagated into the output ndarray. Any value that is not finite is also set to bad in the output ndarray. If all values from the input ndarray are finite, the output ndarray will B have its bad flag set. =cut #line 747 "Bad.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *setinftobad = \&PDL::setinftobad; #line 753 "Bad.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 setnonfinitetobad =for sig Signature: (a(); [o]b()) =for ref Sets non-finite values (for complex, where either is non-finite) in the input ndarray bad (only relevant for floating-point ndarrays). Can be done inplace. =for usage $y = $x->setnonfinitetobad; $x->inplace->setnonfinitetobad; =for bad This method can process ndarrays with bad values: those bad values are propagated into the output ndarray. Any value that is not finite is also set to bad in the output ndarray. If all values from the input ndarray are finite, the output ndarray will B have its bad flag set. =cut #line 788 "Bad.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *setnonfinitetobad = \&PDL::setnonfinitetobad; #line 794 "Bad.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 setbadtonan =for sig Signature: (a(); [o] b();) =for ref Sets Bad values to NaN This is only relevant for floating-point ndarrays. The input ndarray can be of any type, but if done inplace, the input must be floating point. =for usage $y = $x->setbadtonan; $x->inplace->setbadtonan; =for bad This method processes input ndarrays with bad values. The output ndarrays will not contain bad values (insofar as NaN is not Bad as far as PDL is concerned) and the output ndarray does not have its bad flag set. As an inplace operation, it clears the bad flag. =cut #line 829 "Bad.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *setbadtonan = \&PDL::setbadtonan; #line 835 "Bad.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 setbadtoval =for sig Signature: (a(); [o]b(); double newval) =for ref Replace any bad values by a (non-bad) value. Can be done inplace. Also see L. =for example $x->inplace->setbadtoval(23); print "a badflag: ", $x->badflag, "\n"; a badflag: 0 =for bad The output always has its bad flag cleared. If the input ndarray does not have its bad flag set, then values are copied with no replacement. =cut #line 870 "Bad.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *setbadtoval = \&PDL::setbadtoval; #line 876 "Bad.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 copybad =for sig Signature: (a(); mask(); [o]b()) =for ref Copies values from one ndarray to another, setting them bad if they are bad in the supplied mask. Can be done inplace. =for example $x = byte( [0,1,3] ); $mask = byte( [0,0,0] ); $mask->badflag(1); set($mask,1,$mask->badvalue); $x->inplace->copybad( $mask ); p $x; [0 BAD 3] It is equivalent to: $c = $x + $mask * 0 =for bad This handles input ndarrays that are bad. If either C<$x> or C<$mask> have bad values, those values will be marked as bad in the output ndarray and the output ndarray will have its bad value flag set to true. =cut #line 920 "Bad.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *copybad = \&PDL::copybad; #line 926 "Bad.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 locf =for sig Signature: (a(n); [o]b(n)) =for ref Last Observation Carried Forward - replace every BAD value with the most recent non-BAD value prior to it. Any leading BADs will be set to 0. =for bad locf processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 953 "Bad.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *locf = \&PDL::locf; #line 959 "Bad.pm" #line 1143 "bad.pd" =head1 AUTHOR Doug Burke (djburke@cpan.org), 2000, 2001, 2003, 2006. The per-ndarray bad value support is by Heiko Klein (2006). CPAN documentation fixes by David Mertens (2010, 2013). 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 #line 982 "Bad.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/ImageND.pm0000644000175000017500000004000414200406317015605 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::ImageND; our @EXPORT_OK = qw(kernctr convolve ninterpol rebin circ_mean circ_mean_p convolveND ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::ImageND ; #line 5 "imagend.pd" =head1 NAME PDL::ImageND - useful image processing in N dimensions =head1 DESCRIPTION These routines act on PDLs as N-dimensional objects, not as threaded sets of 0-D or 1-D objects. The file is sort of a catch-all for broadly functional routines, most of which could legitimately be filed elsewhere (and probably will, one day). ImageND is not a part of the PDL core (v2.4) and hence must be explicitly loaded. =head1 SYNOPSIS use PDL::ImageND; $y = $x->convolveND($kernel,{bound=>'periodic'}); $y = $x->rebin(50,30,10); =cut use strict; use warnings; #line 52 "ImageND.pm" =head1 FUNCTIONS =cut #line 96 "imagend.pd" use Carp; #line 69 "ImageND.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 convolve =for sig Signature: (a(m); b(n); indx adims(p); indx bdims(q); [o]c(m)) =for ref N-dimensional convolution (Deprecated; use convolveND) =for usage $new = convolve $x, $kernel Convolve an array with a kernel, both of which are N-dimensional. This routine does direct convolution (by copying) but uses quasi-periodic boundary conditions: each dim "wraps around" to the next higher row in the next dim. This routine is kept for backwards compatibility with earlier scripts; for most purposes you want L instead: it runs faster and handles a variety of boundary conditions. =for bad convolve does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 108 "ImageND.pm" #line 1060 "../../blib/lib/PDL/PP.pm" # Custom Perl wrapper sub PDL::convolve{ my($x,$y,$c) = @_; barf("Usage: convolve(a(*), b(*), [o]c(*)") if $#_<1 || $#_>2; $c = PDL->null if $#_<2; &PDL::_convolve_int( $x->clump(-1), $y->clump(-1), long([$x->dims]), long([$y->dims]), ($c->getndims>1? $c->clump(-1) : $c) ); $c->setdims([$x->dims]); if($x->is_inplace) { $x .= $c; $x->set_inplace(0); return $x; } return $c; } #line 134 "ImageND.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *convolve = \&PDL::convolve; #line 140 "ImageND.pm" #line 226 "imagend.pd" =head2 ninterpol() =for ref N-dimensional interpolation routine =for sig Signature: ninterpol(point(),data(n),[o]value()) =for usage $value = ninterpol($point, $data); C uses C to find a linearly interpolated value in N dimensions, assuming the data is spread on a uniform grid. To use an arbitrary grid distribution, need to find the grid-space point from the indexing scheme, then call C -- this is far from trivial (and ill-defined in general). See also L, which includes boundary conditions and allows you to switch the method of interpolation, but which runs somewhat slower. =cut *ninterpol = \&PDL::ninterpol; sub PDL::ninterpol { use PDL::Math 'floor'; use PDL::Primitive 'interpol'; print 'Usage: $x = ninterpolate($point(s), $data);' if $#_ != 1; my ($p, $y) = @_; my ($ip) = floor($p); # isolate relevant N-cube $y = $y->slice(join (',',map($_.':'.($_+1),list $ip))); for (list ($p-$ip)) { $y = interpol($_,$y->xvals,$y); } $y; } #line 186 "ImageND.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 rebin =for sig Signature: (a(m); [o]b(n); int ns => n) =for ref N-dimensional rebinning algorithm =for usage $new = rebin $x, $dim1, $dim2,..;. $new = rebin $x, $template; $new = rebin $x, $template, {Norm => 1}; Rebin an N-dimensional array to newly specified dimensions. Specifying `Norm' keeps the sum constant, otherwise the intensities are kept constant. If more template dimensions are given than for the input pdl, these dimensions are created; if less, the final dimensions are maintained as they were. So if C<$x> is a 10 x 10 pdl, then C is a 15 x 10 pdl, while C is a 15 x 16 x 17 pdl (where the values along the final dimension are all identical). Expansion is performed by sampling; reduction is performed by averaging. If you want different behavior, use L instead. PDL::Transform::map runs slower but is more flexible. =for bad rebin does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 232 "ImageND.pm" #line 1060 "../../blib/lib/PDL/PP.pm" # Custom Perl wrapper sub PDL::rebin { my($x) = shift; my($opts) = ref $_[-1] eq "HASH" ? pop : {}; my(@idims) = $x->dims; my(@odims) = ref $_[0] ? $_[0]->dims : @_; my($i,$y); foreach $i (0..$#odims) { if ($i > $#idims) { # Just dummy extra dimensions $x = $x->dummy($i,$odims[$i]); next; # rebin_int can cope with all cases, but code # 1->n and n->1 separately for speed } elsif ($odims[$i] != $idims[$i]) { # If something changes if (!($odims[$i] % $idims[$i])) { # Cells map 1 -> n my ($r) = $odims[$i]/$idims[$i]; $y = $x->mv($i,0)->dummy(0,$r)->clump(2); } elsif (!($idims[$i] % $odims[$i])) { # Cells map n -> 1 my ($r) = $idims[$i]/$odims[$i]; $x = $x->mv($i,0); # -> copy so won't corrupt input PDL $y = $x->slice("0:-1:$r")->copy; foreach (1..$r-1) { $y += $x->slice("$_:-1:$r"); } $y /= $r; } else { # Cells map n -> m &PDL::_rebin_int($x->mv($i,0), $y = null, $odims[$i]); } $x = $y->mv(0,$i); } } if (exists $opts->{Norm} and $opts->{Norm}) { my ($norm) = 1; for $i (0..$#odims) { if ($i > $#idims) { $norm /= $odims[$i]; } else { $norm *= $idims[$i]/$odims[$i]; } } return $x * $norm; } else { # Explicit copy so i) can't corrupt input PDL through this link # ii) don't waste space on invisible elements return $x -> copy; } } #line 288 "ImageND.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *rebin = \&PDL::rebin; #line 294 "ImageND.pm" #line 379 "imagend.pd" =head2 circ_mean_p =for ref Calculates the circular mean of an n-dim image and returns the projection. Optionally takes the center to be used. =for usage $cmean=circ_mean_p($im); $cmean=circ_mean_p($im,{Center => [10,10]}); =cut sub circ_mean_p { my ($x,$opt) = @_; my ($rad,$sum,$norm); if (defined $opt) { $rad = long PDL::rvals($x,$opt); } else { $rad = long rvals $x; } $sum = zeroes($rad->max+1); PDL::indadd $x->clump(-1), $rad->clump(-1), $sum; # this does the real work $norm = zeroes($rad->max+1); PDL::indadd pdl(1), $rad->clump(-1), $norm; # equivalent to get norm $sum /= $norm; return $sum; } =head2 circ_mean =for ref Smooths an image by applying circular mean. Optionally takes the center to be used. =for usage circ_mean($im); circ_mean($im,{Center => [10,10]}); =cut sub circ_mean { my ($x,$opt) = @_; my ($rad,$sum,$norm,$a1); if (defined $opt) { $rad = long PDL::rvals($x,$opt); } else { $rad = long rvals $x; } $sum = zeroes($rad->max+1); PDL::indadd $x->clump(-1), $rad->clump(-1), $sum; # this does the real work $norm = zeroes($rad->max+1); PDL::indadd pdl(1), $rad->clump(-1), $norm; # equivalent to get norm $sum /= $norm; $a1 = $x->clump(-1); $a1 .= $sum->index($rad->clump(-1)); return $x; } #line 368 "ImageND.pm" #line 455 "imagend.pd" =head2 kernctr =for ref `centre' a kernel (auxiliary routine to fftconvolve) =for usage $kernel = kernctr($image,$smallk); fftconvolve($image,$kernel); kernctr centres a small kernel to emulate the behaviour of the direct convolution routines. =cut *kernctr = \&PDL::kernctr; sub PDL::kernctr { # `centre' the kernel, to match kernel & image sizes and # emulate convolve/conv2d. FIX: implement with phase shifts # in fftconvolve, with option tag barf "Must have image & kernel for kernctr" if $#_ != 1; my ($imag, $kern) = @_; my (@ni) = $imag->dims; my (@nk) = $kern->dims; barf "Kernel and image must have same number of dims" if $#ni != $#nk; my ($newk) = zeroes(double,@ni); my ($k,$n,$y,$d,$i,@stri,@strk,@b); for ($i=0; $i <= $#ni; $i++) { $k = $nk[$i]; $n = $ni[$i]; barf "Kernel must be smaller than image in all dims" if ($n < $k); $d = int(($k-1)/2); $stri[$i][0] = "0:$d,"; $strk[$i][0] = (-$d-1).":-1,"; $stri[$i][1] = $d == 0 ? '' : ($d-$k+1).':-1,'; $strk[$i][1] = $d == 0 ? '' : '0:'.($k-$d-2).','; } # kernel is split between the 2^n corners of the cube my ($nchunk) = 2 << $#ni; CHUNK: for ($i=0; $i < $nchunk; $i++) { my ($stri,$strk); for ($n=0, $y=$i; $n <= $#ni; $n++, $y >>= 1) { next CHUNK if $stri[$n][$y & 1] eq ''; $stri .= $stri[$n][$y & 1]; $strk .= $strk[$n][$y & 1]; } chop ($stri); chop ($strk); (my $t = $newk->slice($stri)) .= $kern->slice($strk); } $newk; } #line 429 "ImageND.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 convolveND =for sig Signature: (k0(); SV *k; SV *aa; SV *a) =for ref Speed-optimized convolution with selectable boundary conditions =for usage $new = convolveND($x, $kernel, [ {options} ]); Conolve an array with a kernel, both of which are N-dimensional. If the kernel has fewer dimensions than the array, then the extra array dimensions are threaded over. There are options that control the boundary conditions and method used. The kernel's origin is taken to be at the kernel's center. If your kernel has a dimension of even order then the origin's coordinates get rounded up to the next higher pixel (e.g. (1,2) for a 3x4 kernel). This mimics the behavior of the earlier L and L routines, so convolveND is a drop-in replacement for them. The kernel may be any size compared to the image, in any dimension. The kernel and the array are not quite interchangeable (as in mathematical convolution): the code is inplace-aware only for the array itself, and the only allowed boundary condition on the kernel is truncation. convolveND is inplace-aware: say C to modify a variable in-place. You don't reduce the working memory that way -- only the final memory. OPTIONS Options are parsed by PDL::Options, so unique abbreviations are accepted. =over 3 =item boundary (default: 'truncate') The boundary condition on the array, which affects any pixel closer to the edge than the half-width of the kernel. The boundary conditions are the same as those accepted by L, because this option is passed directly into L. Useful options are 'truncate' (the default), 'extend', and 'periodic'. You can select different boundary conditions for different axes -- see L for more detail. The (default) truncate option marks all the near-boundary pixels as BAD if you have bad values compiled into your PDL and the array's badflag is set. =item method (default: 'auto') The method to use for the convolution. Acceptable alternatives are 'direct', 'fft', or 'auto'. The direct method is an explicit copy-and-multiply operation; the fft method takes the Fourier transform of the input and output kernels. The two methods give the same answer to within double-precision numerical roundoff. The fft method is much faster for large kernels; the direct method is faster for tiny kernels. The tradeoff occurs when the array has about 400x more pixels than the kernel. The default method is 'auto', which chooses direct or fft convolution based on the size of the input arrays. =back NOTES At the moment there's no way to thread over kernels. That could/should be fixed. The threading over input is cheesy and should probably be fixed: currently the kernel just gets dummy dimensions added to it to match the input dims. That does the right thing tersely but probably runs slower than a dedicated threadloop. The direct copying code uses PP primarily for the generic typing: it includes its own threadloops. =for bad convolveND does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 534 "ImageND.pm" #line 1060 "../../blib/lib/PDL/PP.pm" use PDL::Options; # Perl wrapper conditions the data to make life easier for the PP sub. sub PDL::convolveND { my($a0,$k,$opt0) = @_; my $inplace = $a0->is_inplace; my $x = $a0->new_or_inplace; barf("convolveND: kernel (".join("x",$k->dims).") has more dims than source (".join("x",$x->dims).")\n") if($x->ndims < $k->ndims); # Coerce stuff all into the same type. Try to make sense. # The trivial conversion leaves dataflow intact (nontrivial conversions # don't), so the inplace code is OK. Non-inplace code: let the existing # PDL code choose what type is best. my $type; if($inplace) { $type = $a0->get_datatype; } else { my $z = $x->flat->index(0) + $k->flat->index(0); $type = $z->get_datatype; } $x = $x->convert($type); $k = $k->convert($type); ## Handle options -- $def is a static variable so it only gets set up once. our $def; unless(defined($def)) { $def = new PDL::Options( { Method=>'a', Boundary=>'t' } ); $def->minmatch(1); $def->casesens(0); } my $opt = $def->options(PDL::Options::ifhref($opt0)); ### # If the kernel has too few dimensions, we thread over the other # dims -- this is the same as supplying the kernel with dummy dims of # order 1, so, er, we do that. $k = $k->dummy($x->dims - 1, 1) if($x->ndims > $k->ndims); my $kdims = pdl($k->dims); ### # Decide whether to FFT or directly convolve: if we're in auto mode, # choose based on the relative size of the image and kernel arrays. my $fft = ( ($opt->{Method} =~ m/^a/i) ? ( $x->nelem > 2500 and ($x->nelem) <= ($k->nelem * 500) ) : ( $opt->{Method} !~ m/^[ds]/i ) ); ### # Pad the array to include boundary conditions my $adims = pdl($x->dims); my $koff = ($kdims/2)->ceil - 1; my $aa = $x->range( -$koff, $adims + $kdims, $opt->{Boundary} ) ->sever; if($fft) { require PDL::FFT; print "convolveND: using FFT method\n" if($PDL::debug); # FFT works best on doubles; do our work there then cast back # at the end. $aa = double($aa); my $aai = $aa->zeroes; my $kk = $aa->zeroes; my $kki = $aa->zeroes; my $tmp; # work around new perl -d "feature" ($tmp = $kk->range( - ($kdims/2)->floor, $kdims, 'p')) .= $k; PDL::fftnd($kk, $kki); PDL::fftnd($aa, $aai); { my($ii) = $kk * $aai + $aa * $kki; $aa = $aa * $kk - $kki * $aai; $aai .= $ii; } PDL::ifftnd($aa,$aai); $x .= $aa->range( $koff, $adims); } else { print "convolveND: using direct method\n" if($PDL::debug); ### The first argument is a dummy to set $GENERIC. &PDL::_convolveND_int( $k->flat->index(0), $k, $aa, $x ); } $x; } #line 644 "ImageND.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *convolveND = \&PDL::convolveND; #line 650 "ImageND.pm" #line 35 "imagend.pd" =head1 AUTHORS Copyright (C) Karl Glazebrook and Craig DeForest, 1997, 2003 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 #line 668 "ImageND.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/Transform/0000755000175000017500000000000014200406317015760 5ustar osboxesosboxesPDL-2.074/GENERATED/PDL/Transform/Proj4.pm0000644000175000017500000002302714200406317017320 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::Transform::Proj4; our @EXPORT_OK = qw(t_proj _proj4_dummy ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader','PDL::Transform' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Transform::Proj4 ; BEGIN { use PDL::LiteF; use PDL::NiceSlice; use PDL::Transform; use PDL::GIS::Proj; } #line 28 "Proj4.pd" # # PDL::Transform::Proj4 # # Judd Taylor, USF IMaRS # 4 Apr 2006 # =head1 NAME PDL::Transform::Proj4 - PDL::Transform interface to the Proj4 projection library =head1 SYNOPSIS # Using the generalized proj interface: # Make an orthographic map of Earth use PDL::Transform::Cartography; use PDL::Transform::Proj4; $x = earth_coast(); $x = graticule(10,2)->glue(1,$x); $t = t_proj( proj_params => "+proj=ortho +ellps=WGS84 +lon_0=-90 +lat_0=40" ); $w = pgwin(xs); $w->lines($t->apply($x)->clean_lines()); # Using the aliased functions: # Make an orthographic map of Earth use PDL::Transform::Cartography; use PDL::Transform::Proj4; $x = earth_coast(); $x = graticule(10,2)->glue(1,$x); $t = t_proj_ortho( ellps => 'WGS84', lon_0 => -90, lat_0 => 40 ) $w = pgwin(xs); $w->lines($t->apply($x)->clean_lines()); =head1 DESCRIPTION Works like PDL::Transform::Cartography, but using the proj library in the background. Please see the proj library docs at L for more information on proj, and how to use the library. =head1 GENERALIZED INTERFACE The main object here is the PDL::Transform::Proj4 object, aliased to the t_proj() function. This object accepts all of the standard options described below, but mainly is there to be called with just the B option defined. When options are used, they must be used with a '+' before them when placed in the proj_params string, but that is not required otherwise. See the SYNOPSIS above. =head2 ALIASED INTERFACE Other than t_proj(), all of the other transforms below have been autogenerated, and may not work properly. The main problem is determining the parameters a projection requires from the proj library itself. Due to the difficulties in doing this, there may be times when the proj docs specify a parameter for a projection that won't work using the anon-hash type specification. In that case, just throw that parameter in the proj_params string, and everything should work fine. =head1 PARAMETERS AVAILABLE IN ALL PROJECTIONS =head2 General Parameters =head3 proj_params This is a string containing the proj "plus style" parameters. This would be similar to what you would put on the command line for the 'proj' tool. Like "+proj=ortho +ellps=WGS84 +lon_0=-90 +lat_0=40". This parameter overrides the others below when it contains parameters that are also specified explicitly. =head3 proj The proj projection code to use (like ortho...) =head3 x_0 Cartesian X offset for the output of the transformation =head3 y_0 Cartesian Y offset for the output of the transformation =head3 lat_0 Central latitude for the projection. NOTE: This may mean other things depending on the projection selected, read the proj docs! =head3 lon_0 Central longitude for the projection. NOTE: This may mean other things depending on the projection selected, read the proj docs! =head3 units Cartesian units used for the output of the projection. NOTE: Like most of the options here, this is likely useless in the current implementation of this library. =head3 init Specify a file:unit for proj to use for its runtime defaults. See the proj docs. =head3 no_defs Don't load any defaults. See the proj docs. =head3 over Normally, the transformation limits the output to between -180 and 180 degrees (or the cartesian equivalent), but with this option that behavior is turned off. =head3 geoc Input values are geocentric coordinates. =head2 Earth Figure Parameters =head3 ellps Ellipsoid datum to use. Ex: WGS72, WGS74. See the proj docs and command line tool for list of possibilities ('proj -le'). =head3 R Radius of the Earth. =head3 R_A Radius of a sphere with equivalent surface area of specified ellipse. =head3 R_V Radius of a sphere with equivalent volume of specified ellipse. =head3 R_a Arithmetic mean of the major and minor axis, Ra = (a + b)/2. =head3 R_g Geometric mean of the major and minor axis, Rg = (ab)1/2. =head3 R_h Harmonic mean of the major and minor axis, Rh = 2ab/(a + b). =head3 R_lat_a=phi Arithmetic mean of the principle radii at latitude phi. =head3 R_lat_g=phi Geometric mean of the principle radii at latitude phi. =head3 b Semiminor axis or polar radius =head3 f Flattening =head3 rf Reciprocal flattening, +rf=1/f =head3 e Eccentricity +e=e =head3 es Eccentricity squared +es=e2 =cut sub new { my $proto = shift; my $sub = "PDL::Transform::Proj4::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; my $class = ref($proto) || $proto; my $self = $class->SUPER::new( @_ ); bless ($self, $class); my $o = $_[0]; unless( (ref $o) ) { $o = {@_}; } #use Data::Dumper; #my $dd2 = Data::Dumper->new( [$o], ["$sub: o"] ); #$dd2->Indent(1); #print STDERR $dd2->Dump(); $self->{name} = "Proj4"; # Grab our options: # Used in the general sense: $self->{params}->{proj_params} = PDL::Transform::_opt( $o, ['proj_params','params'] ); # Projection options available to all projections: $self->{general_params} = [ qw( proj x_0 y_0 lat_0 lon_0 units init ) ]; foreach my $param ( @{ $self->{general_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } # Options that have no value (like "+over"): $self->{bool_params} = [ qw( no_defs over geoc ) ]; foreach my $param ( @{ $self->{bool_params} } ) { $self->{params}->{$param} = ( PDL::Transform::_opt( $o, [ $param ] ) ) ? 'ON' : undef; } # Options for the Earth figure: (ellipsoid, etc): $self->{earth_params} = [ qw( ellps R R_A R_V R_a R_g R_h R_lat_a R_lat_g b f rf e es ) ]; foreach my $param ( @{ $self->{earth_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } # First process the old params that may already be in the string: # These override the specific params set above: if( defined( $self->{params}->{proj_params} ) ) { $self->{orig_proj_params} = $self->{params}->{proj_params}; my @params = split( /\s+/, $self->{orig_proj_params} ); foreach my $param ( @params ) { if( $param =~ /^\+(\S+)=(\S+)/ ) { my ($name, $val) = ($1, $2); $self->{params}->{$name} = $val; #print STDERR "$sub: $name => $val\n"; } elsif( $param =~ /^\+(\S+)/ ) { # Boolean option $self->{params}->{$1} = 'ON'; } } } # Update the proj_string to current options: # $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); ############################## # The meat -- just copy and paste from Transform.pm :) # (and do some proj stuff here as well) # Forward transformation: $self->{func} = sub { my $in = shift; my $opt = shift; my $out = $in->new_or_inplace(); # Always set the badflag to 1 here, to handle possible bad projection values: $out->badflag(1); $out->inplace(1); PDL::GIS::Proj::fwd_transform( $out, $opt->{proj_params} ); }; # Inverse transformation: $self->{inv} = sub { my $in = shift; my $opt = shift; my $out = $in->new_or_inplace(); # Always set the badflag to 1 here, to handle possible bad projection values: $out->badflag(1); $out->inplace(1); PDL::GIS::Proj::inv_transform( $out, $opt->{proj_params} ); }; return $self; } # End of new()... sub update_proj_string { my $self = shift; my $sub = "PDL::Transform::Proj4::update_proj_string()"; # (Re)Generate the proj_params string from the options passed: # delete( $self->{params}->{proj_params} ); my $proj_string = ""; foreach my $param ( sort keys %{ $self->{params} } ) #line 326 "Proj4.pm" #line 321 "Proj4.pd" { next unless defined( $self->{params}->{$param} ); $proj_string .= ( $self->{params}->{$param} eq 'ON' ) ? "+$param " : " +$param=" . $self->{params}->{$param} . " "; #print STDERR "$sub: Adding \'$proj_string\'...\n"; } #print STDERR "$sub: Final proj_params: \'$proj_string\'\n"; $self->{params}->{proj_params} = $proj_string; } # End of update_proj_string()... sub proj_params { my $self = shift; $self->update_proj_string(); return $self->{params}->{proj_params}; } # End of proj_params()... sub t_proj { PDL::Transform::Proj4->new( @_ ); } # End of t_proj()... 1; #line 354 "Proj4.pm" #line 354 "Proj4.pd" =head1 FUNCTIONS =head2 t_proj This is the main entry point for the generalized interface. See above on its usage. =cut #line 371 "Proj4.pm" #line 1061 "/home/osboxes/pdl-code/blib/lib/PDL/PP.pm" *_proj4_dummy = \&PDL::_proj4_dummy; #line 377 "Proj4.pm" #line 486 "Proj4.pd" =head1 AUTHOR & MAINTAINER Judd Taylor, Orbital Systems, Ltd. judd dot t at orbitalsystems dot com =cut #line 391 "Proj4.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSLSF/0000755000175000017500000000000014200406316014662 5ustar osboxesosboxesPDL-2.074/GENERATED/PDL/GSLSF/EXPINT.pm0000644000175000017500000001307214200406314016230 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::EXPINT; our @EXPORT_OK = qw(gsl_sf_expint_E1 gsl_sf_expint_E2 gsl_sf_expint_Ei gsl_sf_Shi gsl_sf_Chi gsl_sf_expint_3 gsl_sf_Si gsl_sf_Ci gsl_sf_atanint ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::EXPINT ; #line 5 "gsl_sf_expint.pd" use strict; use warnings; =head1 NAME PDL::GSLSF::EXPINT - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =cut #line 38 "EXPINT.pm" =head1 FUNCTIONS =cut #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_expint_E1 =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref E_1(x) := Re[ Integrate[ Exp[-xt]/t, {t,1,Infinity}] ] =for bad gsl_sf_expint_E1 does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 72 "EXPINT.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_expint_E1 = \&PDL::gsl_sf_expint_E1; #line 78 "EXPINT.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_expint_E2 =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref E_2(x) := Re[ Integrate[ Exp[-xt]/t^2, {t,1,Infity}] ] =for bad gsl_sf_expint_E2 does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 102 "EXPINT.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_expint_E2 = \&PDL::gsl_sf_expint_E2; #line 108 "EXPINT.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_expint_Ei =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Ei(x) := PV Integrate[ Exp[-t]/t, {t,-x,Infinity}] =for bad gsl_sf_expint_Ei does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 132 "EXPINT.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_expint_Ei = \&PDL::gsl_sf_expint_Ei; #line 138 "EXPINT.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_Shi =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Shi(x) := Integrate[ Sinh[t]/t, {t,0,x}] =for bad gsl_sf_Shi does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 162 "EXPINT.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_Shi = \&PDL::gsl_sf_Shi; #line 168 "EXPINT.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_Chi =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Chi(x) := Re[ M_EULER + log(x) + Integrate[(Cosh[t]-1)/t, {t,0,x}] ] =for bad gsl_sf_Chi does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 192 "EXPINT.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_Chi = \&PDL::gsl_sf_Chi; #line 198 "EXPINT.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_expint_3 =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Ei_3(x) := Integral[ Exp[-t^3], {t,0,x}] =for bad gsl_sf_expint_3 does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 222 "EXPINT.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_expint_3 = \&PDL::gsl_sf_expint_3; #line 228 "EXPINT.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_Si =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Si(x) := Integrate[ Sin[t]/t, {t,0,x}] =for bad gsl_sf_Si does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 252 "EXPINT.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_Si = \&PDL::gsl_sf_Si; #line 258 "EXPINT.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_Ci =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Ci(x) := -Integrate[ Cos[t]/t, {t,x,Infinity}] =for bad gsl_sf_Ci does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 282 "EXPINT.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_Ci = \&PDL::gsl_sf_Ci; #line 288 "EXPINT.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_atanint =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref AtanInt(x) := Integral[ Arctan[t]/t, {t,0,x}] =for bad gsl_sf_atanint does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 312 "EXPINT.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_atanint = \&PDL::gsl_sf_atanint; #line 318 "EXPINT.pm" #line 139 "gsl_sf_expint.pd" =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin 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. The GSL SF modules were written by G. Jungman. =cut #line 337 "EXPINT.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSLSF/EXP.pm0000644000175000017500000000517314200406314015660 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::EXP; our @EXPORT_OK = qw(gsl_sf_exp gsl_sf_exprel_n gsl_sf_exp_err ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::EXP ; #line 5 "gsl_sf_exp.pd" use strict; use warnings; =head1 NAME PDL::GSLSF::EXP - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =cut #line 38 "EXP.pm" =head1 FUNCTIONS =cut #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_exp =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Exponential =for bad gsl_sf_exp does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 72 "EXP.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_exp = \&PDL::gsl_sf_exp; #line 78 "EXP.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_exprel_n =for sig Signature: (double x(); double [o]y(); double [o]e(); int n) =for ref N-relative Exponential. exprel_N(x) = N!/x^N (exp(x) - Sum[x^k/k!, {k,0,N-1}]) = 1 + x/(N+1) + x^2/((N+1)(N+2)) + ... = 1F1(1,1+N,x) =for bad gsl_sf_exprel_n does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 102 "EXP.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_exprel_n = \&PDL::gsl_sf_exprel_n; #line 108 "EXP.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_exp_err =for sig Signature: (double x(); double dx(); double [o]y(); double [o]e()) =for ref Exponential of a quantity with given error. =for bad gsl_sf_exp_err does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 132 "EXP.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_exp_err = \&PDL::gsl_sf_exp_err; #line 138 "EXP.pm" #line 66 "gsl_sf_exp.pd" =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin 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. The GSL SF modules were written by G. Jungman. =cut #line 157 "EXP.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSLSF/HYPERG.pm0000644000175000017500000001360014200406315016215 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::HYPERG; our @EXPORT_OK = qw(gsl_sf_hyperg_0F1 gsl_sf_hyperg_1F1 gsl_sf_hyperg_U gsl_sf_hyperg_2F1 gsl_sf_hyperg_2F1_conj gsl_sf_hyperg_2F1_renorm gsl_sf_hyperg_2F1_conj_renorm gsl_sf_hyperg_2F0 ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::HYPERG ; #line 5 "gsl_sf_hyperg.pd" use strict; use warnings; =head1 NAME PDL::GSLSF::HYPERG - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =cut #line 38 "HYPERG.pm" =head1 FUNCTIONS =cut #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_hyperg_0F1 =for sig Signature: (double x(); double [o]y(); double [o]e(); double c) =for ref /* Hypergeometric function related to Bessel functions 0F1[c,x] = Gamma[c] x^(1/2(1-c)) I_{c-1}(2 Sqrt[x]) Gamma[c] (-x)^(1/2(1-c)) J_{c-1}(2 Sqrt[-x]) =for bad gsl_sf_hyperg_0F1 does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 72 "HYPERG.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_hyperg_0F1 = \&PDL::gsl_sf_hyperg_0F1; #line 78 "HYPERG.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_hyperg_1F1 =for sig Signature: (double x(); double [o]y(); double [o]e(); double a; double b) =for ref Confluent hypergeometric function for integer parameters. 1F1[a,b,x] = M(a,b,x) =for bad gsl_sf_hyperg_1F1 does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 102 "HYPERG.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_hyperg_1F1 = \&PDL::gsl_sf_hyperg_1F1; #line 108 "HYPERG.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_hyperg_U =for sig Signature: (double x(); double [o]y(); double [o]e(); double a; double b) =for ref Confluent hypergeometric function for integer parameters. U(a,b,x) =for bad gsl_sf_hyperg_U does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 132 "HYPERG.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_hyperg_U = \&PDL::gsl_sf_hyperg_U; #line 138 "HYPERG.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_hyperg_2F1 =for sig Signature: (double x(); double [o]y(); double [o]e(); double a; double b; double c) =for ref Confluent hypergeometric function for integer parameters. 2F1[a,b,c,x] =for bad gsl_sf_hyperg_2F1 does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 162 "HYPERG.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_hyperg_2F1 = \&PDL::gsl_sf_hyperg_2F1; #line 168 "HYPERG.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_hyperg_2F1_conj =for sig Signature: (double x(); double [o]y(); double [o]e(); double a; double b; double c) =for ref Gauss hypergeometric function 2F1[aR + I aI, aR - I aI, c, x] =for bad gsl_sf_hyperg_2F1_conj does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 192 "HYPERG.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_hyperg_2F1_conj = \&PDL::gsl_sf_hyperg_2F1_conj; #line 198 "HYPERG.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_hyperg_2F1_renorm =for sig Signature: (double x(); double [o]y(); double [o]e(); double a; double b; double c) =for ref Renormalized Gauss hypergeometric function 2F1[a,b,c,x] / Gamma[c] =for bad gsl_sf_hyperg_2F1_renorm does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 222 "HYPERG.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_hyperg_2F1_renorm = \&PDL::gsl_sf_hyperg_2F1_renorm; #line 228 "HYPERG.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_hyperg_2F1_conj_renorm =for sig Signature: (double x(); double [o]y(); double [o]e(); double a; double b; double c) =for ref Renormalized Gauss hypergeometric function 2F1[aR + I aI, aR - I aI, c, x] / Gamma[c] =for bad gsl_sf_hyperg_2F1_conj_renorm does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 252 "HYPERG.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_hyperg_2F1_conj_renorm = \&PDL::gsl_sf_hyperg_2F1_conj_renorm; #line 258 "HYPERG.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_hyperg_2F0 =for sig Signature: (double x(); double [o]y(); double [o]e(); double a; double b) =for ref Mysterious hypergeometric function. The series representation is a divergent hypergeometric series. However, for x < 0 we have 2F0(a,b,x) = (-1/x)^a U(a,1+a-b,-1/x) =for bad gsl_sf_hyperg_2F0 does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 282 "HYPERG.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_hyperg_2F0 = \&PDL::gsl_sf_hyperg_2F0; #line 288 "HYPERG.pm" #line 131 "gsl_sf_hyperg.pd" =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin 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. The GSL SF modules were written by G. Jungman. =cut #line 308 "HYPERG.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSLSF/POLY.pm0000644000175000017500000000342114200406315016002 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::POLY; our @EXPORT_OK = qw(gsl_poly_eval ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::POLY ; #line 5 "gsl_sf_poly.pd" use strict; use warnings; =head1 NAME PDL::GSLSF::POLY - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. NOTE: this should actually be PDL::POLY for consistency but I don't want to get into edits changing the directory structure at this time. These fixes should allow things to build. =cut #line 41 "POLY.pm" =head1 FUNCTIONS =cut #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_poly_eval =for sig Signature: (double x(); double c(m); double [o]y()) =for ref c[0] + c[1] x + c[2] x^2 + ... + c[m-1] x^(m-1) =for bad gsl_poly_eval does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 75 "POLY.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_poly_eval = \&PDL::gsl_poly_eval; #line 81 "POLY.pm" #line 42 "gsl_sf_poly.pd" =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin 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. The GSL SF modules were written by G. Jungman. =cut #line 100 "POLY.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSLSF/GAMMA.pm0000644000175000017500000002564414200406315016054 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::GAMMA; our @EXPORT_OK = qw(gsl_sf_lngamma gsl_sf_gamma gsl_sf_gammastar gsl_sf_gammainv gsl_sf_lngamma_complex gsl_sf_taylorcoeff gsl_sf_fact gsl_sf_doublefact gsl_sf_lnfact gsl_sf_lndoublefact gsl_sf_lnchoose gsl_sf_choose gsl_sf_lnpoch gsl_sf_poch gsl_sf_pochrel gsl_sf_gamma_inc_Q gsl_sf_gamma_inc_P gsl_sf_lnbeta gsl_sf_beta ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::GAMMA ; #line 5 "gsl_sf_gamma.pd" use strict; use warnings; =head1 NAME PDL::GSLSF::GAMMA - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =cut #line 38 "GAMMA.pm" =head1 FUNCTIONS =cut #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_lngamma =for sig Signature: (double x(); double [o]y(); double [o]s(); double [o]e()) =for ref Log[Gamma(x)], x not a negative integer Uses real Lanczos method. Determines the sign of Gamma[x] as well as Log[|Gamma[x]|] for x < 0. So Gamma[x] = sgn * Exp[result_lg]. =for bad gsl_sf_lngamma does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 72 "GAMMA.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_lngamma = \&PDL::gsl_sf_lngamma; #line 78 "GAMMA.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_gamma =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Gamma(x), x not a negative integer =for bad gsl_sf_gamma does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 102 "GAMMA.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_gamma = \&PDL::gsl_sf_gamma; #line 108 "GAMMA.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_gammastar =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Regulated Gamma Function, x > 0 Gamma^*(x) = Gamma(x)/(Sqrt[2Pi] x^(x-1/2) exp(-x)) = (1 + 1/(12x) + ...), x->Inf =for bad gsl_sf_gammastar does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 132 "GAMMA.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_gammastar = \&PDL::gsl_sf_gammastar; #line 138 "GAMMA.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_gammainv =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref 1/Gamma(x) =for bad gsl_sf_gammainv does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 162 "GAMMA.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_gammainv = \&PDL::gsl_sf_gammainv; #line 168 "GAMMA.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_lngamma_complex =for sig Signature: (double zr(); double zi(); double [o]x(); double [o]y(); double [o]xe(); double [o]ye()) =for ref Log[Gamma(z)] for z complex, z not a negative integer. Calculates: lnr = log|Gamma(z)|, arg = arg(Gamma(z)) in (-Pi, Pi] =for bad gsl_sf_lngamma_complex does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 192 "GAMMA.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_lngamma_complex = \&PDL::gsl_sf_lngamma_complex; #line 198 "GAMMA.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_taylorcoeff =for sig Signature: (double x(); double [o]y(); double [o]e(); int n) =for ref x^n / n! =for bad gsl_sf_taylorcoeff does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 222 "GAMMA.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_taylorcoeff = \&PDL::gsl_sf_taylorcoeff; #line 228 "GAMMA.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_fact =for sig Signature: (x(); double [o]y(); double [o]e()) =for ref n! =for bad gsl_sf_fact does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 252 "GAMMA.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_fact = \&PDL::gsl_sf_fact; #line 258 "GAMMA.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_doublefact =for sig Signature: (x(); double [o]y(); double [o]e()) =for ref n!! = n(n-2)(n-4) =for bad gsl_sf_doublefact does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 282 "GAMMA.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_doublefact = \&PDL::gsl_sf_doublefact; #line 288 "GAMMA.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_lnfact =for sig Signature: (x(); double [o]y(); double [o]e()) =for ref ln n! =for bad gsl_sf_lnfact does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 312 "GAMMA.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_lnfact = \&PDL::gsl_sf_lnfact; #line 318 "GAMMA.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_lndoublefact =for sig Signature: (x(); double [o]y(); double [o]e()) =for ref ln n!! =for bad gsl_sf_lndoublefact does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 342 "GAMMA.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_lndoublefact = \&PDL::gsl_sf_lndoublefact; #line 348 "GAMMA.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_lnchoose =for sig Signature: (n(); m(); double [o]y(); double [o]e()) =for ref log(n choose m) =for bad gsl_sf_lnchoose does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 372 "GAMMA.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_lnchoose = \&PDL::gsl_sf_lnchoose; #line 378 "GAMMA.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_choose =for sig Signature: (n(); m(); double [o]y(); double [o]e()) =for ref n choose m =for bad gsl_sf_choose does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 402 "GAMMA.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_choose = \&PDL::gsl_sf_choose; #line 408 "GAMMA.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_lnpoch =for sig Signature: (double x(); double [o]y(); double [o]s(); double [o]e(); double a) =for ref Logarithm of Pochammer (Apell) symbol, with sign information. result = log( |(a)_x| ), sgn = sgn( (a)_x ) where (a)_x := Gamma[a + x]/Gamma[a] =for bad gsl_sf_lnpoch does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 432 "GAMMA.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_lnpoch = \&PDL::gsl_sf_lnpoch; #line 438 "GAMMA.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_poch =for sig Signature: (double x(); double [o]y(); double [o]e(); double a) =for ref Pochammer (Apell) symbol (a)_x := Gamma[a + x]/Gamma[x] =for bad gsl_sf_poch does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 462 "GAMMA.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_poch = \&PDL::gsl_sf_poch; #line 468 "GAMMA.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_pochrel =for sig Signature: (double x(); double [o]y(); double [o]e(); double a) =for ref Relative Pochammer (Apell) symbol ((a,x) - 1)/x where (a,x) = (a)_x := Gamma[a + x]/Gamma[a] =for bad gsl_sf_pochrel does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 492 "GAMMA.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_pochrel = \&PDL::gsl_sf_pochrel; #line 498 "GAMMA.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_gamma_inc_Q =for sig Signature: (double x(); double [o]y(); double [o]e(); double a) =for ref Normalized Incomplete Gamma Function Q(a,x) = 1/Gamma(a) Integral[ t^(a-1) e^(-t), {t,x,Infinity} ] =for bad gsl_sf_gamma_inc_Q does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 522 "GAMMA.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_gamma_inc_Q = \&PDL::gsl_sf_gamma_inc_Q; #line 528 "GAMMA.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_gamma_inc_P =for sig Signature: (double x(); double [o]y(); double [o]e(); double a) =for ref Complementary Normalized Incomplete Gamma Function P(a,x) = 1/Gamma(a) Integral[ t^(a-1) e^(-t), {t,0,x} ] =for bad gsl_sf_gamma_inc_P does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 552 "GAMMA.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_gamma_inc_P = \&PDL::gsl_sf_gamma_inc_P; #line 558 "GAMMA.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_lnbeta =for sig Signature: (double a(); double b(); double [o]y(); double [o]e()) =for ref Logarithm of Beta Function Log[B(a,b)] =for bad gsl_sf_lnbeta does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 582 "GAMMA.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_lnbeta = \&PDL::gsl_sf_lnbeta; #line 588 "GAMMA.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_beta =for sig Signature: (double a(); double b();double [o]y(); double [o]e()) =for ref Beta Function B(a,b) =for bad gsl_sf_beta does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 612 "GAMMA.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_beta = \&PDL::gsl_sf_beta; #line 618 "GAMMA.pm" #line 271 "gsl_sf_gamma.pd" =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin 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. The GSL SF modules were written by G. Jungman. =cut #line 637 "GAMMA.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSLSF/DILOG.pm0000644000175000017500000000442214200406314016056 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::DILOG; our @EXPORT_OK = qw(gsl_sf_dilog gsl_sf_complex_dilog ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::DILOG ; #line 5 "gsl_sf_dilog.pd" use strict; use warnings; =head1 NAME PDL::GSLSF::DILOG - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =cut #line 38 "DILOG.pm" =head1 FUNCTIONS =cut #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_dilog =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref /* Real part of DiLogarithm(x), for real argument. In Lewins notation, this is Li_2(x). Li_2(x) = - Re[ Integrate[ Log[1-s] / s, {s, 0, x}] ] =for bad gsl_sf_dilog does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 72 "DILOG.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_dilog = \&PDL::gsl_sf_dilog; #line 78 "DILOG.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_complex_dilog =for sig Signature: (double r(); double t(); double [o]re(); double [o]im(); double [o]ere(); double [o]eim()) =for ref DiLogarithm(z), for complex argument z = r Exp[i theta]. =for bad gsl_sf_complex_dilog does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 102 "DILOG.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_complex_dilog = \&PDL::gsl_sf_complex_dilog; #line 108 "DILOG.pm" #line 55 "gsl_sf_dilog.pd" =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin 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. The GSL SF modules were written by G. Jungman. =cut #line 127 "DILOG.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSLSF/ERF.pm0000644000175000017500000000702414200406314015635 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::ERF; our @EXPORT_OK = qw(gsl_sf_erfc gsl_sf_log_erfc gsl_sf_erf gsl_sf_erf_Z gsl_sf_erf_Q ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::ERF ; #line 5 "gsl_sf_erf.pd" use strict; use warnings; =head1 NAME PDL::GSLSF::ERF - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =cut #line 38 "ERF.pm" =head1 FUNCTIONS =cut #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_erfc =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Complementary Error Function erfc(x) := 2/Sqrt[Pi] Integrate[Exp[-t^2], {t,x,Infinity}] =for bad gsl_sf_erfc does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 72 "ERF.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_erfc = \&PDL::gsl_sf_erfc; #line 78 "ERF.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_log_erfc =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Log Complementary Error Function =for bad gsl_sf_log_erfc does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 102 "ERF.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_log_erfc = \&PDL::gsl_sf_log_erfc; #line 108 "ERF.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_erf =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Error Function erf(x) := 2/Sqrt[Pi] Integrate[Exp[-t^2], {t,0,x}] =for bad gsl_sf_erf does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 132 "ERF.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_erf = \&PDL::gsl_sf_erf; #line 138 "ERF.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_erf_Z =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Z(x) : Abramowitz+Stegun 26.2.1 =for bad gsl_sf_erf_Z does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 162 "ERF.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_erf_Z = \&PDL::gsl_sf_erf_Z; #line 168 "ERF.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_erf_Q =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Q(x) : Abramowitz+Stegun 26.2.1 =for bad gsl_sf_erf_Q does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 192 "ERF.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_erf_Q = \&PDL::gsl_sf_erf_Q; #line 198 "ERF.pm" #line 88 "gsl_sf_erf.pd" =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin 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. The GSL SF modules were written by G. Jungman. =cut #line 217 "ERF.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSLSF/ELLJAC.pm0000644000175000017500000000325014200406314016150 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::ELLJAC; our @EXPORT_OK = qw(gsl_sf_elljac ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::ELLJAC ; #line 5 "gsl_sf_elljac.pd" use strict; use warnings; =head1 NAME PDL::GSLSF::ELLJAC - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =cut #line 38 "ELLJAC.pm" =head1 FUNCTIONS =cut #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_elljac =for sig Signature: (double u(); double m(); double [o]sn(); double [o]cn(); double [o]dn()) =for ref Jacobian elliptic functions sn, dn, cn by descending Landen transformations =for bad gsl_sf_elljac does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 72 "ELLJAC.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_elljac = \&PDL::gsl_sf_elljac; #line 78 "ELLJAC.pm" #line 36 "gsl_sf_elljac.pd" =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin 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. The GSL SF modules were written by G. Jungman. =cut #line 97 "ELLJAC.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSLSF/COULOMB.pm0000644000175000017500000000751614200406314016327 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::COULOMB; our @EXPORT_OK = qw(gsl_sf_hydrogenicR gsl_sf_coulomb_wave_FGp_array gsl_sf_coulomb_wave_sphF_array gsl_sf_coulomb_CL_e ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::COULOMB ; #line 5 "gsl_sf_coulomb.pd" use strict; use warnings; =head1 NAME PDL::GSLSF::COULOMB - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut #line 40 "COULOMB.pm" =head1 FUNCTIONS =cut #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_hydrogenicR =for sig Signature: (double x(); double [o]y(); double [o]e(); int n; int l; double z) =for ref Normalized Hydrogenic bound states. Radial dipendence. =for bad gsl_sf_hydrogenicR does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 74 "COULOMB.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_hydrogenicR = \&PDL::gsl_sf_hydrogenicR; #line 80 "COULOMB.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_coulomb_wave_FGp_array =for sig Signature: (double x(); double [o]fc(n); double [o]fcp(n); double [o]gc(n); double [o]gcp(n); int [o]ovfw(); double [o]fe(n); double [o]ge(n); double lam_min; int kmax=>n; double eta) =for ref Coulomb wave functions F_{lam_F}(eta,x), G_{lam_G}(eta,x) and their derivatives; lam_G := lam_F - k_lam_G. if ovfw is signaled then F_L(eta,x) = fc[k_L] * exp(fe) and similar. =for bad gsl_sf_coulomb_wave_FGp_array does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 104 "COULOMB.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_coulomb_wave_FGp_array = \&PDL::gsl_sf_coulomb_wave_FGp_array; #line 110 "COULOMB.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_coulomb_wave_sphF_array =for sig Signature: (double x(); double [o]fc(n); int [o]ovfw(); double [o]fe(n); double lam_min; int kmax=>n; double eta) =for ref Coulomb wave function divided by the argument, F(xi, eta)/xi. This is the function which reduces to spherical Bessel functions in the limit eta->0. =for bad gsl_sf_coulomb_wave_sphF_array does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 134 "COULOMB.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_coulomb_wave_sphF_array = \&PDL::gsl_sf_coulomb_wave_sphF_array; #line 140 "COULOMB.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_coulomb_CL_e =for sig Signature: (double L(); double eta(); double [o]y(); double [o]e()) =for ref Coulomb wave function normalization constant. [Abramowitz+Stegun 14.1.8, 14.1.9]. =for bad gsl_sf_coulomb_CL_e does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 164 "COULOMB.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_coulomb_CL_e = \&PDL::gsl_sf_coulomb_CL_e; #line 170 "COULOMB.pm" #line 91 "gsl_sf_coulomb.pd" =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin 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. The GSL SF modules were written by G. Jungman. =cut #line 189 "COULOMB.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSLSF/COUPLING.pm0000644000175000017500000000543314200406314016443 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::COUPLING; our @EXPORT_OK = qw(gsl_sf_coupling_3j gsl_sf_coupling_6j gsl_sf_coupling_9j ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::COUPLING ; #line 5 "gsl_sf_coupling.pd" use strict; use warnings; =head1 NAME PDL::GSLSF::COUPLING - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =cut #line 38 "COUPLING.pm" =head1 FUNCTIONS =cut #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_coupling_3j =for sig Signature: (ja(); jb(); jc(); ma(); mb(); mc(); double [o]y(); double [o]e()) =for ref 3j Symbols: (ja jb jc) over (ma mb mc). =for bad gsl_sf_coupling_3j does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 72 "COUPLING.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_coupling_3j = \&PDL::gsl_sf_coupling_3j; #line 78 "COUPLING.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_coupling_6j =for sig Signature: (ja(); jb(); jc(); jd(); je(); jf(); double [o]y(); double [o]e()) =for ref 6j Symbols: (ja jb jc) over (jd je jf). =for bad gsl_sf_coupling_6j does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 102 "COUPLING.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_coupling_6j = \&PDL::gsl_sf_coupling_6j; #line 108 "COUPLING.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_coupling_9j =for sig Signature: (ja(); jb(); jc(); jd(); je(); jf(); jg(); jh(); ji(); double [o]y(); double [o]e()) =for ref 9j Symbols: (ja jb jc) over (jd je jf) over (jg jh ji). =for bad gsl_sf_coupling_9j does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 132 "COUPLING.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_coupling_9j = \&PDL::gsl_sf_coupling_9j; #line 138 "COUPLING.pm" #line 65 "gsl_sf_coupling.pd" =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin 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. The GSL SF modules were written by G. Jungman. =cut #line 157 "COUPLING.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSLSF/ELLINT.pm0000644000175000017500000001575614200406314016223 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::ELLINT; our @EXPORT_OK = qw(gsl_sf_ellint_Kcomp gsl_sf_ellint_Ecomp gsl_sf_ellint_F gsl_sf_ellint_E gsl_sf_ellint_P gsl_sf_ellint_D gsl_sf_ellint_RC gsl_sf_ellint_RD gsl_sf_ellint_RF gsl_sf_ellint_RJ ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::ELLINT ; #line 6 "gsl_sf_ellint.pd" use strict; use warnings; =head1 NAME PDL::GSLSF::ELLINT - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =cut #line 38 "ELLINT.pm" =head1 FUNCTIONS =cut #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_ellint_Kcomp =for sig Signature: (double k(); double [o]y(); double [o]e()) =for ref Legendre form of complete elliptic integrals K(k) = Integral[1/Sqrt[1 - k^2 Sin[t]^2], {t, 0, Pi/2}]. =for bad gsl_sf_ellint_Kcomp does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 72 "ELLINT.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_ellint_Kcomp = \&PDL::gsl_sf_ellint_Kcomp; #line 78 "ELLINT.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_ellint_Ecomp =for sig Signature: (double k(); double [o]y(); double [o]e()) =for ref Legendre form of complete elliptic integrals E(k) = Integral[ Sqrt[1 - k^2 Sin[t]^2], {t, 0, Pi/2}] =for bad gsl_sf_ellint_Ecomp does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 102 "ELLINT.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_ellint_Ecomp = \&PDL::gsl_sf_ellint_Ecomp; #line 108 "ELLINT.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_ellint_F =for sig Signature: (double phi(); double k(); double [o]y(); double [o]e()) =for ref Legendre form of incomplete elliptic integrals F(phi,k) = Integral[1/Sqrt[1 - k^2 Sin[t]^2], {t, 0, phi}] =for bad gsl_sf_ellint_F does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 132 "ELLINT.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_ellint_F = \&PDL::gsl_sf_ellint_F; #line 138 "ELLINT.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_ellint_E =for sig Signature: (double phi(); double k(); double [o]y(); double [o]e()) =for ref Legendre form of incomplete elliptic integrals E(phi,k) = Integral[ Sqrt[1 - k^2 Sin[t]^2], {t, 0, phi}] =for bad gsl_sf_ellint_E does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 162 "ELLINT.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_ellint_E = \&PDL::gsl_sf_ellint_E; #line 168 "ELLINT.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_ellint_P =for sig Signature: (double phi(); double k(); double n(); double [o]y(); double [o]e()) =for ref Legendre form of incomplete elliptic integrals P(phi,k,n) = Integral[(1 + n Sin[t]^2)^(-1)/Sqrt[1 - k^2 Sin[t]^2], {t, 0, phi}] =for bad gsl_sf_ellint_P does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 193 "ELLINT.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_ellint_P = \&PDL::gsl_sf_ellint_P; #line 199 "ELLINT.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_ellint_D =for sig Signature: (double phi(); double k(); double [o]y(); double [o]e()) =for ref Legendre form of incomplete elliptic integrals D(phi,k) =for bad gsl_sf_ellint_D does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 224 "ELLINT.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_ellint_D = \&PDL::gsl_sf_ellint_D; #line 230 "ELLINT.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_ellint_RC =for sig Signature: (double x(); double yy(); double [o]y(); double [o]e()) =for ref Carlsons symmetric basis of functions RC(x,y) = 1/2 Integral[(t+x)^(-1/2) (t+y)^(-1)], {t,0,Inf} =for bad gsl_sf_ellint_RC does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 254 "ELLINT.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_ellint_RC = \&PDL::gsl_sf_ellint_RC; #line 260 "ELLINT.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_ellint_RD =for sig Signature: (double x(); double yy(); double z(); double [o]y(); double [o]e()) =for ref Carlsons symmetric basis of functions RD(x,y,z) = 3/2 Integral[(t+x)^(-1/2) (t+y)^(-1/2) (t+z)^(-3/2), {t,0,Inf}] =for bad gsl_sf_ellint_RD does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 284 "ELLINT.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_ellint_RD = \&PDL::gsl_sf_ellint_RD; #line 290 "ELLINT.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_ellint_RF =for sig Signature: (double x(); double yy(); double z(); double [o]y(); double [o]e()) =for ref Carlsons symmetric basis of functions RF(x,y,z) = 1/2 Integral[(t+x)^(-1/2) (t+y)^(-1/2) (t+z)^(-1/2), {t,0,Inf}] =for bad gsl_sf_ellint_RF does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 314 "ELLINT.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_ellint_RF = \&PDL::gsl_sf_ellint_RF; #line 320 "ELLINT.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_ellint_RJ =for sig Signature: (double x(); double yy(); double z(); double p(); double [o]y(); double [o]e()) =for ref Carlsons symmetric basis of functions RJ(x,y,z,p) = 3/2 Integral[(t+x)^(-1/2) (t+y)^(-1/2) (t+z)^(-1/2) (t+p)^(-1), {t,0,Inf}] =for bad gsl_sf_ellint_RJ does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 344 "ELLINT.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_ellint_RJ = \&PDL::gsl_sf_ellint_RJ; #line 350 "ELLINT.pm" #line 172 "gsl_sf_ellint.pd" =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin , 2002 Christian Soeller. 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. The GSL SF modules were written by G. Jungman. =cut #line 370 "ELLINT.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSLSF/LAGUERRE.pm0000644000175000017500000000324114200406315016425 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::LAGUERRE; our @EXPORT_OK = qw(gsl_sf_laguerre_n ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::LAGUERRE ; #line 5 "gsl_sf_laguerre.pd" use strict; use warnings; =head1 NAME PDL::GSLSF::LAGUERRE - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =cut #line 38 "LAGUERRE.pm" =head1 FUNCTIONS =cut #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_laguerre_n =for sig Signature: (double x(); double [o]y(); double [o]e(); int n; double a) =for ref Evaluate generalized Laguerre polynomials. =for bad gsl_sf_laguerre_n does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 72 "LAGUERRE.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_laguerre_n = \&PDL::gsl_sf_laguerre_n; #line 78 "LAGUERRE.pm" #line 40 "gsl_sf_laguerre.pd" =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin 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. The GSL SF modules were written by G. Jungman. =cut #line 98 "LAGUERRE.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSLSF/POW_INT.pm0000644000175000017500000000314214200406316016377 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::POW_INT; our @EXPORT_OK = qw(gsl_sf_pow_int ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::POW_INT ; #line 5 "gsl_sf_pow_int.pd" use strict; use warnings; =head1 NAME PDL::GSLSF::POW_INT - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =cut #line 38 "POW_INT.pm" =head1 FUNCTIONS =cut #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_pow_int =for sig Signature: (double x(); double [o]y(); double [o]e(); int n) =for ref Calculate x^n. =for bad gsl_sf_pow_int does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 72 "POW_INT.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_pow_int = \&PDL::gsl_sf_pow_int; #line 78 "POW_INT.pm" #line 43 "gsl_sf_pow_int.pd" =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin 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. The GSL SF modules were written by G. Jungman. =cut #line 97 "POW_INT.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSLSF/ELEMENTARY.pm0000644000175000017500000000431014200406314016661 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::ELEMENTARY; our @EXPORT_OK = qw(gsl_sf_multiply gsl_sf_multiply_err ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::ELEMENTARY ; #line 5 "gsl_sf_elementary.pd" use strict; use warnings; =head1 NAME PDL::GSLSF::ELEMENTARY - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =cut #line 38 "ELEMENTARY.pm" =head1 FUNCTIONS =cut #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_multiply =for sig Signature: (double x(); double xx(); double [o]y(); double [o]e()) =for ref Multiplication. =for bad gsl_sf_multiply does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 72 "ELEMENTARY.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_multiply = \&PDL::gsl_sf_multiply; #line 78 "ELEMENTARY.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_multiply_err =for sig Signature: (double x(); double xe(); double xx(); double xxe(); double [o]y(); double [o]e()) =for ref Multiplication with associated errors. =for bad gsl_sf_multiply_err does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 102 "ELEMENTARY.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_multiply_err = \&PDL::gsl_sf_multiply_err; #line 108 "ELEMENTARY.pm" #line 52 "gsl_sf_elementary.pd" =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin 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. The GSL SF modules were written by G. Jungman. =cut #line 127 "ELEMENTARY.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSLSF/CLAUSEN.pm0000644000175000017500000000321614200406313016311 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::CLAUSEN; our @EXPORT_OK = qw(gsl_sf_clausen ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::CLAUSEN ; #line 5 "gsl_sf_clausen.pd" use strict; use warnings; =head1 NAME PDL::GSLSF::CLAUSEN - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =cut #line 38 "CLAUSEN.pm" =head1 FUNCTIONS =cut #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_clausen =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Clausen Integral. Cl_2(x) := Integrate[-Log[2 Sin[t/2]], {t,0,x}] =for bad gsl_sf_clausen does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 72 "CLAUSEN.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_clausen = \&PDL::gsl_sf_clausen; #line 78 "CLAUSEN.pm" #line 40 "gsl_sf_clausen.pd" =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin 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. The GSL SF modules were written by G. Jungman. =cut #line 97 "CLAUSEN.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSLSF/LOG.pm0000644000175000017500000000423714200406315015646 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::LOG; our @EXPORT_OK = qw(gsl_sf_log gsl_sf_complex_log ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::LOG ; #line 5 "gsl_sf_log.pd" use strict; use warnings; =head1 NAME PDL::GSLSF::LOG - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =cut #line 38 "LOG.pm" =head1 FUNCTIONS =cut #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_log =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Provide a logarithm function with GSL semantics. =for bad gsl_sf_log does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 72 "LOG.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_log = \&PDL::gsl_sf_log; #line 78 "LOG.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_complex_log =for sig Signature: (double zr(); double zi(); double [o]x(); double [o]y(); double [o]xe(); double [o]ye()) =for ref Complex Logarithm exp(lnr + I theta) = zr + I zi Returns argument in [-pi,pi]. =for bad gsl_sf_complex_log does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 102 "LOG.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_complex_log = \&PDL::gsl_sf_complex_log; #line 108 "LOG.pm" #line 58 "gsl_sf_log.pd" =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin 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. The GSL SF modules were written by G. Jungman. =cut #line 127 "LOG.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSLSF/TRANSPORT.pm0000644000175000017500000000622214200406316016616 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::TRANSPORT; our @EXPORT_OK = qw(gsl_sf_transport_2 gsl_sf_transport_3 gsl_sf_transport_4 gsl_sf_transport_5 ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::TRANSPORT ; #line 5 "gsl_sf_transport.pd" use strict; use warnings; =head1 NAME PDL::GSLSF::TRANSPORT - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. Transport function: J(n,x) := Integral[ t^n e^t /(e^t - 1)^2, {t,0,x}] =cut #line 42 "TRANSPORT.pm" =head1 FUNCTIONS =cut #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_transport_2 =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref J(2,x) =for bad gsl_sf_transport_2 does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 76 "TRANSPORT.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_transport_2 = \&PDL::gsl_sf_transport_2; #line 82 "TRANSPORT.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_transport_3 =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref J(3,x) =for bad gsl_sf_transport_3 does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 106 "TRANSPORT.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_transport_3 = \&PDL::gsl_sf_transport_3; #line 112 "TRANSPORT.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_transport_4 =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref J(4,x) =for bad gsl_sf_transport_4 does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 136 "TRANSPORT.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_transport_4 = \&PDL::gsl_sf_transport_4; #line 142 "TRANSPORT.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_transport_5 =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref J(5,x) =for bad gsl_sf_transport_5 does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 166 "TRANSPORT.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_transport_5 = \&PDL::gsl_sf_transport_5; #line 172 "TRANSPORT.pm" #line 81 "gsl_sf_transport.pd" =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin 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. The GSL SF modules were written by G. Jungman. =cut #line 191 "TRANSPORT.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSLSF/AIRY.pm0000644000175000017500000001262614200406313015770 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::AIRY; our @EXPORT_OK = qw(gsl_sf_airy_Ai gsl_sf_airy_Bi gsl_sf_airy_Ai_scaled gsl_sf_airy_Bi_scaled gsl_sf_airy_Ai_deriv gsl_sf_airy_Bi_deriv gsl_sf_airy_Ai_deriv_scaled gsl_sf_airy_Bi_deriv_scaled ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::AIRY ; #line 5 "gsl_sf_airy.pd" use strict; use warnings; =head1 NAME PDL::GSLSF::AIRY - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =cut #line 38 "AIRY.pm" =head1 FUNCTIONS =cut #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_airy_Ai =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Airy Function Ai(x). =for bad gsl_sf_airy_Ai does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 72 "AIRY.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_airy_Ai = \&PDL::gsl_sf_airy_Ai; #line 78 "AIRY.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_airy_Bi =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Airy Function Bi(x). =for bad gsl_sf_airy_Bi does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 102 "AIRY.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_airy_Bi = \&PDL::gsl_sf_airy_Bi; #line 108 "AIRY.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_airy_Ai_scaled =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Scaled Airy Function Ai(x). Ai(x) for x < 0 and exp(+2/3 x^{3/2}) Ai(x) for x > 0. =for bad gsl_sf_airy_Ai_scaled does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 132 "AIRY.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_airy_Ai_scaled = \&PDL::gsl_sf_airy_Ai_scaled; #line 138 "AIRY.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_airy_Bi_scaled =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Scaled Airy Function Bi(x). Bi(x) for x < 0 and exp(+2/3 x^{3/2}) Bi(x) for x > 0. =for bad gsl_sf_airy_Bi_scaled does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 162 "AIRY.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_airy_Bi_scaled = \&PDL::gsl_sf_airy_Bi_scaled; #line 168 "AIRY.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_airy_Ai_deriv =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Derivative Airy Function Ai`(x). =for bad gsl_sf_airy_Ai_deriv does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 192 "AIRY.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_airy_Ai_deriv = \&PDL::gsl_sf_airy_Ai_deriv; #line 198 "AIRY.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_airy_Bi_deriv =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Derivative Airy Function Bi`(x). =for bad gsl_sf_airy_Bi_deriv does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 222 "AIRY.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_airy_Bi_deriv = \&PDL::gsl_sf_airy_Bi_deriv; #line 228 "AIRY.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_airy_Ai_deriv_scaled =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Derivative Scaled Airy Function Ai(x). Ai`(x) for x < 0 and exp(+2/3 x^{3/2}) Ai`(x) for x > 0. =for bad gsl_sf_airy_Ai_deriv_scaled does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 252 "AIRY.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_airy_Ai_deriv_scaled = \&PDL::gsl_sf_airy_Ai_deriv_scaled; #line 258 "AIRY.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_airy_Bi_deriv_scaled =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Derivative Scaled Airy Function Bi(x). Bi`(x) for x < 0 and exp(+2/3 x^{3/2}) Bi`(x) for x > 0. =for bad gsl_sf_airy_Bi_deriv_scaled does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 282 "AIRY.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_airy_Bi_deriv_scaled = \&PDL::gsl_sf_airy_Bi_deriv_scaled; #line 288 "AIRY.pm" #line 64 "gsl_sf_airy.pd" =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin 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. The GSL SF modules were written by G. Jungman. =cut #line 307 "AIRY.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSLSF/DAWSON.pm0000644000175000017500000000321014200406314016205 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::DAWSON; our @EXPORT_OK = qw(gsl_sf_dawson ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::DAWSON ; #line 5 "gsl_sf_dawson.pd" use strict; use warnings; =head1 NAME PDL::GSLSF::DAWSON - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =head1 SYNOPSIS =cut #line 40 "DAWSON.pm" =head1 FUNCTIONS =cut #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_dawson =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Dawsons integral: Exp[-x^2] Integral[ Exp[t^2], {t,0,x}] =for bad gsl_sf_dawson does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 74 "DAWSON.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_dawson = \&PDL::gsl_sf_dawson; #line 80 "DAWSON.pm" #line 43 "gsl_sf_dawson.pd" =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin 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. The GSL SF modules were written by G. Jungman. =cut #line 99 "DAWSON.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSLSF/TRIG.pm0000644000175000017500000002041514200406316015767 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::TRIG; our @EXPORT_OK = qw(gsl_sf_sin gsl_sf_cos gsl_sf_hypot gsl_sf_complex_sin gsl_sf_complex_cos gsl_sf_complex_logsin gsl_sf_lnsinh gsl_sf_lncosh gsl_sf_polar_to_rect gsl_sf_rect_to_polar gsl_sf_angle_restrict_symm gsl_sf_angle_restrict_pos gsl_sf_sin_err gsl_sf_cos_err ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::TRIG ; #line 5 "gsl_sf_trig.pd" use strict; use warnings; =head1 NAME PDL::GSLSF::TRIG - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =cut #line 38 "TRIG.pm" =head1 FUNCTIONS =cut #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_sin =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Sin(x) with GSL semantics. =for bad gsl_sf_sin does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 72 "TRIG.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_sin = \&PDL::gsl_sf_sin; #line 78 "TRIG.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_cos =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Cos(x) with GSL semantics. =for bad gsl_sf_cos does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 102 "TRIG.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_cos = \&PDL::gsl_sf_cos; #line 108 "TRIG.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_hypot =for sig Signature: (double x(); double xx(); double [o]y(); double [o]e()) =for ref Hypot(x,xx) with GSL semantics. =for bad gsl_sf_hypot does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 132 "TRIG.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_hypot = \&PDL::gsl_sf_hypot; #line 138 "TRIG.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_complex_sin =for sig Signature: (double zr(); double zi(); double [o]x(); double [o]y(); double [o]xe(); double [o]ye()) =for ref Sin(z) for complex z =for bad gsl_sf_complex_sin does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 162 "TRIG.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_complex_sin = \&PDL::gsl_sf_complex_sin; #line 168 "TRIG.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_complex_cos =for sig Signature: (double zr(); double zi(); double [o]x(); double [o]y(); double [o]xe(); double [o]ye()) =for ref Cos(z) for complex z =for bad gsl_sf_complex_cos does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 192 "TRIG.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_complex_cos = \&PDL::gsl_sf_complex_cos; #line 198 "TRIG.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_complex_logsin =for sig Signature: (double zr(); double zi(); double [o]x(); double [o]y(); double [o]xe(); double [o]ye()) =for ref Log(Sin(z)) for complex z =for bad gsl_sf_complex_logsin does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 222 "TRIG.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_complex_logsin = \&PDL::gsl_sf_complex_logsin; #line 228 "TRIG.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_lnsinh =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Log(Sinh(x)) with GSL semantics. =for bad gsl_sf_lnsinh does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 252 "TRIG.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_lnsinh = \&PDL::gsl_sf_lnsinh; #line 258 "TRIG.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_lncosh =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Log(Cos(x)) with GSL semantics. =for bad gsl_sf_lncosh does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 282 "TRIG.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_lncosh = \&PDL::gsl_sf_lncosh; #line 288 "TRIG.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_polar_to_rect =for sig Signature: (double r(); double t(); double [o]x(); double [o]y(); double [o]xe(); double [o]ye()) =for ref Convert polar to rectlinear coordinates. =for bad gsl_sf_polar_to_rect does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 312 "TRIG.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_polar_to_rect = \&PDL::gsl_sf_polar_to_rect; #line 318 "TRIG.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_rect_to_polar =for sig Signature: (double x(); double y(); double [o]r(); double [o]t(); double [o]re(); double [o]te()) =for ref Convert rectlinear to polar coordinates. return argument in range [-pi, pi]. =for bad gsl_sf_rect_to_polar does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 342 "TRIG.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_rect_to_polar = \&PDL::gsl_sf_rect_to_polar; #line 348 "TRIG.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_angle_restrict_symm =for sig Signature: (double [o]y()) =for ref Force an angle to lie in the range (-pi,pi]. =for bad gsl_sf_angle_restrict_symm does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 372 "TRIG.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_angle_restrict_symm = \&PDL::gsl_sf_angle_restrict_symm; #line 378 "TRIG.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_angle_restrict_pos =for sig Signature: (double [o]y()) =for ref Force an angle to lie in the range [0,2 pi). =for bad gsl_sf_angle_restrict_pos does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 402 "TRIG.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_angle_restrict_pos = \&PDL::gsl_sf_angle_restrict_pos; #line 408 "TRIG.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_sin_err =for sig Signature: (double x(); double dx(); double [o]y(); double [o]e()) =for ref Sin(x) for quantity with an associated error. =for bad gsl_sf_sin_err does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 432 "TRIG.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_sin_err = \&PDL::gsl_sf_sin_err; #line 438 "TRIG.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_cos_err =for sig Signature: (double x(); double dx(); double [o]y(); double [o]e()) =for ref Cos(x) for quantity with an associated error. =for bad gsl_sf_cos_err does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 462 "TRIG.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_cos_err = \&PDL::gsl_sf_cos_err; #line 468 "TRIG.pm" #line 204 "gsl_sf_trig.pd" =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin 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. The GSL SF modules were written by G. Jungman. =cut #line 487 "TRIG.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSLSF/FERMI_DIRAC.pm0000644000175000017500000001015714200406315016767 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::FERMI_DIRAC; our @EXPORT_OK = qw(gsl_sf_fermi_dirac_int gsl_sf_fermi_dirac_mhalf gsl_sf_fermi_dirac_half gsl_sf_fermi_dirac_3half gsl_sf_fermi_dirac_inc_0 ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::FERMI_DIRAC ; #line 5 "gsl_sf_fermi_dirac.pd" use strict; use warnings; =head1 NAME PDL::GSLSF::FERMI_DIRAC - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. Please note that: Complete Fermi-Dirac Integrals: F_j(x) := 1/Gamma[j+1] Integral[ t^j /(Exp[t-x] + 1), {t,0,Infinity}] Incomplete Fermi-Dirac Integrals: F_j(x,b) := 1/Gamma[j+1] Integral[ t^j /(Exp[t-x] + 1), {t,b,Infinity}] =cut #line 48 "FERMI_DIRAC.pm" =head1 FUNCTIONS =cut #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_fermi_dirac_int =for sig Signature: (double x(); double [o]y(); double [o]e(); int j) =for ref Complete integral F_j(x) for integer j =for bad gsl_sf_fermi_dirac_int does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 82 "FERMI_DIRAC.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_fermi_dirac_int = \&PDL::gsl_sf_fermi_dirac_int; #line 88 "FERMI_DIRAC.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_fermi_dirac_mhalf =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Complete integral F_{-1/2}(x) =for bad gsl_sf_fermi_dirac_mhalf does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 112 "FERMI_DIRAC.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_fermi_dirac_mhalf = \&PDL::gsl_sf_fermi_dirac_mhalf; #line 118 "FERMI_DIRAC.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_fermi_dirac_half =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Complete integral F_{1/2}(x) =for bad gsl_sf_fermi_dirac_half does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 142 "FERMI_DIRAC.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_fermi_dirac_half = \&PDL::gsl_sf_fermi_dirac_half; #line 148 "FERMI_DIRAC.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_fermi_dirac_3half =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Complete integral F_{3/2}(x) =for bad gsl_sf_fermi_dirac_3half does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 172 "FERMI_DIRAC.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_fermi_dirac_3half = \&PDL::gsl_sf_fermi_dirac_3half; #line 178 "FERMI_DIRAC.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_fermi_dirac_inc_0 =for sig Signature: (double x(); double [o]y(); double [o]e(); double b) =for ref Incomplete integral F_0(x,b) = ln(1 + e^(b-x)) - (b-x) =for bad gsl_sf_fermi_dirac_inc_0 does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 202 "FERMI_DIRAC.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_fermi_dirac_inc_0 = \&PDL::gsl_sf_fermi_dirac_inc_0; #line 208 "FERMI_DIRAC.pm" #line 101 "gsl_sf_fermi_dirac.pd" =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin 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. The GSL SF modules were written by G. Jungman. =cut #line 227 "FERMI_DIRAC.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSLSF/PSI.pm0000644000175000017500000000512714200406316015660 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::PSI; our @EXPORT_OK = qw(gsl_sf_psi gsl_sf_psi_1piy gsl_sf_psi_n ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::PSI ; #line 5 "gsl_sf_psi.pd" use strict; use warnings; =head1 NAME PDL::GSLSF::PSI - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. Poly-Gamma Functions psi(m,x) := (d/dx)^m psi(0,x) = (d/dx)^{m+1} log(gamma(x)) =cut #line 42 "PSI.pm" =head1 FUNCTIONS =cut #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_psi =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Di-Gamma Function psi(x). =for bad gsl_sf_psi does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 76 "PSI.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_psi = \&PDL::gsl_sf_psi; #line 82 "PSI.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_psi_1piy =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Di-Gamma Function Re[psi(1 + I y)] =for bad gsl_sf_psi_1piy does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 106 "PSI.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_psi_1piy = \&PDL::gsl_sf_psi_1piy; #line 112 "PSI.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_psi_n =for sig Signature: (double x(); double [o]y(); double [o]e(); int n) =for ref Poly-Gamma Function psi^(n)(x) =for bad gsl_sf_psi_n does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 136 "PSI.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_psi_n = \&PDL::gsl_sf_psi_n; #line 142 "PSI.pm" #line 70 "gsl_sf_psi.pd" =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin 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. The GSL SF modules were written by G. Jungman. =cut #line 161 "PSI.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSLSF/GEGENBAUER.pm0000644000175000017500000000437214200406315016631 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::GEGENBAUER; our @EXPORT_OK = qw(gsl_sf_gegenpoly_n gsl_sf_gegenpoly_array ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::GEGENBAUER ; #line 5 "gsl_sf_gegenbauer.pd" use strict; use warnings; =head1 NAME PDL::GSLSF::GEGENBAUER - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =cut #line 38 "GEGENBAUER.pm" =head1 FUNCTIONS =cut #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_gegenpoly_n =for sig Signature: (double x(); double [o]y(); double [o]e(); int n; double lambda) =for ref Evaluate Gegenbauer polynomials. =for bad gsl_sf_gegenpoly_n does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 72 "GEGENBAUER.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_gegenpoly_n = \&PDL::gsl_sf_gegenpoly_n; #line 78 "GEGENBAUER.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_gegenpoly_array =for sig Signature: (double x(); double [o]y(num); int n=>num; double lambda) =for ref Calculate array of Gegenbauer polynomials from 0 to n-1. =for bad gsl_sf_gegenpoly_array does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 102 "GEGENBAUER.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_gegenpoly_array = \&PDL::gsl_sf_gegenpoly_array; #line 108 "GEGENBAUER.pm" #line 50 "gsl_sf_gegenbauer.pd" =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin 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. The GSL SF modules were written by G. Jungman. =cut #line 128 "GEGENBAUER.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSLSF/DEBYE.pm0000644000175000017500000000614714200406314016056 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::DEBYE; our @EXPORT_OK = qw(gsl_sf_debye_1 gsl_sf_debye_2 gsl_sf_debye_3 gsl_sf_debye_4 ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::DEBYE ; #line 5 "gsl_sf_debye.pd" use strict; use warnings; =head1 NAME PDL::GSLSF::DEBYE - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =cut #line 38 "DEBYE.pm" =head1 FUNCTIONS =cut #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_debye_1 =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref D_n(x) := n/x^n Integrate[t^n/(e^t - 1), {t,0,x}] =for bad gsl_sf_debye_1 does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 72 "DEBYE.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_debye_1 = \&PDL::gsl_sf_debye_1; #line 78 "DEBYE.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_debye_2 =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref D_n(x) := n/x^n Integrate[t^n/(e^t - 1), {t,0,x}] =for bad gsl_sf_debye_2 does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 102 "DEBYE.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_debye_2 = \&PDL::gsl_sf_debye_2; #line 108 "DEBYE.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_debye_3 =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref D_n(x) := n/x^n Integrate[t^n/(e^t - 1), {t,0,x}] =for bad gsl_sf_debye_3 does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 132 "DEBYE.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_debye_3 = \&PDL::gsl_sf_debye_3; #line 138 "DEBYE.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_debye_4 =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref D_n(x) := n/x^n Integrate[t^n/(e^t - 1), {t,0,x}] =for bad gsl_sf_debye_4 does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 162 "DEBYE.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_debye_4 = \&PDL::gsl_sf_debye_4; #line 168 "DEBYE.pm" #line 75 "gsl_sf_debye.pd" =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin 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. The GSL SF modules were written by G. Jungman. =cut #line 187 "DEBYE.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSLSF/SYNCHROTRON.pm0000644000175000017500000000443414200406316017055 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::SYNCHROTRON; our @EXPORT_OK = qw(gsl_sf_synchrotron_1 gsl_sf_synchrotron_2 ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::SYNCHROTRON ; #line 5 "gsl_sf_synchrotron.pd" use strict; use warnings; =head1 NAME PDL::GSLSF::SYNCHROTRON - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =cut #line 38 "SYNCHROTRON.pm" =head1 FUNCTIONS =cut #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_synchrotron_1 =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref First synchrotron function: synchrotron_1(x) = x Integral[ K_{5/3}(t), {t, x, Infinity}] =for bad gsl_sf_synchrotron_1 does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 72 "SYNCHROTRON.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_synchrotron_1 = \&PDL::gsl_sf_synchrotron_1; #line 78 "SYNCHROTRON.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_synchrotron_2 =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Second synchroton function: synchrotron_2(x) = x * K_{2/3}(x) =for bad gsl_sf_synchrotron_2 does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 102 "SYNCHROTRON.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_synchrotron_2 = \&PDL::gsl_sf_synchrotron_2; #line 108 "SYNCHROTRON.pm" #line 51 "gsl_sf_synchrotron.pd" =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin 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. The GSL SF modules were written by G. Jungman. =cut #line 127 "SYNCHROTRON.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSLSF/LEGENDRE.pm0000644000175000017500000002460414200406315016412 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::LEGENDRE; our @EXPORT_OK = qw(gsl_sf_legendre_Pl gsl_sf_legendre_Pl_array gsl_sf_legendre_Ql gsl_sf_legendre_Plm gsl_sf_legendre_array gsl_sf_legendre_array_index gsl_sf_legendre_sphPlm gsl_sf_conicalP_half gsl_sf_conicalP_mhalf gsl_sf_conicalP_0 gsl_sf_conicalP_1 gsl_sf_conicalP_sph_reg gsl_sf_conicalP_cyl_reg_e gsl_sf_legendre_H3d gsl_sf_legendre_H3d_array ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::LEGENDRE ; #line 6 "gsl_sf_legendre.pd" use strict; use warnings; =head1 NAME PDL::GSLSF::LEGENDRE - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =cut #line 38 "LEGENDRE.pm" =head1 FUNCTIONS =cut #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_legendre_Pl =for sig Signature: (double x(); double [o]y(); double [o]e(); int l) =for ref P_l(x) =for bad gsl_sf_legendre_Pl does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 72 "LEGENDRE.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_legendre_Pl = \&PDL::gsl_sf_legendre_Pl; #line 78 "LEGENDRE.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_legendre_Pl_array =for sig Signature: (double x(); double [o]y(num); int l=>num) =for ref P_l(x) from 0 to n-1. =for bad gsl_sf_legendre_Pl_array does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 102 "LEGENDRE.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_legendre_Pl_array = \&PDL::gsl_sf_legendre_Pl_array; #line 108 "LEGENDRE.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_legendre_Ql =for sig Signature: (double x(); double [o]y(); double [o]e(); int l) =for ref Q_l(x) =for bad gsl_sf_legendre_Ql does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 132 "LEGENDRE.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_legendre_Ql = \&PDL::gsl_sf_legendre_Ql; #line 138 "LEGENDRE.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_legendre_Plm =for sig Signature: (double x(); double [o]y(); double [o]e(); int l; int m) =for ref P_lm(x) =for bad gsl_sf_legendre_Plm does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 162 "LEGENDRE.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_legendre_Plm = \&PDL::gsl_sf_legendre_Plm; #line 168 "LEGENDRE.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_legendre_array =for sig Signature: (double x(); double [o]y(n); double [t]work(wn); char norm; int lmax; int csphase) =for ref Calculate all normalized associated Legendre polynomials. =for usage $Plm = gsl_sf_legendre_array($x,'P',4,-1); The calculation is done for degree 0 <= l <= lmax and order 0 <= m <= l on the range abs(x)<=1. The parameter norm should be: =over 3 =item 'P' for unnormalized associated Legendre polynomials P_l^m(x), =item 'S' for Schmidt semi-normalized associated Legendre polynomials S_l^m(x), =item 'Y' for spherical harmonic associated Legendre polynomials Y_l^m(x), or =item 'N' for fully normalized associated Legendre polynomials N_l^m(x). =back lmax is the maximum degree l. csphase should be (-1) to INCLUDE the Condon-Shortley phase factor (-1)^m, or (+1) to EXCLUDE it. See L to get the value of C and C in the returned vector. =for bad gsl_sf_legendre_array processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 219 "LEGENDRE.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_legendre_array = \&PDL::gsl_sf_legendre_array; #line 225 "LEGENDRE.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_legendre_array_index =for sig Signature: (int [o]l(n); int [o]m(n); int lmax) =for ref Calculate the relation between gsl_sf_legendre_arrays index and l and m values. =for usage ($l,$m) = gsl_sf_legendre_array_index($lmax); Note that this function is called differently than the corresponding GSL function, to make it more useful for PDL: here you just input the maximum l (lmax) that was used in C and it calculates all l and m values. =for bad gsl_sf_legendre_array_index does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 254 "LEGENDRE.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_legendre_array_index = \&PDL::gsl_sf_legendre_array_index; #line 260 "LEGENDRE.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_legendre_sphPlm =for sig Signature: (double x(); double [o]y(); double [o]e(); int l; int m) =for ref P_lm(x), normalized properly for use in spherical harmonics =for bad gsl_sf_legendre_sphPlm does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 284 "LEGENDRE.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_legendre_sphPlm = \&PDL::gsl_sf_legendre_sphPlm; #line 290 "LEGENDRE.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_conicalP_half =for sig Signature: (double x(); double [o]y(); double [o]e(); double lambda) =for ref Irregular Spherical Conical Function P^{1/2}_{-1/2 + I lambda}(x) =for bad gsl_sf_conicalP_half does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 314 "LEGENDRE.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_conicalP_half = \&PDL::gsl_sf_conicalP_half; #line 320 "LEGENDRE.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_conicalP_mhalf =for sig Signature: (double x(); double [o]y(); double [o]e(); double lambda) =for ref Regular Spherical Conical Function P^{-1/2}_{-1/2 + I lambda}(x) =for bad gsl_sf_conicalP_mhalf does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 344 "LEGENDRE.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_conicalP_mhalf = \&PDL::gsl_sf_conicalP_mhalf; #line 350 "LEGENDRE.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_conicalP_0 =for sig Signature: (double x(); double [o]y(); double [o]e(); double lambda) =for ref Conical Function P^{0}_{-1/2 + I lambda}(x) =for bad gsl_sf_conicalP_0 does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 374 "LEGENDRE.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_conicalP_0 = \&PDL::gsl_sf_conicalP_0; #line 380 "LEGENDRE.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_conicalP_1 =for sig Signature: (double x(); double [o]y(); double [o]e(); double lambda) =for ref Conical Function P^{1}_{-1/2 + I lambda}(x) =for bad gsl_sf_conicalP_1 does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 404 "LEGENDRE.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_conicalP_1 = \&PDL::gsl_sf_conicalP_1; #line 410 "LEGENDRE.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_conicalP_sph_reg =for sig Signature: (double x(); double [o]y(); double [o]e(); int l; double lambda) =for ref Regular Spherical Conical Function P^{-1/2-l}_{-1/2 + I lambda}(x) =for bad gsl_sf_conicalP_sph_reg does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 434 "LEGENDRE.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_conicalP_sph_reg = \&PDL::gsl_sf_conicalP_sph_reg; #line 440 "LEGENDRE.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_conicalP_cyl_reg_e =for sig Signature: (double x(); double [o]y(); double [o]e(); int m; double lambda) =for ref Regular Cylindrical Conical Function P^{-m}_{-1/2 + I lambda}(x) =for bad gsl_sf_conicalP_cyl_reg_e does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 464 "LEGENDRE.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_conicalP_cyl_reg_e = \&PDL::gsl_sf_conicalP_cyl_reg_e; #line 470 "LEGENDRE.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_legendre_H3d =for sig Signature: (double [o]y(); double [o]e(); int l; double lambda; double eta) =for ref lth radial eigenfunction of the Laplacian on the 3-dimensional hyperbolic space. =for bad gsl_sf_legendre_H3d does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 494 "LEGENDRE.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_legendre_H3d = \&PDL::gsl_sf_legendre_H3d; #line 500 "LEGENDRE.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_legendre_H3d_array =for sig Signature: (double [o]y(num); int l=>num; double lambda; double eta) =for ref Array of H3d(ell), for l from 0 to n-1. =for bad gsl_sf_legendre_H3d_array does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 524 "LEGENDRE.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_legendre_H3d_array = \&PDL::gsl_sf_legendre_H3d_array; #line 530 "LEGENDRE.pm" #line 345 "gsl_sf_legendre.pd" =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin 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. The GSL SF modules were written by G. Jungman. =cut #line 550 "LEGENDRE.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSLSF/ZETA.pm0000644000175000017500000000513214200406316015764 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::ZETA; our @EXPORT_OK = qw(gsl_sf_zeta gsl_sf_hzeta gsl_sf_eta ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::ZETA ; #line 5 "gsl_sf_zeta.pd" use strict; use warnings; =head1 NAME PDL::GSLSF::ZETA - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =cut #line 38 "ZETA.pm" =head1 FUNCTIONS =cut #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_zeta =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Riemann Zeta Function zeta(x) = Sum[ k^(-s), {k,1,Infinity} ], s != 1.0 =for bad gsl_sf_zeta does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 72 "ZETA.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_zeta = \&PDL::gsl_sf_zeta; #line 78 "ZETA.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_hzeta =for sig Signature: (double s(); double [o]y(); double [o]e(); double q) =for ref Hurwicz Zeta Function zeta(s,q) = Sum[ (k+q)^(-s), {k,0,Infinity} ] =for bad gsl_sf_hzeta does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 102 "ZETA.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_hzeta = \&PDL::gsl_sf_hzeta; #line 108 "ZETA.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_eta =for sig Signature: (double x(); double [o]y(); double [o]e()) =for ref Eta Function eta(s) = (1-2^(1-s)) zeta(s) =for bad gsl_sf_eta does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 132 "ZETA.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_eta = \&PDL::gsl_sf_eta; #line 138 "ZETA.pm" #line 64 "gsl_sf_zeta.pd" =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin 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. The GSL SF modules were written by G. Jungman. =cut #line 158 "ZETA.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSLSF/BESSEL.pm0000644000175000017500000004004114200406313016171 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSLSF::BESSEL; our @EXPORT_OK = qw(gsl_sf_bessel_Jn gsl_sf_bessel_Jn_array gsl_sf_bessel_Yn gsl_sf_bessel_Yn_array gsl_sf_bessel_In gsl_sf_bessel_I_array gsl_sf_bessel_In_scaled gsl_sf_bessel_In_scaled_array gsl_sf_bessel_Kn gsl_sf_bessel_K_array gsl_sf_bessel_Kn_scaled gsl_sf_bessel_Kn_scaled_array gsl_sf_bessel_jl gsl_sf_bessel_jl_array gsl_sf_bessel_yl gsl_sf_bessel_yl_array gsl_sf_bessel_il_scaled gsl_sf_bessel_il_scaled_array gsl_sf_bessel_kl_scaled gsl_sf_bessel_kl_scaled_array gsl_sf_bessel_Jnu gsl_sf_bessel_Ynu gsl_sf_bessel_Inu_scaled gsl_sf_bessel_Inu gsl_sf_bessel_Knu_scaled gsl_sf_bessel_Knu gsl_sf_bessel_lnKnu ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSLSF::BESSEL ; #line 5 "gsl_sf_bessel.pd" use strict; use warnings; =head1 NAME PDL::GSLSF::BESSEL - PDL interface to GSL Special Functions =head1 DESCRIPTION This is an interface to the Special Function package present in the GNU Scientific Library. =cut #line 38 "BESSEL.pm" =head1 FUNCTIONS =cut #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_bessel_Jn =for sig Signature: (double x(); double [o]y(); double [o]e(); int n) =for ref Regular Bessel Function J_n(x). =for bad gsl_sf_bessel_Jn does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 72 "BESSEL.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_bessel_Jn = \&PDL::gsl_sf_bessel_Jn; #line 78 "BESSEL.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_bessel_Jn_array =for sig Signature: (double x(); double [o]y(num); int s; int n=>num) =for ref Array of Regular Bessel Functions J_{s}(x) to J_{s+n-1}(x). =for bad gsl_sf_bessel_Jn_array does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 102 "BESSEL.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_bessel_Jn_array = \&PDL::gsl_sf_bessel_Jn_array; #line 108 "BESSEL.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_bessel_Yn =for sig Signature: (double x(); double [o]y(); double [o]e(); int n) =for ref IrRegular Bessel Function Y_n(x). =for bad gsl_sf_bessel_Yn does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 132 "BESSEL.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_bessel_Yn = \&PDL::gsl_sf_bessel_Yn; #line 138 "BESSEL.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_bessel_Yn_array =for sig Signature: (double x(); double [o]y(num); int s; int n=>num) =for ref Array of Regular Bessel Functions Y_{s}(x) to Y_{s+n-1}(x). =for bad gsl_sf_bessel_Yn_array does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 162 "BESSEL.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_bessel_Yn_array = \&PDL::gsl_sf_bessel_Yn_array; #line 168 "BESSEL.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_bessel_In =for sig Signature: (double x(); double [o]y(); double [o]e(); int n) =for ref Regular Modified Bessel Function I_n(x). =for bad gsl_sf_bessel_In does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 192 "BESSEL.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_bessel_In = \&PDL::gsl_sf_bessel_In; #line 198 "BESSEL.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_bessel_I_array =for sig Signature: (double x(); double [o]y(num); int s; int n=>num) =for ref Array of Regular Modified Bessel Functions I_{s}(x) to I_{s+n-1}(x). =for bad gsl_sf_bessel_I_array does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 222 "BESSEL.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_bessel_I_array = \&PDL::gsl_sf_bessel_I_array; #line 228 "BESSEL.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_bessel_In_scaled =for sig Signature: (double x(); double [o]y(); double [o]e(); int n) =for ref Scaled Regular Modified Bessel Function exp(-|x|) I_n(x). =for bad gsl_sf_bessel_In_scaled does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 252 "BESSEL.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_bessel_In_scaled = \&PDL::gsl_sf_bessel_In_scaled; #line 258 "BESSEL.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_bessel_In_scaled_array =for sig Signature: (double x(); double [o]y(num); int s; int n=>num) =for ref Array of Scaled Regular Modified Bessel Functions exp(-|x|) I_{s}(x) to exp(-|x|) I_{s+n-1}(x). =for bad gsl_sf_bessel_In_scaled_array does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 282 "BESSEL.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_bessel_In_scaled_array = \&PDL::gsl_sf_bessel_In_scaled_array; #line 288 "BESSEL.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_bessel_Kn =for sig Signature: (double x(); double [o]y(); double [o]e(); int n) =for ref IrRegular Modified Bessel Function K_n(x). =for bad gsl_sf_bessel_Kn does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 312 "BESSEL.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_bessel_Kn = \&PDL::gsl_sf_bessel_Kn; #line 318 "BESSEL.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_bessel_K_array =for sig Signature: (double x(); double [o]y(num); int s; int n=>num) =for ref Array of IrRegular Modified Bessel Functions K_{s}(x) to K_{s+n-1}(x). =for bad gsl_sf_bessel_K_array does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 342 "BESSEL.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_bessel_K_array = \&PDL::gsl_sf_bessel_K_array; #line 348 "BESSEL.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_bessel_Kn_scaled =for sig Signature: (double x(); double [o]y(); double [o]e(); int n) =for ref Scaled IrRegular Modified Bessel Function exp(-|x|) K_n(x). =for bad gsl_sf_bessel_Kn_scaled does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 372 "BESSEL.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_bessel_Kn_scaled = \&PDL::gsl_sf_bessel_Kn_scaled; #line 378 "BESSEL.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_bessel_Kn_scaled_array =for sig Signature: (double x(); double [o]y(num); int s; int n=>num) =for ref Array of Scaled IrRegular Modified Bessel Functions exp(-|x|) K_{s}(x) to exp(-|x|) K_{s+n-1}(x). =for bad gsl_sf_bessel_Kn_scaled_array does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 402 "BESSEL.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_bessel_Kn_scaled_array = \&PDL::gsl_sf_bessel_Kn_scaled_array; #line 408 "BESSEL.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_bessel_jl =for sig Signature: (double x(); double [o]y(); double [o]e(); int n) =for ref Regular Sphericl Bessel Function J_n(x). =for bad gsl_sf_bessel_jl does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 432 "BESSEL.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_bessel_jl = \&PDL::gsl_sf_bessel_jl; #line 438 "BESSEL.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_bessel_jl_array =for sig Signature: (double x(); double [o]y(num); int n=>num) =for ref Array of Spherical Regular Bessel Functions J_{0}(x) to J_{n-1}(x). =for bad gsl_sf_bessel_jl_array does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 462 "BESSEL.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_bessel_jl_array = \&PDL::gsl_sf_bessel_jl_array; #line 468 "BESSEL.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_bessel_yl =for sig Signature: (double x(); double [o]y(); double [o]e(); int n) =for ref IrRegular Spherical Bessel Function y_n(x). =for bad gsl_sf_bessel_yl does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 492 "BESSEL.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_bessel_yl = \&PDL::gsl_sf_bessel_yl; #line 498 "BESSEL.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_bessel_yl_array =for sig Signature: (double x(); double [o]y(num); int n=>num) =for ref Array of Regular Spherical Bessel Functions y_{0}(x) to y_{n-1}(x). =for bad gsl_sf_bessel_yl_array does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 522 "BESSEL.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_bessel_yl_array = \&PDL::gsl_sf_bessel_yl_array; #line 528 "BESSEL.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_bessel_il_scaled =for sig Signature: (double x(); double [o]y(); double [o]e(); int n) =for ref Scaled Regular Modified Spherical Bessel Function exp(-|x|) i_n(x). =for bad gsl_sf_bessel_il_scaled does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 552 "BESSEL.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_bessel_il_scaled = \&PDL::gsl_sf_bessel_il_scaled; #line 558 "BESSEL.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_bessel_il_scaled_array =for sig Signature: (double x(); double [o]y(num); int n=>num) =for ref Array of Scaled Regular Modified Spherical Bessel Functions exp(-|x|) i_{0}(x) to exp(-|x|) i_{n-1}(x). =for bad gsl_sf_bessel_il_scaled_array does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 582 "BESSEL.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_bessel_il_scaled_array = \&PDL::gsl_sf_bessel_il_scaled_array; #line 588 "BESSEL.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_bessel_kl_scaled =for sig Signature: (double x(); double [o]y(); double [o]e(); int n) =for ref Scaled IrRegular Modified Spherical Bessel Function exp(-|x|) k_n(x). =for bad gsl_sf_bessel_kl_scaled does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 612 "BESSEL.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_bessel_kl_scaled = \&PDL::gsl_sf_bessel_kl_scaled; #line 618 "BESSEL.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_bessel_kl_scaled_array =for sig Signature: (double x(); double [o]y(num); int n=>num) =for ref Array of Scaled IrRegular Modified Spherical Bessel Functions exp(-|x|) k_{s}(x) to exp(-|x|) k_{s+n-1}(x). =for bad gsl_sf_bessel_kl_scaled_array does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 642 "BESSEL.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_bessel_kl_scaled_array = \&PDL::gsl_sf_bessel_kl_scaled_array; #line 648 "BESSEL.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_bessel_Jnu =for sig Signature: (double x(); double [o]y(); double [o]e(); double n) =for ref Regular Cylindrical Bessel Function J_nu(x). =for bad gsl_sf_bessel_Jnu does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 672 "BESSEL.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_bessel_Jnu = \&PDL::gsl_sf_bessel_Jnu; #line 678 "BESSEL.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_bessel_Ynu =for sig Signature: (double x(); double [o]y(); double [o]e(); double n) =for ref IrRegular Cylindrical Bessel Function J_nu(x). =for bad gsl_sf_bessel_Ynu does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 702 "BESSEL.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_bessel_Ynu = \&PDL::gsl_sf_bessel_Ynu; #line 708 "BESSEL.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_bessel_Inu_scaled =for sig Signature: (double x(); double [o]y(); double [o]e(); double n) =for ref Scaled Modified Cylindrical Bessel Function exp(-|x|) I_nu(x). =for bad gsl_sf_bessel_Inu_scaled does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 732 "BESSEL.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_bessel_Inu_scaled = \&PDL::gsl_sf_bessel_Inu_scaled; #line 738 "BESSEL.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_bessel_Inu =for sig Signature: (double x(); double [o]y(); double [o]e(); double n) =for ref Modified Cylindrical Bessel Function I_nu(x). =for bad gsl_sf_bessel_Inu does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 762 "BESSEL.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_bessel_Inu = \&PDL::gsl_sf_bessel_Inu; #line 768 "BESSEL.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_bessel_Knu_scaled =for sig Signature: (double x(); double [o]y(); double [o]e(); double n) =for ref Scaled Modified Cylindrical Bessel Function exp(-|x|) K_nu(x). =for bad gsl_sf_bessel_Knu_scaled does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 792 "BESSEL.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_bessel_Knu_scaled = \&PDL::gsl_sf_bessel_Knu_scaled; #line 798 "BESSEL.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_bessel_Knu =for sig Signature: (double x(); double [o]y(); double [o]e(); double n) =for ref Modified Cylindrical Bessel Function K_nu(x). =for bad gsl_sf_bessel_Knu does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 822 "BESSEL.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_bessel_Knu = \&PDL::gsl_sf_bessel_Knu; #line 828 "BESSEL.pm" #line 1059 "../../../../blib/lib/PDL/PP.pm" =head2 gsl_sf_bessel_lnKnu =for sig Signature: (double x(); double [o]y(); double [o]e(); double n) =for ref Logarithm of Modified Cylindrical Bessel Function K_nu(x). =for bad gsl_sf_bessel_lnKnu does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 852 "BESSEL.pm" #line 1061 "../../../../blib/lib/PDL/PP.pm" *gsl_sf_bessel_lnKnu = \&PDL::gsl_sf_bessel_lnKnu; #line 858 "BESSEL.pm" #line 350 "gsl_sf_bessel.pd" =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin 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. The GSL SF modules were written by G. Jungman. =cut #line 878 "BESSEL.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/Slices.pm0000644000175000017500000013255614200406306015577 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::Slices; our @EXPORT_OK = qw(index index1d index2d indexND indexNDb rangeb rld rle _clump_int xchg mv using diagonal lags splitdim rotate threadI unthread dice dice_axis slice ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Slices ; #line 6 "slices.pd" =head1 NAME PDL::Slices -- Indexing, slicing, and dicing =head1 SYNOPSIS use PDL; $x = ones(3,3); $y = $x->slice('-1:0,(1)'); $c = $x->dummy(2); =head1 DESCRIPTION This package provides many of the powerful PerlDL core index manipulation routines. These routines mostly allow two-way data flow, so you can modify your data in the most convenient representation. For example, you can make a 1000x1000 unit matrix with $x = zeroes(1000,1000); $x->diagonal(0,1) ++; which is quite efficient. See L and L for more examples. Slicing is so central to the PDL language that a special compile-time syntax has been introduced to handle it compactly; see L for details. PDL indexing and slicing functions usually include two-way data flow, so that you can separate the actions of reshaping your data structures and modifying the data themselves. Two special methods, L and L, help you control the data flow connection between related variables. $y = $x->slice("1:3"); # Slice maintains a link between $x and $y. $y += 5; # $x is changed! If you want to force a physical copy and no data flow, you can copy or sever the slice expression: $y = $x->slice("1:3")->copy; $y += 5; # $x is not changed. $y = $x->slice("1:3")->sever; $y += 5; # $x is not changed. The difference between C and C is that sever acts on (and returns) its argument, while copy produces a disconnected copy. If you say $y = $x->slice("1:3"); $c = $y->sever; then the variables C<$y> and C<$c> point to the same object but with C<-Ecopy> they would not. =cut use strict; use warnings; use PDL::Core ':Internal'; use Scalar::Util 'blessed'; #line 90 "Slices.pm" =head1 FUNCTIONS =cut #line 1059 "../../blib/lib/PDL/PP.pm" =head2 index =for sig Signature: (a(n); indx ind(); [oca] c()) =for ref C, C, and C provide rudimentary index indirection. =for example $c = index($source,$ind); $c = index1d($source,$ind); $c = index2d($source2,$ind1,$ind2); use the C<$ind> variables as indices to look up values in C<$source>. The three routines thread slightly differently. =over 3 =item * C uses direct threading for 1-D indexing across the 0 dim of C<$source>. It can thread over source thread dims or index thread dims, but not (easily) both: If C<$source> has more than 1 dimension and C<$ind> has more than 0 dimensions, they must agree in a threading sense. =item * C uses a single active dim in C<$ind> to produce a list of indexed values in the 0 dim of the output - it is useful for collapsing C<$source> by indexing with a single row of values along C<$source>'s 0 dimension. The output has the same number of dims as C<$source>. The 0 dim of the output has size 1 if C<$ind> is a scalar, and the same size as the 0 dim of C<$ind> if it is not. If C<$ind> and C<$source> both have more than 1 dim, then all dims higher than 0 must agree in a threading sense. =item * C works like C but uses separate ndarrays for X and Y coordinates. For more general N-dimensional indexing, see the L syntax or L (in particular C, C, and C). =back These functions are two-way, i.e. after $c = $x->index(pdl[0,5,8]); $c .= pdl [0,2,4]; the changes in C<$c> will flow back to C<$x>. C provids simple threading: multiple-dimensioned arrays are treated as collections of 1-D arrays, so that $x = xvals(10,10)+10*yvals(10,10); $y = $x->index(3); $c = $x->index(9-xvals(10)); puts a single column from C<$x> into C<$y>, and puts a single element from each column of C<$x> into C<$c>. If you want to extract multiple columns from an array in one operation, see L or L. =for bad index barfs if any of the index values are bad. =cut #line 182 "Slices.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *index = \&PDL::index; #line 188 "Slices.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 index1d =for sig Signature: (a(n); indx ind(m); [oca] c(m)) =for ref C, C, and C provide rudimentary index indirection. =for example $c = index($source,$ind); $c = index1d($source,$ind); $c = index2d($source2,$ind1,$ind2); use the C<$ind> variables as indices to look up values in C<$source>. The three routines thread slightly differently. =over 3 =item * C uses direct threading for 1-D indexing across the 0 dim of C<$source>. It can thread over source thread dims or index thread dims, but not (easily) both: If C<$source> has more than 1 dimension and C<$ind> has more than 0 dimensions, they must agree in a threading sense. =item * C uses a single active dim in C<$ind> to produce a list of indexed values in the 0 dim of the output - it is useful for collapsing C<$source> by indexing with a single row of values along C<$source>'s 0 dimension. The output has the same number of dims as C<$source>. The 0 dim of the output has size 1 if C<$ind> is a scalar, and the same size as the 0 dim of C<$ind> if it is not. If C<$ind> and C<$source> both have more than 1 dim, then all dims higher than 0 must agree in a threading sense. =item * C works like C but uses separate ndarrays for X and Y coordinates. For more general N-dimensional indexing, see the L syntax or L (in particular C, C, and C). =back These functions are two-way, i.e. after $c = $x->index(pdl[0,5,8]); $c .= pdl [0,2,4]; the changes in C<$c> will flow back to C<$x>. C provids simple threading: multiple-dimensioned arrays are treated as collections of 1-D arrays, so that $x = xvals(10,10)+10*yvals(10,10); $y = $x->index(3); $c = $x->index(9-xvals(10)); puts a single column from C<$x> into C<$y>, and puts a single element from each column of C<$x> into C<$c>. If you want to extract multiple columns from an array in one operation, see L or L. =for bad index1d propagates BAD index elements to the output variable. =cut #line 270 "Slices.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *index1d = \&PDL::index1d; #line 276 "Slices.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 index2d =for sig Signature: (a(na,nb); indx inda(); indx indb(); [oca] c()) =for ref C, C, and C provide rudimentary index indirection. =for example $c = index($source,$ind); $c = index1d($source,$ind); $c = index2d($source2,$ind1,$ind2); use the C<$ind> variables as indices to look up values in C<$source>. The three routines thread slightly differently. =over 3 =item * C uses direct threading for 1-D indexing across the 0 dim of C<$source>. It can thread over source thread dims or index thread dims, but not (easily) both: If C<$source> has more than 1 dimension and C<$ind> has more than 0 dimensions, they must agree in a threading sense. =item * C uses a single active dim in C<$ind> to produce a list of indexed values in the 0 dim of the output - it is useful for collapsing C<$source> by indexing with a single row of values along C<$source>'s 0 dimension. The output has the same number of dims as C<$source>. The 0 dim of the output has size 1 if C<$ind> is a scalar, and the same size as the 0 dim of C<$ind> if it is not. If C<$ind> and C<$source> both have more than 1 dim, then all dims higher than 0 must agree in a threading sense. =item * C works like C but uses separate ndarrays for X and Y coordinates. For more general N-dimensional indexing, see the L syntax or L (in particular C, C, and C). =back These functions are two-way, i.e. after $c = $x->index(pdl[0,5,8]); $c .= pdl [0,2,4]; the changes in C<$c> will flow back to C<$x>. C provids simple threading: multiple-dimensioned arrays are treated as collections of 1-D arrays, so that $x = xvals(10,10)+10*yvals(10,10); $y = $x->index(3); $c = $x->index(9-xvals(10)); puts a single column from C<$x> into C<$y>, and puts a single element from each column of C<$x> into C<$c>. If you want to extract multiple columns from an array in one operation, see L or L. =for bad index2d barfs if either of the index values are bad. =cut #line 358 "Slices.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *index2d = \&PDL::index2d; #line 364 "Slices.pm" #line 300 "slices.pd" =head2 indexNDb =for ref Backwards-compatibility alias for indexND =head2 indexND =for ref Find selected elements in an N-D ndarray, with optional boundary handling =for example $out = $source->indexND( $index, [$method] ) $source = 10*xvals(10,10) + yvals(10,10); $index = pdl([[2,3],[4,5]],[[6,7],[8,9]]); print $source->indexND( $index ); [ [23 45] [67 89] ] IndexND collapses C<$index> by lookup into C<$source>. The 0th dimension of C<$index> is treated as coordinates in C<$source>, and the return value has the same dimensions as the rest of C<$index>. The returned elements are looked up from C<$source>. Dataflow works -- propagated assignment flows back into C<$source>. IndexND and IndexNDb were originally separate routines but they are both now implemented as a call to L, and have identical syntax to one another. SEE ALSO: L returns N-D indices into a multidimensional PDL, suitable for feeding to this. =cut sub PDL::indexND { my($source,$index, $boundary) = @_; return PDL::range($source,$index,undef,$boundary); } *PDL::indexNDb = \&PDL::indexND; #line 418 "Slices.pm" #line 353 "slices.pd" sub PDL::range { my($source,$ind,$sz,$bound) = @_; # Convert to indx type up front (also handled in rangeb if necessary) my $index = (ref $ind && UNIVERSAL::isa($ind,'PDL') && $ind->type eq 'indx') ? $ind : indx($ind); my $size = defined($sz) ? PDL->pdl($sz) : undef; # Handle empty PDL case: return a properly constructed Empty. if($index->isempty) { my @sdims= $source->dims; splice(@sdims, 0, $index->dim(0) + ($index->dim(0)==0)); # added term is to treat Empty[0] like a single empty coordinate unshift(@sdims, $size->list) if(defined($size)); return PDL->new_from_specification(0 x ($index->ndims-1), @sdims); } $index = $index->dummy(0,1) unless $index->ndims; # Pack boundary string if necessary if(defined $bound) { if(ref $bound eq 'ARRAY') { my ($s,$el); foreach $el(@$bound) { barf "Illegal boundary value '$el' in range" unless( $el =~ m/^([0123fFtTeEpPmM])/ ); $s .= $1; } $bound = $s; } elsif($bound !~ m/^[0123ftepx]+$/ && $bound =~ m/^([0123ftepx])/i ) { $bound = $1; } } no warnings; # shut up about passing undef into rangeb $source->rangeb($index,$size,$bound); } #line 463 "Slices.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 rangeb =for sig Signature: (P(); C(); pdl *ind_pdl; SV *size; SV *boundary_sv) =for ref Engine for L =for example Same calling convention as L, but you must supply all parameters. C is marginally faster as it makes a direct PP call, avoiding the perl argument-parsing step. =head2 range =for ref Extract selected chunks from a source ndarray, with boundary conditions =for example $out = $source->range($index,[$size,[$boundary]]) Returns elements or rectangular slices of the original ndarray, indexed by the C<$index> ndarray. C<$source> is an N-dimensional ndarray, and C<$index> is an ndarray whose first dimension has size up to N. Each row of C<$index> is treated as coordinates of a single value or chunk from C<$source>, specifying the location(s) to extract. If you specify a single index location, then range is essentially an expensive slice, with controllable boundary conditions. B C<$index> and C<$size> can be ndarrays or array refs such as you would feed to L and its ilk. If C<$index>'s 0th dimension has size higher than the number of dimensions in C<$source>, then C<$source> is treated as though it had trivial dummy dimensions of size 1, up to the required size to be indexed by C<$index> -- so if your source array is 1-D and your index array is a list of 3-vectors, you get two dummy dimensions of size 1 on the end of your source array. You can extract single elements or N-D rectangular ranges from C<$source>, by setting C<$size>. If C<$size> is undef or zero, then you get a single sample for each row of C<$index>. This behavior is similar to L, which is in fact implemented as a call to L. If C<$size> is positive then you get a range of values from C<$source> at each location, and the output has extra dimensions allocated for them. C<$size> can be a scalar, in which case it applies to all dimensions, or an N-vector, in which case each element is applied independently to the corresponding dimension in C<$source>. See below for details. C<$boundary> is a number, string, or list ref indicating the type of boundary conditions to use when ranges reach the edge of C<$source>. If you specify no boundary conditions the default is to forbid boundary violations on all axes. If you specify exactly one boundary condition, it applies to all axes. If you specify more (as elements of a list ref, or as a packed string, see below), then they apply to dimensions in the order in which they appear, and the last one applies to all subsequent dimensions. (This is less difficult than it sounds; see the examples below). =over 3 =item 0 (synonyms: 'f','forbid') B<(default)> Ranges are not allowed to cross the boundary of the original PDL. Disallowed ranges throw an error. The errors are thrown at evaluation time, not at the time of the range call (this is the same behavior as L). =item 1 (synonyms: 't','truncate') Values outside the original ndarray get BAD if you've got bad value support compiled into your PDL and set the badflag for the source PDL; or 0 if you haven't (you must set the badflag if you want BADs for out of bound values, otherwise you get 0). Reverse dataflow works OK for the portion of the child that is in-bounds. The out-of-bounds part of the child is reset to (BAD|0) during each dataflow operation, but execution continues. =item 2 (synonyms: 'e','x','extend') Values that would be outside the original ndarray point instead to the nearest allowed value within the ndarray. See the CAVEAT below on mappings that are not single valued. =item 3 (synonyms: 'p','periodic') Periodic boundary conditions apply: the numbers in $index are applied, strict-modulo the corresponding dimensions of $source. This is equivalent to duplicating the $source ndarray throughout N-D space. See the CAVEAT below about mappings that are not single valued. =item 4 (synonyms: 'm','mirror') Mirror-reflection periodic boundary conditions apply. See the CAVEAT below about mappings that are not single valued. =back The boundary condition identifiers all begin with unique characters, so you can feed in multiple boundary conditions as either a list ref or a packed string. (The packed string is marginally faster to run). For example, the four expressions [0,1], ['forbid','truncate'], ['f','t'], and 'ft' all specify that violating the boundary in the 0th dimension throws an error, and all other dimensions get truncated. If you feed in a single string, it is interpreted as a packed boundary array if all of its characters are valid boundary specifiers (e.g. 'pet'), but as a single word-style specifier if they are not (e.g. 'forbid'). B The output threads over both C<$index> and C<$source>. Because implicit threading can happen in a couple of ways, a little thought is needed. The returned dimension list is stacked up like this: (index thread dims), (index dims (size)), (source thread dims) The first few dims of the output correspond to the extra dims of C<$index> (beyond the 0 dim). They allow you to pick out individual ranges from a large, threaded collection. The middle few dims of the output correspond to the size dims specified in C<$size>, and contain the range of values that is extracted at each location in C<$source>. Every nonzero element of C<$size> is copied to the dimension list here, so that if you feed in (for example) C<$size = [2,0,1]> you get an index dim list of C<(2,1)>. The last few dims of the output correspond to extra dims of C<$source> beyond the number of dims indexed by C<$index>. These dims act like ordinary thread dims, because adding more dims to C<$source> just tacks extra dims on the end of the output. Each source thread dim ranges over the entire corresponding dim of C<$source>. B: Dataflow is bidirectional. B: Here are basic examples of C operation, showing how to get ranges out of a small matrix. The first few examples show extraction and selection of individual chunks. The last example shows how to mark loci in the original matrix (using dataflow). pdl> $src = 10*xvals(10,5)+yvals(10,5) pdl> print $src->range([2,3]) # Cut out a single element 23 pdl> print $src->range([2,3],1) # Cut out a single 1x1 block [ [23] ] pdl> print $src->range([2,3], [2,1]) # Cut a 2x1 chunk [ [23 33] ] pdl> print $src->range([[2,3]],[2,1]) # Trivial list of 1 chunk [ [ [23] [33] ] ] pdl> print $src->range([[2,3],[0,1]], [2,1]) # two 2x1 chunks [ [ [23 1] [33 11] ] ] pdl> # A 2x2 collection of 2x1 chunks pdl> print $src->range([[[1,1],[2,2]],[[2,3],[0,1]]],[2,1]) [ [ [ [11 22] [23 1] ] [ [21 32] [33 11] ] ] ] pdl> $src = xvals(5,3)*10+yvals(5,3) pdl> print $src->range(3,1) # Thread over y dimension in $src [ [30] [31] [32] ] pdl> $src = zeroes(5,4); pdl> $src->range(pdl([2,3],[0,1]),pdl(2,1)) .= xvals(2,2,1) + 1 pdl> print $src [ [0 0 0 0 0] [2 2 0 0 0] [0 0 0 0 0] [0 0 1 1 0] ] B: It's quite possible to select multiple ranges that intersect. In that case, modifying the ranges doesn't have a guaranteed result in the original PDL -- the result is an arbitrary choice among the valid values. For some things that's OK; but for others it's not. In particular, this doesn't work: pdl> $photon_list = new PDL::RandVar->sample(500)->reshape(2,250)*10 pdl> histogram = zeroes(10,10) pdl> histogram->range($photon_list,1)++; #not what you wanted The reason is that if two photons land in the same bin, then that bin doesn't get incremented twice. (That may get fixed in a later version...) B: If C<$index> has too many dimensions compared to C<$source>, then $source is treated as though it had dummy dimensions of size 1, up to the required number of dimensions. These virtual dummy dimensions have the usual boundary conditions applied to them. If the 0 dimension of C<$index> is ludicrously large (if its size is more than 5 greater than the number of dims in the source PDL) then range will insist that you specify a size in every dimension, to make sure that you know what you're doing. That catches a common error with range usage: confusing the initial dim (which is usually small) with another index dim (perhaps of size 1000). If the index variable is Empty, then range() always returns the Empty PDL. If the index variable is not Empty, indexing it always yields a boundary violation. All non-barfing conditions are treated as truncation, since there are no actual data to return. B: Because C isn't an affine transformation (it involves lookup into a list of N-D indices), it is somewhat memory-inefficient for long lists of ranges, and keeping dataflow open is much slower than for affine transformations (which don't have to copy data around). Doing operations on small subfields of a large range is inefficient because the engine must flow the entire range back into the original PDL with every atomic perl operation, even if you only touch a single element. One way to speed up such code is to sever your range, so that PDL doesn't have to copy the data with each operation, then copy the elements explicitly at the end of your loop. Here's an example that labels each region in a range sequentially, using many small operations rather than a single xvals assignment: ### How to make a collection of small ops run fast with range... $x = $data->range($index, $sizes, $bound)->sever; $aa = $data->range($index, $sizes, $bound); map { $x($_ - 1) .= $_; } (1..$x->nelem); # Lots of little ops $aa .= $x; C is a perl front-end to a PP function, C. Calling C is marginally faster but requires that you include all arguments. DEVEL NOTES * index thread dimensions are effectively clumped internally. This makes it easier to loop over the index array but a little more brain-bending to tease out the algorithm. =cut =for bad rangeb processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 746 "Slices.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *rangeb = \&PDL::rangeb; #line 752 "Slices.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 rld =for sig Signature: (indx a(n); b(n); [o]c(m)) =for ref Run-length decode a vector Given a vector C<$x> of the numbers of instances of values C<$y>, run-length decode to C<$c>. =for example rld($x,$y,$c=null); =for bad rld does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 785 "Slices.pm" #line 1060 "../../blib/lib/PDL/PP.pm" sub PDL::rld { my ($x,$y) = @_; my ($c); if ($#_ == 2) { $c = $_[2]; } else { # XXX Need to improve emulation of threading in auto-generating c my ($size) = $x->sumover->max->sclr; my (@dims) = $x->dims; shift @dims; $c = $y->zeroes($size,@dims); } &PDL::_rld_int($x,$y,$c); $c; } #line 805 "Slices.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *rld = \&PDL::rld; #line 811 "Slices.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 rle =for sig Signature: (c(n); indx [o]a(m); [o]b(m)) =for ref Run-length encode a vector Given vector C<$c>, generate a vector C<$x> with the number of each element, and a vector C<$y> of the unique values. New in PDL 2.017, only the elements up to the first instance of C<0> in C<$x> are returned, which makes the common use case of a 1-dimensional C<$c> simpler. For threaded operation, C<$x> and C<$y> will be large enough to hold the largest row of C<$y>, and only the elements up to the first instance of C<0> in each row of C<$x> should be considered. =for example $c = floor(4*random(10)); rle($c,$x=null,$y=null); #or ($x,$y) = rle($c); #for $c of shape [10, 4]: $c = floor(4*random(10,4)); ($x,$y) = rle($c); #to see the results of each row one at a time: foreach (0..$c->dim(1)-1){ my ($as,$bs) = ($x(:,($_)),$y(:,($_))); my ($ta,$tb) = where($as,$bs,$as!=0); #only the non-zero elements of $x print $c(:,($_)) . " rle==> " , ($ta,$tb) , "\trld==> " . rld($ta,$tb) . "\n"; } # the inverse of (chance of all 6 3d6 rolls being >= each possible sum) ($nrolls, $ndice, $dmax) = (6, 3, 6); ($x, $x1) = (allaxisvals(($dmax) x $ndice)+1)->sumover->flat->qsort->rle; $y = $x->cumusumover; $yprob1x = $y->slice('-1:0')->double / $y->slice('(-1)'); $z = cat($x1, 1 / $yprob1x**$nrolls)->transpose; =for bad rle does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 870 "Slices.pm" #line 1060 "../../blib/lib/PDL/PP.pm" sub PDL::rle { my $c = shift; my ($x,$y) = @_==2 ? @_ : (null,null); PDL::_rle_int($c,$x,$y); my $max_ind = ($c->ndims<2) ? ($x!=0)->sumover-1 : ($x!=0)->clump(1..$x->ndims-1)->sumover->max->sclr-1; return ($x->slice("0:$max_ind"),$y->slice("0:$max_ind")); } #line 883 "Slices.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *rle = \&PDL::rle; #line 889 "Slices.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *_clump_int = \&PDL::_clump_int; #line 895 "Slices.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 xchg =for sig Signature: (P(); C(); PDL_Indx n1; PDL_Indx n2) =for ref exchange two dimensions Negative dimension indices count from the end. The command =for example $y = $x->xchg(2,3); creates C<$y> to be like C<$x> except that the dimensions 2 and 3 are exchanged with each other i.e. $y->at(5,3,2,8) == $x->at(5,3,8,2) =for bad xchg does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 934 "Slices.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *xchg = \&PDL::xchg; #line 940 "Slices.pm" #line 1320 "slices.pd" =head2 reorder =for ref Re-orders the dimensions of a PDL based on the supplied list. Similar to the L method, this method re-orders the dimensions of a PDL. While the L method swaps the position of two dimensions, the reorder method can change the positions of many dimensions at once. =for usage # Completely reverse the dimension order of a 6-Dim array. $reOrderedPDL = $pdl->reorder(5,4,3,2,1,0); The argument to reorder is an array representing where the current dimensions should go in the new array. In the above usage, the argument to reorder C<(5,4,3,2,1,0)> indicates that the old dimensions (C<$pdl>'s dims) should be re-arranged to make the new pdl (C<$reOrderPDL>) according to the following: Old Position New Position ------------ ------------ 5 0 4 1 3 2 2 3 1 4 0 5 You do not need to specify all dimensions, only a complete set starting at position 0. (Extra dimensions are left where they are). This means, for example, that you can reorder() the X and Y dimensions of an image, and not care whether it is an RGB image with a third dimension running across color plane. =for example Example: pdl> $x = sequence(5,3,2); # Create a 3-d Array pdl> p $x [ [ [ 0 1 2 3 4] [ 5 6 7 8 9] [10 11 12 13 14] ] [ [15 16 17 18 19] [20 21 22 23 24] [25 26 27 28 29] ] ] pdl> p $x->reorder(2,1,0); # Reverse the order of the 3-D PDL [ [ [ 0 15] [ 5 20] [10 25] ] [ [ 1 16] [ 6 21] [11 26] ] [ [ 2 17] [ 7 22] [12 27] ] [ [ 3 18] [ 8 23] [13 28] ] [ [ 4 19] [ 9 24] [14 29] ] ] The above is a simple example that could be duplicated by calling C<$x-Exchg(0,2)>, but it demonstrates the basic functionality of reorder. As this is an index function, any modifications to the result PDL will change the parent. =cut sub PDL::reorder { my ($pdl,@newDimOrder) = @_; my $arrayMax = $#newDimOrder; #Error Checking: if( $pdl->getndims < scalar(@newDimOrder) ){ my $errString = "PDL::reorder: Number of elements (".scalar(@newDimOrder).") in newDimOrder array exceeds\n"; $errString .= "the number of dims in the supplied PDL (".$pdl->getndims.")"; barf($errString); } # Check to make sure all the dims are within bounds for my $i(0..$#newDimOrder) { my $dim = $newDimOrder[$i]; if($dim < 0 || $dim > $#newDimOrder) { my $errString = "PDL::reorder: Dim index $newDimOrder[$i] out of range in position $i\n(range is 0-$#newDimOrder)"; barf($errString); } } # Checking that they are all present and also not duplicated is done by thread() [I think] # a quicker way to do the reorder return $pdl->thread(@newDimOrder)->unthread(0); } #line 1064 "Slices.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 mv =for sig Signature: (P(); C(); PDL_Indx n1; PDL_Indx n2) =for ref move a dimension to another position The command =for example $y = $x->mv(4,1); creates C<$y> to be like C<$x> except that the dimension 4 is moved to the place 1, so: $y->at(1,2,3,4,5,6) == $x->at(1,5,2,3,4,6); The other dimensions are moved accordingly. Negative dimension indices count from the end. =for bad mv does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1103 "Slices.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *mv = \&PDL::mv; #line 1109 "Slices.pm" #line 1496 "slices.pd" =head2 using =for ref Returns array of column numbers requested =for usage line $pdl->using(1,2); Plot, as a line, column 1 of C<$pdl> vs. column 2 =for example pdl> $pdl = rcols("file"); pdl> line $pdl->using(1,2); =cut *using = \&PDL::using; sub PDL::using { my ($x,@ind)=@_; @ind = list $ind[0] if (blessed($ind[0]) && $ind[0]->isa('PDL')); foreach (@ind) { $_ = $x->slice("($_)"); } @ind; } #line 1143 "Slices.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 diagonal =for sig Signature: (P(); C(); PDL_Indx whichdims[]) =for ref Returns the multidimensional diagonal over the specified dimensions. The diagonal is placed at the first (by number) dimension that is diagonalized. The other diagonalized dimensions are removed. So if C<$x> has dimensions C<(5,3,5,4,6,5)> then after =for usage $d = $x->diagonal(dim1, dim2,...) =for example $y = $x->diagonal(0,2,5); the ndarray C<$y> has dimensions C<(5,3,4,6)> and C<$y-Eat(2,1,0,1)> refers to C<$x-Eat(2,1,2,0,1,2)>. NOTE: diagonal doesn't handle threadids correctly. XXX FIX pdl> $x = zeroes(3,3,3); pdl> ($y = $x->diagonal(0,1))++; pdl> p $x [ [ [1 0 0] [0 1 0] [0 0 1] ] [ [1 0 0] [0 1 0] [0 0 1] ] [ [1 0 0] [0 1 0] [0 0 1] ] ] =for bad diagonal does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1208 "Slices.pm" #line 1060 "../../blib/lib/PDL/PP.pm" sub PDL::diagonal { shift->_diagonal_int(my $o=PDL->null, \@_); $o } #line 1214 "Slices.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *diagonal = \&PDL::diagonal; #line 1220 "Slices.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 lags =for sig Signature: (P(); C(); PDL_Indx nthdim;PDL_Indx step;PDL_Indx n) =for ref Returns an ndarray of lags to parent. Usage: =for usage $lags = $x->lags($nthdim,$step,$nlags); I.e. if C<$x> contains [0,1,2,3,4,5,6,7] then =for example $y = $x->lags(0,2,2); is a (5,2) matrix [2,3,4,5,6,7] [0,1,2,3,4,5] This order of returned indices is kept because the function is called "lags" i.e. the nth lag is n steps behind the original. C<$step> and C<$nlags> must be positive. C<$nthdim> can be negative and will then be counted from the last dim backwards in the usual way (-1 = last dim). =for bad lags does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1273 "Slices.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *lags = \&PDL::lags; #line 1279 "Slices.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 splitdim =for sig Signature: (P(); C(); PDL_Indx nthdim;PDL_Indx nsp) =for ref Splits a dimension in the parent ndarray (opposite of L) After =for example $y = $x->splitdim(2,3); the expression $y->at(6,4,m,n,3,6) == $x->at(6,4,m+3*n) is always true (C has to be less than 3). =for bad splitdim does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1316 "Slices.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *splitdim = \&PDL::splitdim; #line 1322 "Slices.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 rotate =for sig Signature: (x(n); indx shift(); [oca]y(n)) =for ref Shift vector elements along with wrap. Flows data back&forth. =for bad rotate does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1347 "Slices.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *rotate = \&PDL::rotate; #line 1353 "Slices.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 threadI =for sig Signature: (P(); C(); PDL_Indx id; PDL_Indx whichdims[]) =for ref internal Put some dimensions to a threadid. =for example $y = $x->threadI(0,1,5); # thread over dims 1,5 in id 1 =for bad threadI does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1385 "Slices.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *threadI = \&PDL::threadI; #line 1391 "Slices.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 unthread =for sig Signature: (P(); C(); int atind) =for ref All threaded dimensions are made real again. See [TBD Doc] for details and examples. =for bad unthread does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1418 "Slices.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *unthread = \&PDL::unthread; #line 1424 "Slices.pm" #line 1936 "slices.pd" =head2 dice =for ref Dice rows/columns/planes out of a PDL using indexes for each dimension. This function can be used to extract irregular subsets along many dimension of a PDL, e.g. only certain rows in an image, or planes in a cube. This can of course be done with the usual dimension tricks but this saves having to figure it out each time! This method is similar in functionality to the L method, but L requires that contiguous ranges or ranges with constant offset be extracted. ( i.e. L requires ranges of the form C<1,2,3,4,5> or C<2,4,6,8,10>). Because of this restriction, L is more memory efficient and slightly faster than dice =for usage $slice = $data->dice([0,2,6],[2,1,6]); # Dicing a 2-D array The arguments to dice are arrays (or 1D PDLs) for each dimension in the PDL. These arrays are used as indexes to which rows/columns/cubes,etc to dice-out (or extract) from the C<$data> PDL. Use C to select all indices along a given dimension (compare also L). As usual (in slicing methods) trailing dimensions can be omitted implying C'es for those. =for example pdl> $x = sequence(10,4) pdl> p $x [ [ 0 1 2 3 4 5 6 7 8 9] [10 11 12 13 14 15 16 17 18 19] [20 21 22 23 24 25 26 27 28 29] [30 31 32 33 34 35 36 37 38 39] ] pdl> p $x->dice([1,2],[0,3]) # Select columns 1,2 and rows 0,3 [ [ 1 2] [31 32] ] pdl> p $x->dice(X,[0,3]) [ [ 0 1 2 3 4 5 6 7 8 9] [30 31 32 33 34 35 36 37 38 39] ] pdl> p $x->dice([0,2,5]) [ [ 0 2 5] [10 12 15] [20 22 25] [30 32 35] ] As this is an index function, any modifications to the slice will change the parent (use the C<.=> operator). =cut sub PDL::dice { my $self = shift; my @dim_indexes = @_; # array of dimension indexes # Check that the number of dim indexes <= # number of dimensions in the PDL my $no_indexes = scalar(@dim_indexes); my $noDims = $self->getndims; barf("PDL::dice: Number of index arrays ($no_indexes) not equal to the dimensions of the PDL ($noDims") if $no_indexes > $noDims; my $index; my $pdlIndex; my $outputPDL=$self; my $indexNo = 0; # Go thru each index array and dice the input PDL: foreach $index(@dim_indexes){ $outputPDL = $outputPDL->dice_axis($indexNo,$index) unless !ref $index && $index eq 'X'; $indexNo++; } return $outputPDL; } *dice = \&PDL::dice; =head2 dice_axis =for ref Dice rows/columns/planes from a single PDL axis (dimension) using index along a specified axis This function can be used to extract irregular subsets along any dimension, e.g. only certain rows in an image, or planes in a cube. This can of course be done with the usual dimension tricks but this saves having to figure it out each time! =for usage $slice = $data->dice_axis($axis,$index); =for example pdl> $x = sequence(10,4) pdl> $idx = pdl(1,2) pdl> p $x->dice_axis(0,$idx) # Select columns [ [ 1 2] [11 12] [21 22] [31 32] ] pdl> $t = $x->dice_axis(1,$idx) # Select rows pdl> $t.=0 pdl> p $x [ [ 0 1 2 3 4 5 6 7 8 9] [ 0 0 0 0 0 0 0 0 0 0] [ 0 0 0 0 0 0 0 0 0 0] [30 31 32 33 34 35 36 37 38 39] ] The trick to using this is that the index selects elements along the dimensions specified, so if you have a 2D image C will select certain C values - i.e. extract columns As this is an index function, any modifications to the slice will change the parent. =cut sub PDL::dice_axis { my($self,$axis,$idx) = @_; my $ix = ref($self)->topdl($idx); barf("dice_axis: index must be <=1D") if $ix->getndims > 1; return $self->mv($axis,0)->index1d($ix)->mv(0,$axis); } *dice_axis = \&PDL::dice_axis; #line 1579 "Slices.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 slice =for sig Signature: (P(); C(); pdl_slice_args *arglist) =for usage $slice = $data->slice([2,3],'x',[2,2,0],"-1:1:-1", "*3"); =for ref Extract rectangular slices of an ndarray, from a string specifier, an array ref specifier, or a combination. C is the main method for extracting regions of PDLs and manipulating their dimensionality. You can call it directly or via he L source prefilter that extends Perl syntax to include array slicing. C can extract regions along each dimension of a source PDL, subsample or reverse those regions, dice each dimension by selecting a list of locations along it, or basic PDL indexing routine. The selected subfield remains connected to the original PDL via dataflow. In most cases this neither allocates more memory nor slows down subsequent operations on either of the two connected PDLs. You pass in a list of arguments. Each term in the list controls the disposition of one axis of the source PDL and/or returned PDL. Each term can be a string-format cut specifier, a list ref that gives the same information without recourse to string manipulation, or a PDL with up to 1 dimension giving indices along that axis that should be selected. If you want to pass in a single string specifier for the entire operation, you can pass in a comma-delimited list as the first argument. C detects this condition and splits the string into a regular argument list. This calling style is fully backwards compatible with C calls from before PDL 2.006. B If a particular argument to C is a string, it is parsed as a selection, an affine slice, or a dummy dimension depending on the form. Leading or trailing whitespace in any part of each specifier is ignored (though it is not ignored within numbers). =over 3 =item C<< '' >>, C<< : >>, or C<< X >> -- keep The empty string, C<:>, or C cause the entire corresponding dimension to be kept unchanged. =item C<< >> -- selection A single number alone causes a single index to be selected from the corresponding dimension. The dimension is kept (and reduced to size 1) in the output. =item C<< () >> -- selection and collapse A single number in parenthesis causes a single index to be selected from the corresponding dimension. The dimension is discarded (completely eliminated) in the output. =item C<< : >> -- select an inclusive range Two numbers separated by a colon selects a range of values from the corresponding axis, e.g. C<< 3:4 >> selects elements 3 and 4 along the corresponding axis, and reduces that axis to size 2 in the output. Both numbers are regularized so that you can address the last element of the axis with an index of C< -1 >. If, after regularization, the two numbers are the same, then exactly one element gets selected (just like the C<< >> case). If, after regulariation, the second number is lower than the first, then the resulting slice counts down rather than up -- e.g. C<-1:0> will return the entire axis, in reversed order. =item C<< :: >> -- select a range with explicit step If you include a third parameter, it is the stride of the extracted range. For example, C<< 0:-1:2 >> will sample every other element across the complete dimension. Specifying a stride of 1 prevents autoreversal -- so to ensure that your slice is *always* forward you can specify, e.g., C<< 2:$n:1 >>. In that case, an "impossible" slice gets an Empty PDL (with 0 elements along the corresponding dimension), so you can generate an Empty PDL with a slice of the form C<< 2:1:1 >>. =item C<< * >> -- insert a dummy dimension Dummy dimensions aren't present in the original source and are "mocked up" to match dimensional slots, by repeating the data in the original PDL some number of times. An asterisk followed by a number produces a dummy dimension in the output, for example C<< *2 >> will generate a dimension of size 2 at the corresponding location in the output dim list. Omitting the number (and using just an asterisk) inserts a dummy dimension of size 1. =back B If you feed in an ARRAY ref as a slice term, then it can have 0-3 elements. The first element is the start of the slice along the corresponding dim; the second is the end; and the third is the stepsize. Different combinations of inputs give the same flexibility as the string syntax. =over 3 =item C<< [] >> - keep dim intact An empty ARRAY ref keeps the entire corresponding dim =item C<< [ 'X' ] >> - keep dim intact =item C<< [ '*',$n ] >> - generate a dummy dim of size $n If $n is missing, you get a dummy dim of size 1. =item C<< [ $dex, , 0 ] >> - collapse and discard dim C<$dex> must be a single value. It is used to index the source, and the corresponding dimension is discarded. =item C<< [ $start, $end ] >> - collect inclusive slice In the simple two-number case, you get a slice that runs up or down (as appropriate) to connect $start and $end. =item C<< [ $start, $end, $inc ] >> - collect inclusive slice The three-number case works exactly like the three-number string case above. =back B If you pass in a 0- or 1-D PDL as a slicing argument, the corresponding dimension is "diced" -- you get one position along the corresponding dim, per element of the indexing PDL, e.g. C<< $x->slice( pdl(3,4,9)) >> gives you elements 3, 4, and 9 along the 0 dim of C<< $x >>. Because dicing is not an affine transformation, it is slower than direct slicing even though the syntax is convenient. =for example $x->slice('1:3'); # return the second to fourth elements of $x $x->slice('3:1'); # reverse the above $x->slice('-2:1'); # return last-but-one to second elements of $x $x->slice([1,3]); # Same as above three calls, but using array ref syntax $x->slice([3,1]); $x->slice([-2,1]); =for bad slice does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1756 "Slices.pm" #line 1060 "../../blib/lib/PDL/PP.pm" sub PDL::slice { my ($source, @others) = @_; for my $i(0..$#others) { my $idx = $others[$i]; if (ref $idx eq 'ARRAY') { my @arr = map UNIVERSAL::isa($_, 'PDL') ? $_->flat->at(0) : $_, @{$others[$i]}; $others[$i] = \@arr; next; } next if !( blessed($idx) && $idx->isa('PDL') ); # Deal with dicing. This is lame and slow compared to the # faster slicing, but works okay. We loop over each argument, # and if it's a PDL we dispatch it in the most straightforward # way. Single-element and zero-element PDLs are trivial and get # converted into slices for faster handling later. barf("slice: dicing parameters must be at most 1D (arg $i)\n") if $idx->ndims > 1; my $nlm = $idx->nelem; if($nlm > 1) { #### More than one element - we have to dice (darn it). my $n = $source->getndims; $source = $source->mv($i,0)->index1d($idx)->mv(0,$i); $others[$i] = ''; } elsif($nlm) { #### One element - convert to a regular slice. $others[$i] = $idx->flat->at(0); } else { #### Zero elements -- force an extended empty. $others[$i] = "1:0:1"; } } PDL::_slice_int($source,my $o=$source->initialize,\@others); $o; } #line 1797 "Slices.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *slice = \&PDL::slice; #line 1803 "Slices.pm" #line 2427 "slices.pd" =head1 BUGS For the moment, you can't slice one of the zero-length dims of an empty ndarray. It is not clear how to implement this in a way that makes sense. Many types of index errors are reported far from the indexing operation that caused them. This is caused by the underlying architecture: slice() sets up a mapping between variables, but that mapping isn't tested for correctness until it is used (potentially much later). =head1 AUTHOR Copyright (C) 1997 Tuomas J. Lukka. Contributions by Craig DeForest, deforest@boulder.swri.edu. Documentation contributions by David Mertens. 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 #line 1834 "Slices.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/Minuit.pm0000644000175000017500000005142014200406317015612 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::Minuit; our @EXPORT_OK = qw(mn_init mn_def_pars mn_excm mn_pout mn_stat mn_err mn_contour mn_emat mninit mn_abre mn_cierra mnparm mnexcm mnpout mnstat mnemat mnerrs mncont ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Minuit ; #line 15 "minuit.pd" =head1 NAME PDL::Minuit -- a PDL interface to the Minuit library =head1 DESCRIPTION This package implements an interface to the Minuit minimization routines (part of the CERN Library) =head1 SYNOPSIS A basic fit with Minuit will call three functions in this package. First, a basic initialization is done with mn_init(). Then, the parameters are defined via the function mn_def_pars(), which allows setting upper and lower bounds. Then the function mn_excm() can be used to issue many Minuit commands, including simplex and migrad minimization algorithms (see Minuit manual for more details). See the test file minuit.t in the test (t/) directory for a basic example. #line 44 "Minuit.pm" =head1 FUNCTIONS =cut #line 37 "minuit.pd" use strict; use warnings; # Package variable my $mn_options; sub mn_init{ my $fun_ref = shift; $mn_options = { Log => undef, Title => 'Minuit Fit', N => undef, Unit => undef, Function => $fun_ref, }; if ( @_ ){ my $args = $_[0]; for my $key (qw/ Log Title Unit/){ $mn_options->{$key} = $args->{$key} if exists $args->{$key}; } } # Check if there was a valid F77 available and barf # if there was not and the user is trying to pass Log if (defined($mn_options->{Log})) { $mn_options->{Unit} = 88 unless defined $mn_options->{Unit}; } else { $mn_options->{Unit} = 6; } if (defined (my $logfile = $mn_options->{Log})){ if (-e $logfile) { unlink $logfile; } PDL::Minuit::mn_abre($mn_options->{Unit},$logfile,'new'); } PDL::Minuit::mninit(5,$mn_options->{Unit},$mn_options->{Unit}); PDL::Minuit::mnseti($mn_options->{Title}); if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_cierra($mn_options->{Unit}); } } #line 103 "Minuit.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 mninit =for sig Signature: (longlong a();longlong b(); longlong c()) =for ref info not available =for bad mninit does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 129 "Minuit.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *mninit = \&PDL::Minuit::mninit; #line 135 "Minuit.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 mn_abre =for sig Signature: (longlong l(); char* nombre; char* mode) =for ref info not available =for bad mn_abre does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 161 "Minuit.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *mn_abre = \&PDL::Minuit::mn_abre; #line 167 "Minuit.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 mn_cierra =for sig Signature: (longlong l()) =for ref info not available =for bad mn_cierra does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 193 "Minuit.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *mn_cierra = \&PDL::Minuit::mn_cierra; #line 199 "Minuit.pm" #line 108 "minuit.pd" sub mn_def_pars{ my $pars = shift; my $steps = shift; my $n = nelem($pars); $mn_options->{N} = $n; #print "Unit :".$mn_options->{Unit}."\n"; my @names = map "Par_$_", 0..$n-1; my $lo_bounds = zeroes($n); my $up_bounds = zeroes($n); if ( @_ ) { my $opts = $_[0]; $lo_bounds = $opts->{Lower_bounds} if defined $opts->{Lower_bounds}; $up_bounds = $opts->{Upper_bounds} if defined $opts->{Upper_bounds}; if (defined($opts->{Names})){ my $names_t = $opts->{Names}; barf "Names has to be an array reference" unless ref($names_t) eq 'ARRAY'; @names = @$names_t; barf "Names has to have as many elements as there are parameters " unless ( @names == $n); } } my $iflag = 0; if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_abre($mn_options->{Unit},$logfile,'old'); } foreach my $i ( 0..(nelem($pars)-1) ){ my $ii = $i + 1; $iflag = PDL::Minuit::mnparm($ii,$pars->slice("($i)"), $steps->slice("($i)"), $lo_bounds->slice("($i)"), $up_bounds->slice("($i)"), $names[$i]); barf "Problem initializing parameter $i in Minuit, got $iflag" unless ($iflag == 0); } if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_cierra($mn_options->{Unit}); } } #line 250 "Minuit.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 mnparm =for sig Signature: (longlong a(); double b(); double c(); double d(); double e(); longlong [o] ia(); char* str) =for ref info not available =for bad mnparm does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 276 "Minuit.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *mnparm = \&PDL::Minuit::mnparm; #line 282 "Minuit.pm" #line 164 "minuit.pd" sub mn_excm{ my $command = shift; my $fun_ref = $mn_options->{Function}; my ($arglis,$narg); if ( @_ ) { $arglis = shift; $narg = nelem($arglis);} else { $arglis = pdl(0); $narg = 0; } if ( @_ ) { barf "Usage : mn_excm($command, [$arglis]) \n"; } if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_abre($mn_options->{Unit},$logfile,'old'); } my $iflag = pdl(0); $iflag = PDL::Minuit::mnexcm($arglis, $narg, $command, $fun_ref,$mn_options->{N}); warn "Problem executing command '$command' " unless ($iflag == 0); if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_cierra($mn_options->{Unit}); } return $iflag; } #line 315 "Minuit.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 mnexcm =for sig Signature: (double a(n); longlong ia(); longlong [o] ib(); char* str; SV* function; IV numelem) =for ref info not available =for bad mnexcm does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 341 "Minuit.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *mnexcm = \&PDL::Minuit::mnexcm; #line 347 "Minuit.pm" #line 205 "minuit.pd" sub mn_pout{ barf "Usage: mn_pout(par_number)" unless ($#_ == 0); my $par_num = shift; my $n = $mn_options->{N}; if (($par_num < 1) || ($par_num > $n)) { barf "Parameter numbers range from 1 to $n "; } if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_abre($mn_options->{Unit},$logfile,'old'); } my $val = pdl(0); my $err = pdl(0); my $bnd1 = pdl(0); my $bnd2 = pdl(0); my $ivarbl = pdl(0); my $par_name = " "; PDL::Minuit::mnpout($par_num,$val,$err,$bnd1,$bnd2,$ivarbl,\$par_name); if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_cierra($mn_options->{Unit}); } return ($val,$err,$bnd1,$bnd2,$ivarbl,$par_name); } #line 377 "Minuit.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 mnpout =for sig Signature: (longlong ia(); double [o] a(); double [o] b(); double [o] c(); double [o] d();longlong [o] ib(); SV* str) =for ref info not available =for bad mnpout does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 403 "Minuit.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *mnpout = \&PDL::Minuit::mnpout; #line 409 "Minuit.pm" #line 242 "minuit.pd" sub mn_stat{ if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_abre($mn_options->{Unit},$logfile,'old'); } my ($fmin,$fedm,$errdef,$npari,$nparx,$istat) = PDL::Minuit::mnstat(); if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_cierra($mn_options->{Unit}); } return ($fmin,$fedm,$errdef,$npari,$nparx,$istat); } #line 429 "Minuit.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 mnstat =for sig Signature: (double [o] a(); double [o] b(); double [o] c(); longlong [o] ia(); longlong [o] ib(); longlong [o] ic()) =for ref info not available =for bad mnstat does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 455 "Minuit.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *mnstat = \&PDL::Minuit::mnstat; #line 461 "Minuit.pm" #line 264 "minuit.pd" sub mn_emat{ if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_abre($mn_options->{Unit},$logfile,'old'); } my ($fmin,$fedm,$errdef,$npari,$nparx,$istat) = PDL::Minuit::mnstat(); my $n = $npari->sum->at; my $mat = zeroes($n,$n); PDL::Minuit::mnemat($mat); if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_cierra($mn_options->{Unit}); } return $mat; } #line 486 "Minuit.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 mnemat =for sig Signature: (double [o] mat(n,n)) =for ref info not available =for bad mnemat does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 512 "Minuit.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *mnemat = \&PDL::Minuit::mnemat; #line 518 "Minuit.pm" #line 292 "minuit.pd" sub mn_err{ barf "Usage: mn_err(par_number)" unless ($#_ == 0); my $par_num = shift; my $n = $mn_options->{N}; if (($par_num < 1) || ($par_num > $n)) { barf "Parameter numbers range from 1 to $n "; } if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_abre($mn_options->{Unit},$logfile,'old'); } my ($eplus,$eminus,$eparab,$globcc) = PDL::Minuit::mnerrs($par_num); if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_cierra($mn_options->{Unit}); } return ($eplus,$eminus,$eparab,$globcc); } #line 544 "Minuit.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 mnerrs =for sig Signature: (longlong ia(); double [o] a(); double [o] b(); double [o] c(); double [o] d()) =for ref info not available =for bad mnerrs does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 570 "Minuit.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *mnerrs = \&PDL::Minuit::mnerrs; #line 576 "Minuit.pm" #line 320 "minuit.pd" sub mn_contour{ barf "Usage: mn_contour(par_number_1,par_number_2,npt)" unless ($#_ == 2); my $par_num_1 = shift; my $par_num_2 = shift; my $npt = shift; my $fun_ref = $mn_options->{Function}; my $n = $mn_options->{N}; if (($par_num_1 < 1) || ($par_num_1 > $n)) { barf "Parameter numbers range from 1 to $n "; } if (($par_num_2 < 1) || ($par_num_2 > $n)) { barf "Parameter numbers range from 1 to $n "; } if ($npt < 5) { barf "Have to specify at least 5 points in routine contour "; } my $xpt = zeroes($npt); my $ypt = zeroes($npt); my $nfound = pdl->new; PDL::Minuit::mncont($par_num_1,$par_num_2,$npt,$xpt,$ypt,$nfound,$fun_ref,$n); if (defined (my $logfile = $mn_options->{Log})){ PDL::Minuit::mn_cierra($mn_options->{Unit}); } return ($xpt,$ypt,$nfound); } #line 607 "Minuit.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 mncont =for sig Signature: (longlong ia(); longlong ib(); longlong ic(); double [o] a(n); double [o] b(n); longlong [o] id(); SV* function; IV numelem) =for ref info not available =for bad mncont does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 633 "Minuit.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *mncont = \&PDL::Minuit::mncont; #line 639 "Minuit.pm" #line 358 "minuit.pd" =head2 mn_init() =for ref The function mn_init() does the basic initialization of the fit. The first argument has to be a reference to the function to be minimized. The function to be minimized has to receive five arguments ($npar,$grad,$fval,$xval,$iflag). The first is the number of parameters currently variable. The second is the gradient of the function (which is not necessarily used, see the Minuit documentation). The third is the current value of the function. The fourth is an ndarray with the values of the parameters. The fifth is an integer flag, which indicates what the function is supposed to calculate. The function has to return the values ($fval,$grad), the function value and the function gradient. There are three optional arguments to mn_init(). By default, the output of Minuit will come through STDOUT unless a filename $logfile is given in the Log option. Note that this will mercilessly erase $logfile if it already exists. Additionally, a title can be given to the fit by the Title option, the default is 'Minuit Fit'. If the output is written to a logfile, this is assigned Fortran unit number 88. If for whatever reason you want to have control over the unit number that Fortran associates to the logfile, you can pass the number through the Unit option. =for usage Usage: mn_init($function_ref,{Log=>$logfile,Title=>$title,Unit=>$unit}) =for example Example: mn_init(\&my_function); #same as above but outputting to a file 'log.out'. #title for fit is 'My fit' mn_init(\&my_function, {Log => 'log.out', Title => 'My fit'}); sub my_function{ # the five variables input to the function to be minimized # xval is an ndarray containing the current values of the parameters my ($npar,$grad,$fval,$xval,$iflag) = @_; # Here is code computing the value of the function # and potentially also its gradient # ...... # return the two variables. If no gradient is being computed # just return the $grad that came as input return ($fval, $grad); } =head2 mn_def_pars() =for ref The function mn_def_pars() defines the initial values of the parameters of the function to be minimized and the value of the initial steps around these values that the minimizer will use for the first variations of the parameters in the search for the minimum. There are several optional arguments. One allows assigning names to these parameters which otherwise get names (Par_0, Par_1,....,Par_n) by default. Another two arguments can give lower and upper bounds for the parameters via two ndarrays. If the lower and upper bound for a given parameter are both equal to 0 then the parameter is unbound. By default these lower and upper bound ndarrays are set to zeroes(n), where n is the number of parameters, i.e. the parameters are unbound by default. The function needs two input variables: an ndarray giving the initial values of the parameters and another ndarray giving the initial steps. An optional reference to a perl array with the variable names can be passed, as well as ndarrays with upper and lower bounds for the parameters (see example below). It returns an integer variable which is 0 upon success. =for usage Usage: $iflag = mn_def_pars($pars, $steps,{Names => \@names, Lower_bounds => $lbounds, Upper_bounds => $ubounds}) =for example Example: #initial parameter values my $pars = pdl(2.5,3.0); #steps my $steps = pdl(0.3,0.5); #parameter names my @names = ('intercept','slope'); #use mn_def_pars with default parameter names (Par_0,Par_1,...) my $iflag = mn_def_pars($pars,$steps); #use of mn_def_pars explicitly specify parameter names $iflag = mn_def_pars($pars,$steps,{Names => \@names}); # specify lower and upper bounds for the parameters. # The example below leaves parameter 1 (intercept) unconstrained # and constrains parameter 2 (slope) to be between 0 and 100 my $lbounds = pdl(0, 0); my $ubounds = pdl(0, 100); $iflag = mn_def_pars($pars,$steps,{Names => \@names, Lower_bounds => $lbounds, Upper_bounds => $ubounds}}); #same as above because $lbounds is by default zeroes(n) $iflag = mn_def_pars($pars,$steps,{Names => \@names, Upper_bounds => $ubounds}}); =head2 mn_excm() The function mn_excm() executes a Minuit command passed as a string. The first argument is the command string and an optional second argument is an ndarray with arguments to the command. The available commands are listed in Chapter 4 of the Minuit manual (see url below). It returns an integer variable which is 0 upon success. =for usage Usage: $iflag = mn_excm($command_string, {$arglis}) =for example Example: #start a simplex minimization my $iflag = mn_excm('simplex'); #same as above but specify the maximum allowed numbers of #function calls in the minimization my $arglist = pdl(1000); $iflag = mn_excm('simplex',$arglist); #start a migrad minimization $iflag = mn_excm('migrad') #set Minuit strategy in order to get the most reliable results $arglist = pdl(2) $iflag = mn_excm('set strategy',$arglist); # each command can be specified by a minimal string that uniquely # identifies it (see Chapter 4 of Minuit manual). The comannd above # is equivalent to: $iflag = mn_excm('set stra',$arglis); =head2 mn_pout() The function mn_pout() gets the current value of a parameter. It takes as input the parameter number and returns an array with the parameter value, the current estimate of its uncertainty (0 if parameter is constant), lower bound on the parameter, if any (otherwise 0), upper bound on the parameter, if any (otherwise 0), integer flag (which is equal to the parameter number if variable, zero if the parameter is constant and negative if parameter is not defined) and the parameter name. =for usage Usage: ($val,$err,$bnd1,$bnd2,$ivarbl,$par_name) = mn_pout($par_number); =head2 mn_stat() The function mn_stat() gets the current status of the minimization. It returns an array with the best function value found so far, the estimated vertical distance remaining to minimum, the value of UP defining parameter uncertainties (default is 1), the number of currently variable parameters, the highest parameter defined and an integer flag indicating how good the covariance matrix is (0=not calculated at all; 1=diagonal approximation, not accurate; 2=full matrix, but forced positive definite; 3=full accurate matrix) =for usage Usage: ($fmin,$fedm,$errdef,$npari,$nparx,$istat) = mn_stat(); =head2 mn_emat() The function mn_emat returns the covariance matrix as an ndarray. =for usage Usage: $emat = mn_emat(); =head2 mn_err() The function mn_err() returns the current existing values for the error in the fitted parameters. It returns an array with the positive error, the negative error, the "parabolic" parameter error from the error matrix and the global correlation coefficient, which is a number between 0 and 1 which gives the correlation between the requested parameter and that linear combination of all other parameters which is most strongly correlated with it. Unless the command 'MINOS' has been issued via the function mn_excm(), the first three values will be equal. =for usage Usage: ($eplus,$eminus,$eparab,$globcc) = mn_err($par_number); =head2 mn_contour() The function mn_contour() finds contours of the function being minimized with respect to two chosen parameters. The contour level is given by F_min + UP, where F_min is the minimum of the function and UP is the ERRordef specified by the user, or 1.0 by default (see Minuit manual). The contour calculated by this function is dynamic, in the sense that it represents the minimum of the function being minimized with respect to all the other NPAR-2 parameters (if any). The function takes as input the parameter numbers with respect to which the contour is to be determined (two) and the number of points $npt required on the contour (>4). It returns an array with ndarrays $xpt,$ypt containing the coordinates of the contour and a variable $nfound indicating the number of points actually found in the contour. If all goes well $nfound will be equal to $npt, but it can be negative if the input arguments are not valid, zero if less than four points have been found or <$npt if the program could not find $npt points. =for usage Usage: ($xpt,$ypt,$nfound) = mn_contour($par_number_1,$par_number_2,$npt) =head1 SEE ALSO L The Minuit documentation is online at http://wwwasdoc.web.cern.ch/wwwasdoc/minuit/minmain.html =head1 AUTHOR This file copyright (C) 2007 Andres Jordan . 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 #line 913 "Minuit.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSL/0000755000175000017500000000000014200406313014426 5ustar osboxesosboxesPDL-2.074/GENERATED/PDL/GSL/RNG.pm0000644000175000017500000014621214200406313015420 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSL::RNG; our @EXPORT_OK = qw( ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core qw/ zeroes long barf /; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSL::RNG ; #line 10 "gsl_random.pd" use strict; use warnings; =head1 NAME PDL::GSL::RNG - PDL interface to RNG and randist routines in GSL =head1 DESCRIPTION This is an interface to the rng and randist packages present in the GNU Scientific Library. =head1 SYNOPSIS use PDL; use PDL::GSL::RNG; $rng = PDL::GSL::RNG->new('taus'); $rng->set_seed(time()); $x=zeroes(5,5,5) $rng->get_uniform($x); # inplace $y=$rng->get_uniform(3,4,5); # creates new pdl =head1 NOMENCLATURE Throughout this documentation we strive to use the same variables that are present in the original GSL documentation (see L). Oftentimes those variables are called C and C. Since good Perl coding practices discourage the use of Perl variables C<$a> and C<$b>, here we refer to Parameters C and C as C<$pa> and C<$pb>, respectively, and Limits (of domain or integration) as C<$la> and C<$lb>. =head1 FUNCTIONS =head2 new =for ref The new method initializes a new instance of the RNG. The available RNGs are: coveyou cmrg fishman18 fishman20 fishman2x gfsr4 knuthran knuthran2 knuthran2002 lecuyer21 minstd mrg mt19937 mt19937_1999 mt19937_1998 r250 ran0 ran1 ran2 ran3 rand rand48 random128_bsd random128_glibc2 random128_libc5 random256_bsd random256_glibc2 random256_libc5 random32_bsd random32_glibc2 random32_libc5 random64_bsd random64_glibc2 random64_libc5 random8_bsd random8_glibc2 random8_libc5 random_bsd random_glibc2 random_libc5 randu ranf ranlux ranlux389 ranlxd1 ranlxd2 ranlxs0 ranlxs1 ranlxs2 ranmar slatec taus taus2 taus113 transputer tt800 uni uni32 vax waterman14 zuf default The last one (default) uses the environment variable GSL_RNG_TYPE. Note that only a few of these rngs are recommended for general use. Please check the GSL documentation for more information. =for usage Usage: $blessed_ref = PDL::GSL::RNG->new($RNG_name); Example: =for example $rng = PDL::GSL::RNG->new('taus'); =head2 set_seed =for ref Sets the RNG seed. Usage: =for usage $rng->set_seed($integer); # or $rng = PDL::GSL::RNG->new('taus')->set_seed($integer); Example: =for example $rng->set_seed(666); =head2 min =for ref Return the minimum value generable by this RNG. Usage: =for usage $integer = $rng->min(); Example: =for example $min = $rng->min(); $max = $rng->max(); =head2 max =for ref Return the maximum value generable by the RNG. Usage: =for usage $integer = $rng->max(); Example: =for example $min = $rng->min(); $max = $rng->max(); =head2 name =for ref Returns the name of the RNG. Usage: =for usage $string = $rng->name(); Example: =for example $name = $rng->name(); =head2 get =for ref This function creates an ndarray with given dimensions or accepts an existing ndarray and fills it. get() returns integer values between a minimum and a maximum specific to every RNG. Usage: =for usage $ndarray = $rng->get($list_of_integers) $rng->get($ndarray); Example: =for example $x = zeroes 5,6; $o = $rng->get(10,10); $rng->get($x); =head2 get_int =for ref This function creates an ndarray with given dimensions or accepts an existing ndarray and fills it. get_int() returns integer values between 0 and $max. Usage: =for usage $ndarray = $rng->get($max, $list_of_integers) $rng->get($max, $ndarray); Example: =for example $x = zeroes 5,6; $max=100; $o = $rng->get(10,10); $rng->get($x); =head2 get_uniform =for ref This function creates an ndarray with given dimensions or accepts an existing ndarray and fills it. get_uniform() returns values 0<=x<1, Usage: =for usage $ndarray = $rng->get_uniform($list_of_integers) $rng->get_uniform($ndarray); Example: =for example $x = zeroes 5,6; $max=100; $o = $rng->get_uniform(10,10); $rng->get_uniform($x); =head2 get_uniform_pos =for ref This function creates an ndarray with given dimensions or accepts an existing ndarray and fills it. get_uniform_pos() returns values 0get_uniform_pos($list_of_integers) $rng->get_uniform_pos($ndarray); Example: =for example $x = zeroes 5,6; $o = $rng->get_uniform_pos(10,10); $rng->get_uniform_pos($x); =head2 ran_shuffle =for ref Shuffles values in ndarray Usage: =for usage $rng->ran_shuffle($ndarray); =head2 ran_shuffle_vec =for ref Shuffles values in ndarray Usage: =for usage $rng->ran_shuffle_vec(@vec); =head2 ran_choose =for ref Chooses values from C<$inndarray> to C<$outndarray>. Usage: =for usage $rng->ran_choose($inndarray,$outndarray); =head2 ran_choose_vec =for ref Chooses C<$n> values from C<@vec>. Usage: =for usage @chosen = $rng->ran_choose_vec($n,@vec); =head2 ran_gaussian =for ref Fills output ndarray with random values from Gaussian distribution with mean zero and standard deviation C<$sigma>. Usage: =for usage $ndarray = $rng->ran_gaussian($sigma,[list of integers = output ndarray dims]); $rng->ran_gaussian($sigma, $output_ndarray); Example: =for example $o = $rng->ran_gaussian($sigma,10,10); $rng->ran_gaussian($sigma,$o); =head2 ran_gaussian_var =for ref This method is similar to L except that it takes the parameters of the distribution as an ndarray and returns an ndarray of equal dimensions. Usage: =for usage $ndarray = $rng->ran_gaussian_var($sigma_ndarray); $rng->ran_gaussian_var($sigma_ndarray, $output_ndarray); Example: =for example $sigma_pdl = rvals zeroes 11,11; $o = $rng->ran_gaussian_var($sigma_pdl); =head2 ran_additive_gaussian =for ref Add Gaussian noise of given sigma to an ndarray. Usage: =for usage $rng->ran_additive_gaussian($sigma,$ndarray); Example: =for example $rng->ran_additive_gaussian(1,$image); =head2 ran_bivariate_gaussian =for ref Generates C<$n> bivariate gaussian random deviates. Usage: =for usage $ndarray = $rng->ran_bivariate_gaussian($sigma_x,$sigma_y,$rho,$n); Example: =for example $o = $rng->ran_bivariate_gaussian(1,2,0.5,1000); =head2 ran_poisson =for ref Fills output ndarray by with random integer values from the Poisson distribution with mean C<$mu>. Usage: =for usage $ndarray = $rng->ran_poisson($mu,[list of integers = output ndarray dims]); $rng->ran_poisson($mu,$output_ndarray); =head2 ran_poisson_var =for ref Similar to L except that it takes the distribution parameters as an ndarray and returns an ndarray of equal dimensions. Usage: =for usage $ndarray = $rng->ran_poisson_var($mu_ndarray); =head2 ran_additive_poisson =for ref Add Poisson noise of given C<$mu> to a C<$ndarray>. Usage: =for usage $rng->ran_additive_poisson($mu,$ndarray); Example: =for example $rng->ran_additive_poisson(1,$image); =head2 ran_feed_poisson =for ref This method simulates shot noise, taking the values of ndarray as values for C<$mu> to be fed in the poissonian RNG. Usage: =for usage $rng->ran_feed_poisson($ndarray); Example: =for example $rng->ran_feed_poisson($image); =head2 ran_bernoulli =for ref Fills output ndarray with random values 0 or 1, the result of a Bernoulli trial with probability C<$p>. Usage: =for usage $ndarray = $rng->ran_bernoulli($p,[list of integers = output ndarray dims]); $rng->ran_bernoulli($p,$output_ndarray); =head2 ran_bernoulli_var =for ref Similar to L except that it takes the distribution parameters as an ndarray and returns an ndarray of equal dimensions. Usage: =for usage $ndarray = $rng->ran_bernoulli_var($p_ndarray); =head2 ran_beta =for ref Fills output ndarray with random variates from the beta distribution with parameters C<$pa> and C<$pb>. Usage: =for usage $ndarray = $rng->ran_beta($pa,$pb,[list of integers = output ndarray dims]); $rng->ran_beta($pa,$pb,$output_ndarray); =head2 ran_beta_var =for ref Similar to L except that it takes the distribution parameters as an ndarray and returns an ndarray of equal dimensions. Usage: =for usage $ndarray = $rng->ran_beta_var($a_ndarray, $b_ndarray); =head2 ran_binomial =for ref Fills output ndarray with random integer values from the binomial distribution, the number of successes in C<$n> independent trials with probability C<$p>. Usage: =for usage $ndarray = $rng->ran_binomial($p,$n,[list of integers = output ndarray dims]); $rng->ran_binomial($p,$n,$output_ndarray); =head2 ran_binomial_var =for ref Similar to L except that it takes the distribution parameters as an ndarray and returns an ndarray of equal dimensions. Usage: =for usage $ndarray = $rng->ran_binomial_var($p_ndarray, $n_ndarray); =head2 ran_cauchy =for ref Fills output ndarray with random variates from the Cauchy distribution with scale parameter C<$pa>. Usage: =for usage $ndarray = $rng->ran_cauchy($pa,[list of integers = output ndarray dims]); $rng->ran_cauchy($pa,$output_ndarray); =head2 ran_cauchy_var =for ref Similar to L except that it takes the distribution parameters as an ndarray and returns an ndarray of equal dimensions. Usage: =for usage $ndarray = $rng->ran_cauchy_var($a_ndarray); =head2 ran_chisq =for ref Fills output ndarray with random variates from the chi-squared distribution with C<$nu> degrees of freedom. Usage: =for usage $ndarray = $rng->ran_chisq($nu,[list of integers = output ndarray dims]); $rng->ran_chisq($nu,$output_ndarray); =head2 ran_chisq_var =for ref Similar to L except that it takes the distribution parameters as an ndarray and returns an ndarray of equal dimensions. Usage: =for usage $ndarray = $rng->ran_chisq_var($nu_ndarray); =head2 ran_exponential =for ref Fills output ndarray with random variates from the exponential distribution with mean C<$mu>. Usage: =for usage $ndarray = $rng->ran_exponential($mu,[list of integers = output ndarray dims]); $rng->ran_exponential($mu,$output_ndarray); =head2 ran_exponential_var =for ref Similar to L except that it takes the distribution parameters as an ndarray and returns an ndarray of equal dimensions. Usage: =for usage $ndarray = $rng->ran_exponential_var($mu_ndarray); =head2 ran_exppow =for ref Fills output ndarray with random variates from the exponential power distribution with scale parameter C<$pa> and exponent C<$pb>. Usage: =for usage $ndarray = $rng->ran_exppow($pa,$pb,[list of integers = output ndarray dims]); $rng->ran_exppow($pa,$pb,$output_ndarray); =head2 ran_exppow_var =for ref Similar to L except that it takes the distribution parameters as an ndarray and returns an ndarray of equal dimensions. Usage: =for usage $ndarray = $rng->ran_exppow_var($a_ndarray, $b_ndarray); =head2 ran_fdist =for ref Fills output ndarray with random variates from the F-distribution with degrees of freedom C<$nu1> and C<$nu2>. Usage: =for usage $ndarray = $rng->ran_fdist($nu1, $nu2,[list of integers = output ndarray dims]); $rng->ran_fdist($nu1, $nu2,$output_ndarray); =head2 ran_fdist_var =for ref Similar to L except that it takes the distribution parameters as an ndarray and returns an ndarray of equal dimensions. Usage: =for usage $ndarray = $rng->ran_fdist_var($nu1_ndarray, $nu2_ndarray); =head2 ran_flat =for ref Fills output ndarray with random variates from the flat (uniform) distribution from C<$la> to C<$lb>. Usage: =for usage $ndarray = $rng->ran_flat($la,$lb,[list of integers = output ndarray dims]); $rng->ran_flat($la,$lb,$output_ndarray); =head2 ran_flat_var =for ref Similar to L except that it takes the distribution parameters as an ndarray and returns an ndarray of equal dimensions. Usage: =for usage $ndarray = $rng->ran_flat_var($a_ndarray, $b_ndarray); =head2 ran_gamma =for ref Fills output ndarray with random variates from the gamma distribution. Usage: =for usage $ndarray = $rng->ran_gamma($pa,$pb,[list of integers = output ndarray dims]); $rng->ran_gamma($pa,$pb,$output_ndarray); =head2 ran_gamma_var =for ref Similar to L except that it takes the distribution parameters as an ndarray and returns an ndarray of equal dimensions. Usage: =for usage $ndarray = $rng->ran_gamma_var($a_ndarray, $b_ndarray); =head2 ran_geometric =for ref Fills output ndarray with random integer values from the geometric distribution, the number of independent trials with probability C<$p> until the first success. Usage: =for usage $ndarray = $rng->ran_geometric($p,[list of integers = output ndarray dims]); $rng->ran_geometric($p,$output_ndarray); =head2 ran_geometric_var =for ref Similar to L except that it takes the distribution parameters as an ndarray and returns an ndarray of equal dimensions. Usage: =for usage $ndarray = $rng->ran_geometric_var($p_ndarray); =head2 ran_gumbel1 =for ref Fills output ndarray with random variates from the Type-1 Gumbel distribution. Usage: =for usage $ndarray = $rng->ran_gumbel1($pa,$pb,[list of integers = output ndarray dims]); $rng->ran_gumbel1($pa,$pb,$output_ndarray); =head2 ran_gumbel1_var =for ref Similar to L except that it takes the distribution parameters as an ndarray and returns an ndarray of equal dimensions. Usage: =for usage $ndarray = $rng->ran_gumbel1_var($a_ndarray, $b_ndarray); =head2 ran_gumbel2 =for ref Fills output ndarray with random variates from the Type-2 Gumbel distribution. Usage: =for usage $ndarray = $rng->ran_gumbel2($pa,$pb,[list of integers = output ndarray dims]); $rng->ran_gumbel2($pa,$pb,$output_ndarray); =head2 ran_gumbel2_var =for ref Similar to L except that it takes the distribution parameters as an ndarray and returns an ndarray of equal dimensions. Usage: =for usage $ndarray = $rng->ran_gumbel2_var($a_ndarray, $b_ndarray); =head2 ran_hypergeometric =for ref Fills output ndarray with random integer values from the hypergeometric distribution. If a population contains C<$n1> elements of type 1 and C<$n2> elements of type 2 then the hypergeometric distribution gives the probability of obtaining C<$x> elements of type 1 in C<$t> samples from the population without replacement. Usage: =for usage $ndarray = $rng->ran_hypergeometric($n1, $n2, $t,[list of integers = output ndarray dims]); $rng->ran_hypergeometric($n1, $n2, $t,$output_ndarray); =head2 ran_hypergeometric_var =for ref Similar to L except that it takes the distribution parameters as an ndarray and returns an ndarray of equal dimensions. Usage: =for usage $ndarray = $rng->ran_hypergeometric_var($n1_ndarray, $n2_ndarray, $t_ndarray); =head2 ran_laplace =for ref Fills output ndarray with random variates from the Laplace distribution with width C<$pa>. Usage: =for usage $ndarray = $rng->ran_laplace($pa,[list of integers = output ndarray dims]); $rng->ran_laplace($pa,$output_ndarray); =head2 ran_laplace_var =for ref Similar to L except that it takes the distribution parameters as an ndarray and returns an ndarray of equal dimensions. Usage: =for usage $ndarray = $rng->ran_laplace_var($a_ndarray); =head2 ran_levy =for ref Fills output ndarray with random variates from the Levy symmetric stable distribution with scale C<$c> and exponent C<$alpha>. Usage: =for usage $ndarray = $rng->ran_levy($mu,$x,[list of integers = output ndarray dims]); $rng->ran_levy($mu,$x,$output_ndarray); =head2 ran_levy_var =for ref Similar to L except that it takes the distribution parameters as an ndarray and returns an ndarray of equal dimensions. Usage: =for usage $ndarray = $rng->ran_levy_var($mu_ndarray, $a_ndarray); =head2 ran_logarithmic =for ref Fills output ndarray with random integer values from the logarithmic distribution. Usage: =for usage $ndarray = $rng->ran_logarithmic($p,[list of integers = output ndarray dims]); $rng->ran_logarithmic($p,$output_ndarray); =head2 ran_logarithmic_var =for ref Similar to L except that it takes the distribution parameters as an ndarray and returns an ndarray of equal dimensions. Usage: =for usage $ndarray = $rng->ran_logarithmic_var($p_ndarray); =head2 ran_logistic =for ref Fills output ndarray with random random variates from the logistic distribution. Usage: =for usage $ndarray = $rng->ran_logistic($m,[list of integers = output ndarray dims]u) $rng->ran_logistic($m,$output_ndarray) =head2 ran_logistic_var =for ref Similar to L except that it takes the distribution parameters as an ndarray and returns an ndarray of equal dimensions. Usage: =for usage $ndarray = $rng->ran_logistic_var($m_ndarray); =head2 ran_lognormal =for ref Fills output ndarray with random variates from the lognormal distribution with parameters C<$mu> (location) and C<$sigma> (scale). Usage: =for usage $ndarray = $rng->ran_lognormal($mu,$sigma,[list of integers = output ndarray dims]); $rng->ran_lognormal($mu,$sigma,$output_ndarray); =head2 ran_lognormal_var =for ref Similar to L except that it takes the distribution parameters as an ndarray and returns an ndarray of equal dimensions. Usage: =for usage $ndarray = $rng->ran_lognormal_var($mu_ndarray, $sigma_ndarray); =head2 ran_negative_binomial =for ref Fills output ndarray with random integer values from the negative binomial distribution, the number of failures occurring before C<$n> successes in independent trials with probability C<$p> of success. Note that C<$n> is not required to be an integer. Usage: =for usage $ndarray = $rng->ran_negative_binomial($p,$n,[list of integers = output ndarray dims]); $rng->ran_negative_binomial($p,$n,$output_ndarray); =head2 ran_negative_binomial_var =for ref Similar to L except that it takes the distribution parameters as an ndarray and returns an ndarray of equal dimensions. Usage: =for usage $ndarray = $rng->ran_negative_binomial_var($p_ndarray, $n_ndarray); =head2 ran_pareto =for ref Fills output ndarray with random variates from the Pareto distribution of order C<$pa> and scale C<$lb>. Usage: =for usage $ndarray = $rng->ran_pareto($pa,$lb,[list of integers = output ndarray dims]); $rng->ran_pareto($pa,$lb,$output_ndarray); =head2 ran_pareto_var =for ref Similar to L except that it takes the distribution parameters as an ndarray and returns an ndarray of equal dimensions. Usage: =for usage $ndarray = $rng->ran_pareto_var($a_ndarray, $b_ndarray); =head2 ran_pascal =for ref Fills output ndarray with random integer values from the Pascal distribution. The Pascal distribution is simply a negative binomial distribution (see L) with an integer value of C<$n>. Usage: =for usage $ndarray = $rng->ran_pascal($p,$n,[list of integers = output ndarray dims]); $rng->ran_pascal($p,$n,$output_ndarray); =head2 ran_pascal_var =for ref Similar to L except that it takes the distribution parameters as an ndarray and returns an ndarray of equal dimensions. Usage: =for usage $ndarray = $rng->ran_pascal_var($p_ndarray, $n_ndarray); =head2 ran_rayleigh =for ref Fills output ndarray with random variates from the Rayleigh distribution with scale parameter C<$sigma>. Usage: =for usage $ndarray = $rng->ran_rayleigh($sigma,[list of integers = output ndarray dims]); $rng->ran_rayleigh($sigma,$output_ndarray); =head2 ran_rayleigh_var =for ref Similar to L except that it takes the distribution parameters as an ndarray and returns an ndarray of equal dimensions. Usage: =for usage $ndarray = $rng->ran_rayleigh_var($sigma_ndarray); =head2 ran_rayleigh_tail =for ref Fills output ndarray with random variates from the tail of the Rayleigh distribution with scale parameter C<$sigma> and a lower limit of C<$la>. Usage: =for usage $ndarray = $rng->ran_rayleigh_tail($la,$sigma,[list of integers = output ndarray dims]); $rng->ran_rayleigh_tail($x,$sigma,$output_ndarray); =head2 ran_rayleigh_tail_var =for ref Similar to L except that it takes the distribution parameters as an ndarray and returns an ndarray of equal dimensions. Usage: =for usage $ndarray = $rng->ran_rayleigh_tail_var($a_ndarray, $sigma_ndarray); =head2 ran_tdist =for ref Fills output ndarray with random variates from the t-distribution (AKA Student's t-distribution) with C<$nu> degrees of freedom. Usage: =for usage $ndarray = $rng->ran_tdist($nu,[list of integers = output ndarray dims]); $rng->ran_tdist($nu,$output_ndarray); =head2 ran_tdist_var =for ref Similar to L except that it takes the distribution parameters as an ndarray and returns an ndarray of equal dimensions. Usage: =for usage $ndarray = $rng->ran_tdist_var($nu_ndarray); =head2 ran_ugaussian_tail =for ref Fills output ndarray with random variates from the upper tail of a Gaussian distribution with C (AKA unit Gaussian distribution). Usage: =for usage $ndarray = $rng->ran_ugaussian_tail($tail,[list of integers = output ndarray dims]); $rng->ran_ugaussian_tail($tail,$output_ndarray); =head2 ran_ugaussian_tail_var =for ref Similar to L except that it takes the distribution parameters as an ndarray and returns an ndarray of equal dimensions. Usage: =for usage $ndarray = $rng->ran_ugaussian_tail_var($tail_ndarray); =head2 ran_weibull =for ref Fills output ndarray with random variates from the Weibull distribution with scale C<$pa> and exponent C<$pb>. (Some literature uses C for C<$pa> and C for C<$pb>.) Usage: =for usage $ndarray = $rng->ran_weibull($pa,$pb,[list of integers = output ndarray dims]); $rng->ran_weibull($pa,$pb,$output_ndarray); =head2 ran_weibull_var =for ref Similar to L except that it takes the distribution parameters as an ndarray and returns an ndarray of equal dimensions. Usage: =for usage $ndarray = $rng->ran_weibull_var($a_ndarray, $b_ndarray); =head2 ran_dir =for ref Returns C<$n> random vectors in C<$ndim> dimensions. Usage: =for usage $ndarray = $rng->ran_dir($ndim,$n); Example: =for example $o = $rng->ran_dir($ndim,$n); =head2 ran_discrete_preproc =for ref This method returns a handle that must be used when calling L. You specify the probability of the integer number that are returned by L. Usage: =for usage $discrete_dist_handle = $rng->ran_discrete_preproc($double_ndarray_prob); Example: =for example $prob = pdl [0.1,0.3,0.6]; $ddh = $rng->ran_discrete_preproc($prob); $o = $rng->ran_discrete($discrete_dist_handle,100); =head2 ran_discrete =for ref Is used to get the desired samples once a proper handle has been enstablished (see ran_discrete_preproc()). Usage: =for usage $ndarray = $rng->ran_discrete($discrete_dist_handle,$num); Example: =for example $prob = pdl [0.1,0.3,0.6]; $ddh = $rng->ran_discrete_preproc($prob); $o = $rng->ran_discrete($discrete_dist_handle,100); =head2 ran_ver =for ref Returns an ndarray with C<$n> values generated by the Verhulst map from C<$x0> and parameter C<$r>. Usage: =for usage $rng->ran_ver($x0, $r, $n); =head2 ran_caos =for ref Returns values from Verhuls map with C<$r=4.0> and randomly chosen C<$x0>. The values are scaled by C<$m>. Usage: =for usage $rng->ran_caos($m,$n); =head1 BUGS Feedback is welcome. Log bugs in the PDL bug database (the database is always linked from L). =head1 SEE ALSO L The GSL documentation for random number distributions is online at L =head1 AUTHOR This file copyright (C) 1999 Christian Pellegrin Docs mangled by C. Soeller. 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. The GSL RNG and randist modules were written by James Theiler. =cut #line 1282 "RNG.pm" #line 1310 "gsl_random.pd" use strict; # PDL::GSL::RNG::nullcreate just creates a null PDL. Used # for the GSL functions that create PDLs sub nullcreate{ my ($type,$arg) = @_; PDL->nullcreate($arg); } #line 1302 "RNG.pm" #line 1324 "gsl_random.pd" sub get_uniform { my ($obj,@var) = @_;if (ref($var[0]) eq 'PDL') { gsl_get_uniform_meat($var[0],$$obj); return $var[0]; } else { my $p; $p = zeroes @var; gsl_get_uniform_meat($p,$$obj); return $p; } } #line 1321 "RNG.pm" #line 1325 "gsl_random.pd" sub get_uniform_pos { my ($obj,@var) = @_;if (ref($var[0]) eq 'PDL') { gsl_get_uniform_pos_meat($var[0],$$obj); return $var[0]; } else { my $p; $p = zeroes @var; gsl_get_uniform_pos_meat($p,$$obj); return $p; } } #line 1340 "RNG.pm" #line 1326 "gsl_random.pd" sub get { my ($obj,@var) = @_;if (ref($var[0]) eq 'PDL') { gsl_get_meat($var[0],$$obj); return $var[0]; } else { my $p; $p = zeroes @var; gsl_get_meat($p,$$obj); return $p; } } #line 1359 "RNG.pm" #line 1327 "gsl_random.pd" sub get_int { my ($obj,$n,@var) = @_;if (!($n>0)) {barf("first parameter must be an int >0")};if (ref($var[0]) eq 'PDL') { gsl_get_int_meat($var[0],$n,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; gsl_get_int_meat($p,$n,$$obj); return $p; } } #line 1378 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_get_uniform_meat = \&PDL::GSL::RNG::gsl_get_uniform_meat; #line 1384 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_get_uniform_pos_meat = \&PDL::GSL::RNG::gsl_get_uniform_pos_meat; #line 1390 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_get_meat = \&PDL::GSL::RNG::gsl_get_meat; #line 1396 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_get_int_meat = \&PDL::GSL::RNG::gsl_get_int_meat; #line 1402 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_gaussian_meat = \&PDL::GSL::RNG::ran_gaussian_meat; #line 1408 "RNG.pm" #line 1408 "gsl_random.pd" sub ran_gaussian { my ($obj,$a,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_gaussian_meat($var[0],$a,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_gaussian_meat($p,$a,$$obj); return $p; } } #line 1428 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_gaussian_var_meat = \&PDL::GSL::RNG::ran_gaussian_var_meat; #line 1434 "RNG.pm" #line 1432 "gsl_random.pd" sub ran_gaussian_var { my ($obj,@var) = @_; if (scalar(@var) != 1) {barf("Bad number of parameters!");} return ran_gaussian_var_meat(@var,$$obj); } #line 1445 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_ugaussian_tail_meat = \&PDL::GSL::RNG::ran_ugaussian_tail_meat; #line 1451 "RNG.pm" #line 1408 "gsl_random.pd" sub ran_ugaussian_tail { my ($obj,$a,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_ugaussian_tail_meat($var[0],$a,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_ugaussian_tail_meat($p,$a,$$obj); return $p; } } #line 1471 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_ugaussian_tail_var_meat = \&PDL::GSL::RNG::ran_ugaussian_tail_var_meat; #line 1477 "RNG.pm" #line 1432 "gsl_random.pd" sub ran_ugaussian_tail_var { my ($obj,@var) = @_; if (scalar(@var) != 1) {barf("Bad number of parameters!");} return ran_ugaussian_tail_var_meat(@var,$$obj); } #line 1488 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_exponential_meat = \&PDL::GSL::RNG::ran_exponential_meat; #line 1494 "RNG.pm" #line 1408 "gsl_random.pd" sub ran_exponential { my ($obj,$a,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_exponential_meat($var[0],$a,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_exponential_meat($p,$a,$$obj); return $p; } } #line 1514 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_exponential_var_meat = \&PDL::GSL::RNG::ran_exponential_var_meat; #line 1520 "RNG.pm" #line 1432 "gsl_random.pd" sub ran_exponential_var { my ($obj,@var) = @_; if (scalar(@var) != 1) {barf("Bad number of parameters!");} return ran_exponential_var_meat(@var,$$obj); } #line 1531 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_laplace_meat = \&PDL::GSL::RNG::ran_laplace_meat; #line 1537 "RNG.pm" #line 1408 "gsl_random.pd" sub ran_laplace { my ($obj,$a,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_laplace_meat($var[0],$a,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_laplace_meat($p,$a,$$obj); return $p; } } #line 1557 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_laplace_var_meat = \&PDL::GSL::RNG::ran_laplace_var_meat; #line 1563 "RNG.pm" #line 1432 "gsl_random.pd" sub ran_laplace_var { my ($obj,@var) = @_; if (scalar(@var) != 1) {barf("Bad number of parameters!");} return ran_laplace_var_meat(@var,$$obj); } #line 1574 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_exppow_meat = \&PDL::GSL::RNG::ran_exppow_meat; #line 1580 "RNG.pm" #line 1408 "gsl_random.pd" sub ran_exppow { my ($obj,$a,$b,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_exppow_meat($var[0],$a,$b,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_exppow_meat($p,$a,$b,$$obj); return $p; } } #line 1600 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_exppow_var_meat = \&PDL::GSL::RNG::ran_exppow_var_meat; #line 1606 "RNG.pm" #line 1432 "gsl_random.pd" sub ran_exppow_var { my ($obj,@var) = @_; if (scalar(@var) != 2) {barf("Bad number of parameters!");} return ran_exppow_var_meat(@var,$$obj); } #line 1617 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_cauchy_meat = \&PDL::GSL::RNG::ran_cauchy_meat; #line 1623 "RNG.pm" #line 1408 "gsl_random.pd" sub ran_cauchy { my ($obj,$a,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_cauchy_meat($var[0],$a,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_cauchy_meat($p,$a,$$obj); return $p; } } #line 1643 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_cauchy_var_meat = \&PDL::GSL::RNG::ran_cauchy_var_meat; #line 1649 "RNG.pm" #line 1432 "gsl_random.pd" sub ran_cauchy_var { my ($obj,@var) = @_; if (scalar(@var) != 1) {barf("Bad number of parameters!");} return ran_cauchy_var_meat(@var,$$obj); } #line 1660 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_rayleigh_meat = \&PDL::GSL::RNG::ran_rayleigh_meat; #line 1666 "RNG.pm" #line 1408 "gsl_random.pd" sub ran_rayleigh { my ($obj,$a,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_rayleigh_meat($var[0],$a,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_rayleigh_meat($p,$a,$$obj); return $p; } } #line 1686 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_rayleigh_var_meat = \&PDL::GSL::RNG::ran_rayleigh_var_meat; #line 1692 "RNG.pm" #line 1432 "gsl_random.pd" sub ran_rayleigh_var { my ($obj,@var) = @_; if (scalar(@var) != 1) {barf("Bad number of parameters!");} return ran_rayleigh_var_meat(@var,$$obj); } #line 1703 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_rayleigh_tail_meat = \&PDL::GSL::RNG::ran_rayleigh_tail_meat; #line 1709 "RNG.pm" #line 1408 "gsl_random.pd" sub ran_rayleigh_tail { my ($obj,$a,$b,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_rayleigh_tail_meat($var[0],$a,$b,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_rayleigh_tail_meat($p,$a,$b,$$obj); return $p; } } #line 1729 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_rayleigh_tail_var_meat = \&PDL::GSL::RNG::ran_rayleigh_tail_var_meat; #line 1735 "RNG.pm" #line 1432 "gsl_random.pd" sub ran_rayleigh_tail_var { my ($obj,@var) = @_; if (scalar(@var) != 2) {barf("Bad number of parameters!");} return ran_rayleigh_tail_var_meat(@var,$$obj); } #line 1746 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_levy_meat = \&PDL::GSL::RNG::ran_levy_meat; #line 1752 "RNG.pm" #line 1408 "gsl_random.pd" sub ran_levy { my ($obj,$a,$b,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_levy_meat($var[0],$a,$b,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_levy_meat($p,$a,$b,$$obj); return $p; } } #line 1772 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_levy_var_meat = \&PDL::GSL::RNG::ran_levy_var_meat; #line 1778 "RNG.pm" #line 1432 "gsl_random.pd" sub ran_levy_var { my ($obj,@var) = @_; if (scalar(@var) != 2) {barf("Bad number of parameters!");} return ran_levy_var_meat(@var,$$obj); } #line 1789 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_gamma_meat = \&PDL::GSL::RNG::ran_gamma_meat; #line 1795 "RNG.pm" #line 1408 "gsl_random.pd" sub ran_gamma { my ($obj,$a,$b,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_gamma_meat($var[0],$a,$b,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_gamma_meat($p,$a,$b,$$obj); return $p; } } #line 1815 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_gamma_var_meat = \&PDL::GSL::RNG::ran_gamma_var_meat; #line 1821 "RNG.pm" #line 1432 "gsl_random.pd" sub ran_gamma_var { my ($obj,@var) = @_; if (scalar(@var) != 2) {barf("Bad number of parameters!");} return ran_gamma_var_meat(@var,$$obj); } #line 1832 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_flat_meat = \&PDL::GSL::RNG::ran_flat_meat; #line 1838 "RNG.pm" #line 1408 "gsl_random.pd" sub ran_flat { my ($obj,$a,$b,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_flat_meat($var[0],$a,$b,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_flat_meat($p,$a,$b,$$obj); return $p; } } #line 1858 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_flat_var_meat = \&PDL::GSL::RNG::ran_flat_var_meat; #line 1864 "RNG.pm" #line 1432 "gsl_random.pd" sub ran_flat_var { my ($obj,@var) = @_; if (scalar(@var) != 2) {barf("Bad number of parameters!");} return ran_flat_var_meat(@var,$$obj); } #line 1875 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_lognormal_meat = \&PDL::GSL::RNG::ran_lognormal_meat; #line 1881 "RNG.pm" #line 1408 "gsl_random.pd" sub ran_lognormal { my ($obj,$a,$b,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_lognormal_meat($var[0],$a,$b,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_lognormal_meat($p,$a,$b,$$obj); return $p; } } #line 1901 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_lognormal_var_meat = \&PDL::GSL::RNG::ran_lognormal_var_meat; #line 1907 "RNG.pm" #line 1432 "gsl_random.pd" sub ran_lognormal_var { my ($obj,@var) = @_; if (scalar(@var) != 2) {barf("Bad number of parameters!");} return ran_lognormal_var_meat(@var,$$obj); } #line 1918 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_chisq_meat = \&PDL::GSL::RNG::ran_chisq_meat; #line 1924 "RNG.pm" #line 1408 "gsl_random.pd" sub ran_chisq { my ($obj,$a,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_chisq_meat($var[0],$a,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_chisq_meat($p,$a,$$obj); return $p; } } #line 1944 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_chisq_var_meat = \&PDL::GSL::RNG::ran_chisq_var_meat; #line 1950 "RNG.pm" #line 1432 "gsl_random.pd" sub ran_chisq_var { my ($obj,@var) = @_; if (scalar(@var) != 1) {barf("Bad number of parameters!");} return ran_chisq_var_meat(@var,$$obj); } #line 1961 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_fdist_meat = \&PDL::GSL::RNG::ran_fdist_meat; #line 1967 "RNG.pm" #line 1408 "gsl_random.pd" sub ran_fdist { my ($obj,$a,$b,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_fdist_meat($var[0],$a,$b,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_fdist_meat($p,$a,$b,$$obj); return $p; } } #line 1987 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_fdist_var_meat = \&PDL::GSL::RNG::ran_fdist_var_meat; #line 1993 "RNG.pm" #line 1432 "gsl_random.pd" sub ran_fdist_var { my ($obj,@var) = @_; if (scalar(@var) != 2) {barf("Bad number of parameters!");} return ran_fdist_var_meat(@var,$$obj); } #line 2004 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_tdist_meat = \&PDL::GSL::RNG::ran_tdist_meat; #line 2010 "RNG.pm" #line 1408 "gsl_random.pd" sub ran_tdist { my ($obj,$a,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_tdist_meat($var[0],$a,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_tdist_meat($p,$a,$$obj); return $p; } } #line 2030 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_tdist_var_meat = \&PDL::GSL::RNG::ran_tdist_var_meat; #line 2036 "RNG.pm" #line 1432 "gsl_random.pd" sub ran_tdist_var { my ($obj,@var) = @_; if (scalar(@var) != 1) {barf("Bad number of parameters!");} return ran_tdist_var_meat(@var,$$obj); } #line 2047 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_beta_meat = \&PDL::GSL::RNG::ran_beta_meat; #line 2053 "RNG.pm" #line 1408 "gsl_random.pd" sub ran_beta { my ($obj,$a,$b,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_beta_meat($var[0],$a,$b,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_beta_meat($p,$a,$b,$$obj); return $p; } } #line 2073 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_beta_var_meat = \&PDL::GSL::RNG::ran_beta_var_meat; #line 2079 "RNG.pm" #line 1432 "gsl_random.pd" sub ran_beta_var { my ($obj,@var) = @_; if (scalar(@var) != 2) {barf("Bad number of parameters!");} return ran_beta_var_meat(@var,$$obj); } #line 2090 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_logistic_meat = \&PDL::GSL::RNG::ran_logistic_meat; #line 2096 "RNG.pm" #line 1408 "gsl_random.pd" sub ran_logistic { my ($obj,$a,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_logistic_meat($var[0],$a,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_logistic_meat($p,$a,$$obj); return $p; } } #line 2116 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_logistic_var_meat = \&PDL::GSL::RNG::ran_logistic_var_meat; #line 2122 "RNG.pm" #line 1432 "gsl_random.pd" sub ran_logistic_var { my ($obj,@var) = @_; if (scalar(@var) != 1) {barf("Bad number of parameters!");} return ran_logistic_var_meat(@var,$$obj); } #line 2133 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_pareto_meat = \&PDL::GSL::RNG::ran_pareto_meat; #line 2139 "RNG.pm" #line 1408 "gsl_random.pd" sub ran_pareto { my ($obj,$a,$b,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_pareto_meat($var[0],$a,$b,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_pareto_meat($p,$a,$b,$$obj); return $p; } } #line 2159 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_pareto_var_meat = \&PDL::GSL::RNG::ran_pareto_var_meat; #line 2165 "RNG.pm" #line 1432 "gsl_random.pd" sub ran_pareto_var { my ($obj,@var) = @_; if (scalar(@var) != 2) {barf("Bad number of parameters!");} return ran_pareto_var_meat(@var,$$obj); } #line 2176 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_weibull_meat = \&PDL::GSL::RNG::ran_weibull_meat; #line 2182 "RNG.pm" #line 1408 "gsl_random.pd" sub ran_weibull { my ($obj,$a,$b,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_weibull_meat($var[0],$a,$b,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_weibull_meat($p,$a,$b,$$obj); return $p; } } #line 2202 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_weibull_var_meat = \&PDL::GSL::RNG::ran_weibull_var_meat; #line 2208 "RNG.pm" #line 1432 "gsl_random.pd" sub ran_weibull_var { my ($obj,@var) = @_; if (scalar(@var) != 2) {barf("Bad number of parameters!");} return ran_weibull_var_meat(@var,$$obj); } #line 2219 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_gumbel1_meat = \&PDL::GSL::RNG::ran_gumbel1_meat; #line 2225 "RNG.pm" #line 1408 "gsl_random.pd" sub ran_gumbel1 { my ($obj,$a,$b,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_gumbel1_meat($var[0],$a,$b,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_gumbel1_meat($p,$a,$b,$$obj); return $p; } } #line 2245 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_gumbel1_var_meat = \&PDL::GSL::RNG::ran_gumbel1_var_meat; #line 2251 "RNG.pm" #line 1432 "gsl_random.pd" sub ran_gumbel1_var { my ($obj,@var) = @_; if (scalar(@var) != 2) {barf("Bad number of parameters!");} return ran_gumbel1_var_meat(@var,$$obj); } #line 2262 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_gumbel2_meat = \&PDL::GSL::RNG::ran_gumbel2_meat; #line 2268 "RNG.pm" #line 1408 "gsl_random.pd" sub ran_gumbel2 { my ($obj,$a,$b,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_gumbel2_meat($var[0],$a,$b,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_gumbel2_meat($p,$a,$b,$$obj); return $p; } } #line 2288 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_gumbel2_var_meat = \&PDL::GSL::RNG::ran_gumbel2_var_meat; #line 2294 "RNG.pm" #line 1432 "gsl_random.pd" sub ran_gumbel2_var { my ($obj,@var) = @_; if (scalar(@var) != 2) {barf("Bad number of parameters!");} return ran_gumbel2_var_meat(@var,$$obj); } #line 2305 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_poisson_meat = \&PDL::GSL::RNG::ran_poisson_meat; #line 2311 "RNG.pm" #line 1408 "gsl_random.pd" sub ran_poisson { my ($obj,$a,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_poisson_meat($var[0],$a,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_poisson_meat($p,$a,$$obj); return $p; } } #line 2331 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_poisson_var_meat = \&PDL::GSL::RNG::ran_poisson_var_meat; #line 2337 "RNG.pm" #line 1432 "gsl_random.pd" sub ran_poisson_var { my ($obj,@var) = @_; if (scalar(@var) != 1) {barf("Bad number of parameters!");} return ran_poisson_var_meat(@var,$$obj); } #line 2348 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_bernoulli_meat = \&PDL::GSL::RNG::ran_bernoulli_meat; #line 2354 "RNG.pm" #line 1408 "gsl_random.pd" sub ran_bernoulli { my ($obj,$a,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_bernoulli_meat($var[0],$a,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_bernoulli_meat($p,$a,$$obj); return $p; } } #line 2374 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_bernoulli_var_meat = \&PDL::GSL::RNG::ran_bernoulli_var_meat; #line 2380 "RNG.pm" #line 1432 "gsl_random.pd" sub ran_bernoulli_var { my ($obj,@var) = @_; if (scalar(@var) != 1) {barf("Bad number of parameters!");} return ran_bernoulli_var_meat(@var,$$obj); } #line 2391 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_binomial_meat = \&PDL::GSL::RNG::ran_binomial_meat; #line 2397 "RNG.pm" #line 1408 "gsl_random.pd" sub ran_binomial { my ($obj,$a,$b,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_binomial_meat($var[0],$a,$b,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_binomial_meat($p,$a,$b,$$obj); return $p; } } #line 2417 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_binomial_var_meat = \&PDL::GSL::RNG::ran_binomial_var_meat; #line 2423 "RNG.pm" #line 1432 "gsl_random.pd" sub ran_binomial_var { my ($obj,@var) = @_; if (scalar(@var) != 2) {barf("Bad number of parameters!");} return ran_binomial_var_meat(@var,$$obj); } #line 2434 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_negative_binomial_meat = \&PDL::GSL::RNG::ran_negative_binomial_meat; #line 2440 "RNG.pm" #line 1408 "gsl_random.pd" sub ran_negative_binomial { my ($obj,$a,$b,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_negative_binomial_meat($var[0],$a,$b,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_negative_binomial_meat($p,$a,$b,$$obj); return $p; } } #line 2460 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_negative_binomial_var_meat = \&PDL::GSL::RNG::ran_negative_binomial_var_meat; #line 2466 "RNG.pm" #line 1432 "gsl_random.pd" sub ran_negative_binomial_var { my ($obj,@var) = @_; if (scalar(@var) != 2) {barf("Bad number of parameters!");} return ran_negative_binomial_var_meat(@var,$$obj); } #line 2477 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_pascal_meat = \&PDL::GSL::RNG::ran_pascal_meat; #line 2483 "RNG.pm" #line 1408 "gsl_random.pd" sub ran_pascal { my ($obj,$a,$b,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_pascal_meat($var[0],$a,$b,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_pascal_meat($p,$a,$b,$$obj); return $p; } } #line 2503 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_pascal_var_meat = \&PDL::GSL::RNG::ran_pascal_var_meat; #line 2509 "RNG.pm" #line 1432 "gsl_random.pd" sub ran_pascal_var { my ($obj,@var) = @_; if (scalar(@var) != 2) {barf("Bad number of parameters!");} return ran_pascal_var_meat(@var,$$obj); } #line 2520 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_geometric_meat = \&PDL::GSL::RNG::ran_geometric_meat; #line 2526 "RNG.pm" #line 1408 "gsl_random.pd" sub ran_geometric { my ($obj,$a,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_geometric_meat($var[0],$a,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_geometric_meat($p,$a,$$obj); return $p; } } #line 2546 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_geometric_var_meat = \&PDL::GSL::RNG::ran_geometric_var_meat; #line 2552 "RNG.pm" #line 1432 "gsl_random.pd" sub ran_geometric_var { my ($obj,@var) = @_; if (scalar(@var) != 1) {barf("Bad number of parameters!");} return ran_geometric_var_meat(@var,$$obj); } #line 2563 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_hypergeometric_meat = \&PDL::GSL::RNG::ran_hypergeometric_meat; #line 2569 "RNG.pm" #line 1408 "gsl_random.pd" sub ran_hypergeometric { my ($obj,$a,$b,$c,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_hypergeometric_meat($var[0],$a,$b,$c,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_hypergeometric_meat($p,$a,$b,$c,$$obj); return $p; } } #line 2589 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_hypergeometric_var_meat = \&PDL::GSL::RNG::ran_hypergeometric_var_meat; #line 2595 "RNG.pm" #line 1432 "gsl_random.pd" sub ran_hypergeometric_var { my ($obj,@var) = @_; if (scalar(@var) != 3) {barf("Bad number of parameters!");} return ran_hypergeometric_var_meat(@var,$$obj); } #line 2606 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_logarithmic_meat = \&PDL::GSL::RNG::ran_logarithmic_meat; #line 2612 "RNG.pm" #line 1408 "gsl_random.pd" sub ran_logarithmic { my ($obj,$a,@var) = @_; if (ref($var[0]) eq 'PDL') { ran_logarithmic_meat($var[0],$a,$$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_logarithmic_meat($p,$a,$$obj); return $p; } } #line 2632 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_logarithmic_var_meat = \&PDL::GSL::RNG::ran_logarithmic_var_meat; #line 2638 "RNG.pm" #line 1432 "gsl_random.pd" sub ran_logarithmic_var { my ($obj,@var) = @_; if (scalar(@var) != 1) {barf("Bad number of parameters!");} return ran_logarithmic_var_meat(@var,$$obj); } #line 2649 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_additive_gaussian_meat = \&PDL::GSL::RNG::ran_additive_gaussian_meat; #line 2655 "RNG.pm" #line 1522 "gsl_random.pd" sub ran_additive_gaussian { my ($obj,$sigma,$var) = @_; barf("In additive gaussian mode you must specify an ndarray!") if ref($var) ne 'PDL'; ran_additive_gaussian_meat($var,$sigma,$$obj); return $var; } #line 2669 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_additive_poisson_meat = \&PDL::GSL::RNG::ran_additive_poisson_meat; #line 2675 "RNG.pm" #line 1538 "gsl_random.pd" sub ran_additive_poisson { my ($obj,$sigma,$var) = @_; barf("In additive poisson mode you must specify an ndarray!") if ref($var) ne 'PDL'; ran_additive_poisson_meat($var,$sigma,$$obj); return $var; } #line 2689 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_feed_poisson_meat = \&PDL::GSL::RNG::ran_feed_poisson_meat; #line 2695 "RNG.pm" #line 1554 "gsl_random.pd" sub ran_feed_poisson { my ($obj,$var) = @_; barf("In poisson mode you must specify an ndarray!") if ref($var) ne 'PDL'; ran_feed_poisson_meat($var,$$obj); return $var; } #line 2709 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_bivariate_gaussian_meat = \&PDL::GSL::RNG::ran_bivariate_gaussian_meat; #line 2715 "RNG.pm" #line 1575 "gsl_random.pd" sub ran_bivariate_gaussian { my ($obj,$sigma_x,$sigma_y,$rho,$n) = @_; barf("Not enough parameters for gaussian bivariate!") if $n<=0; my $p = zeroes(2,$n); ran_bivariate_gaussian_meat($p,$sigma_x,$sigma_y,$rho,$$obj); return $p; } #line 2729 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_dir_2d_meat = \&PDL::GSL::RNG::ran_dir_2d_meat; #line 2735 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_dir_3d_meat = \&PDL::GSL::RNG::ran_dir_3d_meat; #line 2741 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_dir_nd_meat = \&PDL::GSL::RNG::ran_dir_nd_meat; #line 2747 "RNG.pm" #line 1619 "gsl_random.pd" sub ran_dir { my ($obj,$ndim,$n) = @_; barf("Not enough parameters for random vectors!") if $n<=0; my $p = zeroes($ndim,$n); if ($ndim==2) { ran_dir_2d_meat($p,$$obj); } elsif ($ndim==3) { ran_dir_3d_meat($p,$$obj); } elsif ($ndim>=4 && $ndim<=100) { ran_dir_nd_meat($p,$ndim,$$obj); } else { barf("Bad number of dimensions!"); } return $p; } #line 2764 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_discrete_meat = \&PDL::GSL::RNG::ran_discrete_meat; #line 2770 "RNG.pm" #line 1639 "gsl_random.pd" sub ran_discrete { my ($obj, $rdt, @var) = @_; if (ref($var[0]) eq 'PDL') { ran_discrete_meat($var[0], $$rdt, $$obj); return $var[0]; } else { my $p; $p = zeroes @var; ran_discrete_meat($p, $$rdt, $$obj); return $p; } } #line 2790 "RNG.pm" #line 1656 "gsl_random.pd" sub ran_shuffle_vec { my ($obj,@in) = @_; my (@out,$i,$p); $p = long [0..$#in]; $obj->ran_shuffle($p); for($i=0;$iat($i)]=$in[$i]; } return @out; } #line 2807 "RNG.pm" #line 1670 "gsl_random.pd" sub ran_choose_vec { my ($obj,$nout,@in) = @_; my (@out,$i,$pin,$pout); $pin = long [0..$#in]; $pout = long [0..($nout-1)]; $obj->ran_choose($pin,$pout); for($i=0;$i<$nout;$i++) { $out[$i]=$in[$pout->at($i)]; } return @out; } #line 2825 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_ver_meat = \&PDL::GSL::RNG::ran_ver_meat; #line 2831 "RNG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *ran_caos_meat = \&PDL::GSL::RNG::ran_caos_meat; #line 2837 "RNG.pm" #line 1704 "gsl_random.pd" sub ran_ver { my ($obj,$x0,$r,$n) = @_; barf("Not enough parameters for ran_ver!") if $n<=0; my $p = zeroes($n); ran_ver_meat($p,$x0,$r,$n,$$obj); return $p; } #line 2851 "RNG.pm" #line 1714 "gsl_random.pd" sub ran_caos { my ($obj,$m,$n) = @_; barf("Not enough parameters for ran_caos!") if $n<=0; my $p = zeroes($n); ran_caos_meat($p,$m,$n,$$obj); return $p; } #line 2865 "RNG.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSL/INTEG.pm0000644000175000017500000007036214200406312015641 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSL::INTEG; our @EXPORT_OK = qw(gslinteg_qng gslinteg_qag gslinteg_qags gslinteg_qagp gslinteg_qagi gslinteg_qagiu gslinteg_qagil gslinteg_qawc gslinteg_qaws gslinteg_qawo gslinteg_qawf qng_meat qag_meat qags_meat qagp_meat qagi_meat qagiu_meat qagil_meat qawc_meat qaws_meat qawo_meat qawf_meat ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSL::INTEG ; #line 5 "gsl_integ.pd" use strict; use warnings; =head1 NAME PDL::GSL::INTEG - PDL interface to numerical integration routines in GSL =head1 DESCRIPTION This is an interface to the numerical integration package present in the GNU Scientific Library, which is an implementation of QUADPACK. Functions are named B where {algorithm} is the QUADPACK naming convention. The available functions are: =over 3 =item gslinteg_qng: Non-adaptive Gauss-Kronrod integration =item gslinteg_qag: Adaptive integration =item gslinteg_qags: Adaptive integration with singularities =item gslinteg_qagp: Adaptive integration with known singular points =item gslinteg_qagi: Adaptive integration on infinite interval of the form (-\infty,\infty) =item gslinteg_qagiu: Adaptive integration on infinite interval of the form (la,\infty) =item gslinteg_qagil: Adaptive integration on infinite interval of the form (-\infty,lb) =item gslinteg_qawc: Adaptive integration for Cauchy principal values =item gslinteg_qaws: Adaptive integration for singular functions =item gslinteg_qawo: Adaptive integration for oscillatory functions =item gslinteg_qawf: Adaptive integration for Fourier integrals =back Each algorithm computes an approximation to the integral, I, of the function f(x)w(x), where w(x) is a weight function (for general integrands w(x)=1). The user provides absolute and relative error bounds (epsabs,epsrel) which specify the following accuracy requirement: |RESULT - I| <= max(epsabs, epsrel |I|) The routines will fail to converge if the error bounds are too stringent, but always return the best approximation obtained up to that stage All functions return the result, and estimate of the absolute error and an error flag (which is zero if there were no problems). You are responsible for checking for any errors, no warnings are issued unless the option {Warn => 'y'} is specified in which case the reason of failure will be printed. You can nest integrals up to 20 levels. If you find yourself in the unlikely situation that you need more, you can change the value of 'max_nested_integrals' in the first line of the file 'FUNC.c' and recompile. =head1 NOMENCLATURE Throughout this documentation we strive to use the same variables that are present in the original GSL documentation (see L). Oftentimes those variables are called C and C. Since good Perl coding practices discourage the use of Perl variables C<$a> and C<$b>, here we refer to Parameters C and C as C<$pa> and C<$pb>, respectively, and Limits (of domain or integration) as C<$la> and C<$lb>. =for ref Please check the GSL documentation for more information. =head1 SYNOPSIS use PDL; use PDL::GSL::INTEG; my $la = 1.2; my $lb = 3.7; my $epsrel = 0; my $epsabs = 1e-6; # Non adaptive integration my ($res,$abserr,$ierr,$neval) = gslinteg_qng(\&myf,$la,$lb,$epsrel,$epsabs); # Warnings on my ($res,$abserr,$ierr,$neval) = gslinteg_qng(\&myf,$la,$lb,$epsrel,$epsabs,{Warn=>'y'}); # Adaptive integration with warnings on my $limit = 1000; my $key = 5; my ($res,$abserr,$ierr) = gslinteg_qag(\&myf,$la,$lb,$epsrel, $epsabs,$limit,$key,{Warn=>'y'}); sub myf{ my ($x) = @_; return exp(-$x**2); } #line 132 "INTEG.pm" =head1 FUNCTIONS =cut #line 554 "gsl_integ.pd" sub gslinteg_qng{ my ($opt,$warn); if (ref($_[$#_]) eq 'HASH'){ $opt = pop @_; } else{ $opt = {Warn => 'n'}; } if($$opt{Warn}=~/y/i) { $warn = 1;} else {$warn = 0;} my ($f,$la,$lb,$epsabs,$epsrel) = @_; barf 'Usage: gslinteg_qng($function_ref,$la,$lb,$epsabs,$epsrel,[opt]) ' unless ($#_ == 4); my ($res,$abserr,$neval,$ierr) = qng_meat($la,$lb,$epsabs,$epsrel,$warn,$f); return ($res,$abserr,$ierr,$neval); } #line 160 "INTEG.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 qng_meat =for sig Signature: (double a(); double b(); double epsabs(); double epsrel(); double [o] result(); double [o] abserr(); int [o] neval(); int [o] ierr(); int gslwarn(); SV* function) =for ref info not available =for bad qng_meat does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 188 "INTEG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *qng_meat = \&PDL::qng_meat; #line 194 "INTEG.pm" #line 586 "gsl_integ.pd" sub gslinteg_qag{ my ($opt,$warn); if (ref($_[$#_]) eq 'HASH'){ $opt = pop @_; } else{ $opt = {Warn => 'n'}; } if($$opt{Warn}=~/y/i) { $warn = 1;} else {$warn = 0;} my ($f,$la,$lb,$epsabs,$epsrel,$limit,$key) = @_; barf 'Usage: gslinteg_qag($function_ref,$la,$lb,$epsabs,$epsrel,$limit,$key,[opt]) ' unless ($#_ == 6); my ($res,$abserr,$ierr) = qag_meat($la,$lb,$epsabs,$epsrel,$limit,$key,$limit,$warn,$f); return ($res,$abserr,$ierr); } #line 212 "INTEG.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 qag_meat =for sig Signature: (double a(); double b(); double epsabs();double epsrel(); int limit(); int key(); double [o] result(); double [o] abserr();int n();int [o] ierr();int gslwarn();; SV* function) =for ref info not available =for bad qag_meat does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 239 "INTEG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *qag_meat = \&PDL::qag_meat; #line 245 "INTEG.pm" #line 622 "gsl_integ.pd" sub gslinteg_qags{ my ($opt,$warn); if (ref($_[$#_]) eq 'HASH'){ $opt = pop @_; } else{ $opt = {Warn => 'n'}; } if($$opt{Warn}=~/y/i) { $warn = 1;} else {$warn = 0;} my ($f,$la,$lb,$epsabs,$epsrel,$limit) = @_; barf 'Usage: gslinteg_qags($function_ref,$la,$lb,$epsabs,$epsrel,$limit,[opt]) ' unless ($#_ == 5); my ($res,$abserr,$ierr) = qags_meat($la,$lb,$epsabs,$epsrel,$limit,$limit,$warn,$f); return ($res,$abserr,$ierr); } #line 263 "INTEG.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 qags_meat =for sig Signature: (double a(); double b(); double epsabs();double epsrel(); int limit(); double [o] result(); double [o] abserr();int n();int [o] ierr();int gslwarn();; SV* function) =for ref info not available =for bad qags_meat does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 290 "INTEG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *qags_meat = \&PDL::qags_meat; #line 296 "INTEG.pm" #line 657 "gsl_integ.pd" sub gslinteg_qagp{ my ($opt,$warn); if (ref($_[$#_]) eq 'HASH'){ $opt = pop @_; } else{ $opt = {Warn => 'n'}; } if($$opt{Warn}=~/y/i) { $warn = 1;} else {$warn = 0;} my ($f,$points,$epsabs,$epsrel,$limit) = @_; barf 'Usage: gslinteg_qagp($function_ref,$points,$epsabs,$epsrel,$limit,[opt]) ' unless ($#_ == 4); my ($res,$abserr,$ierr) = qagp_meat($points,$epsabs,$epsrel,$limit,$limit,$warn,$f); return ($res,$abserr,$ierr); } #line 314 "INTEG.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 qagp_meat =for sig Signature: (double pts(l); double epsabs();double epsrel();int limit(); double [o] result(); double [o] abserr();int n();int [o] ierr();int gslwarn();; SV* function) =for ref info not available =for bad qagp_meat does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 341 "INTEG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *qagp_meat = \&PDL::qagp_meat; #line 347 "INTEG.pm" #line 691 "gsl_integ.pd" sub gslinteg_qagi{ my ($opt,$warn); if (ref($_[$#_]) eq 'HASH'){ $opt = pop @_; } else{ $opt = {Warn => 'n'}; } if($$opt{Warn}=~/y/i) { $warn = 1;} else {$warn = 0;} my ($f,$epsabs,$epsrel,$limit) = @_; barf 'Usage: gslinteg_qagi($function_ref,$epsabs,$epsrel,$limit,[opt]) ' unless ($#_ == 3); my ($res,$abserr,$ierr) = qagi_meat($epsabs,$epsrel,$limit,$limit,$warn,$f); return ($res,$abserr,$ierr); } #line 365 "INTEG.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 qagi_meat =for sig Signature: (double epsabs();double epsrel(); int limit(); double [o] result(); double [o] abserr(); int n(); int [o] ierr();int gslwarn();; SV* function) =for ref info not available =for bad qagi_meat does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 392 "INTEG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *qagi_meat = \&PDL::qagi_meat; #line 398 "INTEG.pm" #line 725 "gsl_integ.pd" sub gslinteg_qagiu{ my ($opt,$warn); if (ref($_[$#_]) eq 'HASH'){ $opt = pop @_; } else{ $opt = {Warn => 'n'}; } if($$opt{Warn}=~/y/i) { $warn = 1;} else {$warn = 0;} my ($f,$la,$epsabs,$epsrel,$limit) = @_; barf 'Usage: gslinteg_qagiu($function_ref,$la,$epsabs,$epsrel,$limit,[opt]) ' unless ($#_ == 4); my ($res,$abserr,$ierr) = qagiu_meat($la,$epsabs,$epsrel,$limit,$limit,$warn,$f); return ($res,$abserr,$ierr); } #line 416 "INTEG.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 qagiu_meat =for sig Signature: (double a(); double epsabs();double epsrel();int limit(); double [o] result(); double [o] abserr();int n();int [o] ierr();int gslwarn();; SV* function) =for ref info not available =for bad qagiu_meat does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 443 "INTEG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *qagiu_meat = \&PDL::qagiu_meat; #line 449 "INTEG.pm" #line 760 "gsl_integ.pd" sub gslinteg_qagil{ my ($opt,$warn); if (ref($_[$#_]) eq 'HASH'){ $opt = pop @_; } else{ $opt = {Warn => 'n'}; } if($$opt{Warn}=~/y/i) { $warn = 1;} else {$warn = 0;} my ($f,$lb,$epsabs,$epsrel,$limit) = @_; barf 'Usage: gslinteg_qagil($function_ref,$lb,$epsabs,$epsrel,$limit,[opt]) ' unless ($#_ == 4); my ($res,$abserr,$ierr) = qagil_meat($lb,$epsabs,$epsrel,$limit,$limit,$warn,$f); return ($res,$abserr,$ierr); } #line 467 "INTEG.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 qagil_meat =for sig Signature: (double b(); double epsabs();double epsrel();int limit(); double [o] result(); double [o] abserr();int n();int [o] ierr();int gslwarn();; SV* function) =for ref info not available =for bad qagil_meat does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 494 "INTEG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *qagil_meat = \&PDL::qagil_meat; #line 500 "INTEG.pm" #line 795 "gsl_integ.pd" sub gslinteg_qawc{ my ($opt,$warn); if (ref($_[$#_]) eq 'HASH'){ $opt = pop @_; } else{ $opt = {Warn => 'n'}; } if($$opt{Warn}=~/y/i) { $warn = 1;} else {$warn = 0;} my ($f,$la,$lb,$c,$epsabs,$epsrel,$limit) = @_; barf 'Usage: gslinteg_qawc($function_ref,$la,$lb,$c,$epsabs,$epsrel,$limit,[opt]) ' unless ($#_ == 6); my ($res,$abserr,$ierr) = qawc_meat($la,$lb,$c,$epsabs,$epsrel,$limit,$limit,$warn,$f); return ($res,$abserr,$ierr); } #line 518 "INTEG.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 qawc_meat =for sig Signature: (double a(); double b(); double c(); double epsabs();double epsrel();int limit(); double [o] result(); double [o] abserr();int n();int [o] ierr();int gslwarn();; SV* function) =for ref info not available =for bad qawc_meat does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 545 "INTEG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *qawc_meat = \&PDL::qawc_meat; #line 551 "INTEG.pm" #line 829 "gsl_integ.pd" sub gslinteg_qaws{ my ($opt,$warn); if (ref($_[$#_]) eq 'HASH'){ $opt = pop @_; } else{ $opt = {Warn => 'n'}; } if($$opt{Warn}=~/y/i) { $warn = 1;} else {$warn = 0;} my ($f,$alpha,$beta,$mu,$nu,$la,$lb,$epsabs,$epsrel,$limit) = @_; barf 'Usage: gslinteg_qaws($function_ref,$alpha,$beta,$mu,$nu,$la,$lb,$epsabs,$epsrel,$limit,[opt]) ' unless ($#_ == 9); my ($res,$abserr,$ierr) = qaws_meat($la,$lb,$epsabs,$epsrel,$limit,$limit,$alpha,$beta,$mu,$nu,$warn,$f); return ($res,$abserr,$ierr); } #line 569 "INTEG.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 qaws_meat =for sig Signature: (double a(); double b();double epsabs();double epsrel();int limit(); double [o] result(); double [o] abserr();int n(); double alpha(); double beta(); int mu(); int nu();int [o] ierr();int gslwarn();; SV* function) =for ref info not available =for bad qaws_meat does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 597 "INTEG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *qaws_meat = \&PDL::qaws_meat; #line 603 "INTEG.pm" #line 869 "gsl_integ.pd" sub gslinteg_qawo{ my ($opt,$warn); if (ref($_[$#_]) eq 'HASH'){ $opt = pop @_; } else{ $opt = {Warn => 'n'}; } if($$opt{Warn}=~/y/i) { $warn = 1;} else {$warn = 0;} my ($f,$omega,$sincosopt,$la,$lb,$epsabs,$epsrel,$limit) = @_; barf 'Usage: gslinteg_qawo($function_ref,$omega,$sin_or_cos,$la,$lb,$epsabs,$epsrel,$limit,[opt]) ' unless ($#_ == 7); my $OPTION_SIN_COS; if($sincosopt=~/cos/i){ $OPTION_SIN_COS = 0;} elsif($sincosopt=~/sin/i){ $OPTION_SIN_COS = 1;} else { barf("Error in argument 3 of function gslinteg_qawo: specify 'cos' or 'sin'\n");} my $L = $lb - $la; my $nlevels = $limit; my ($res,$abserr,$ierr) = qawo_meat($la,$lb,$epsabs,$epsrel,$limit,$limit,$OPTION_SIN_COS,$omega,$L,$nlevels,$warn,$f); return ($res,$abserr,$ierr); } #line 628 "INTEG.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 qawo_meat =for sig Signature: (double a(); double b();double epsabs();double epsrel();int limit(); double [o] result(); double [o] abserr();int n(); int sincosopt(); double omega(); double L(); int nlevels();int [o] ierr();int gslwarn();; SV* function) =for ref info not available =for bad qawo_meat does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 656 "INTEG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *qawo_meat = \&PDL::qawo_meat; #line 662 "INTEG.pm" #line 920 "gsl_integ.pd" sub gslinteg_qawf{ my ($opt,$warn); if (ref($_[$#_]) eq 'HASH'){ $opt = pop @_; } else{ $opt = {Warn => 'n'}; } if($$opt{Warn}=~/y/i) { $warn = 1;} else {$warn = 0;} my ($f,$omega,$sincosopt,$la,$epsabs,$limit) = @_; barf 'Usage: gslinteg_qawf($function_ref,$omega,$sin_or_cos,$la,$epsabs,$limit,[opt]) ' unless ($#_ == 5); my $OPTION_SIN_COS; if($sincosopt=~/cos/i){ $OPTION_SIN_COS = 0;} elsif($sincosopt=~/sin/i){ $OPTION_SIN_COS = 1;} else { barf("Error in argument 3 of function gslinteg_qawf: specify 'cos' or 'sin'\n");} my $nlevels = $limit; my ($res,$abserr,$ierr) = qawf_meat($la,$epsabs,$limit,$limit,$OPTION_SIN_COS,$omega,$nlevels,$warn,$f); return ($res,$abserr,$ierr); } #line 685 "INTEG.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 qawf_meat =for sig Signature: (double a(); double epsabs();int limit(); double [o] result(); double [o] abserr();int n(); int sincosopt(); double omega(); int nlevels();int [o] ierr();int gslwarn();; SV* function) =for ref info not available =for bad qawf_meat does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 713 "INTEG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *qawf_meat = \&PDL::qawf_meat; #line 719 "INTEG.pm" #line 113 "gsl_integ.pd" =head2 gslinteg_qng - Non-adaptive Gauss-Kronrod integration This function applies the Gauss-Kronrod 10-point, 21-point, 43-point and 87-point integration rules in succession until an estimate of the integral of f over ($la,$lb) is achieved within the desired absolute and relative error limits, $epsabs and $epsrel. It is meant for fast integration of smooth functions. It returns an array with the result, an estimate of the absolute error, an error flag and the number of function evaluations performed. =for usage Usage: ($res,$abserr,$ierr,$neval) = gslinteg_qng($function_ref,$la,$lb, $epsrel,$epsabs,[{Warn => $warn}]); =for example Example: my ($res,$abserr,$ierr,$neval) = gslinteg_qng(\&f,0,1,0,1e-9); # with warnings on my ($res,$abserr,$ierr,$neval) = gslinteg_qng(\&f,0,1,0,1e-9,{Warn => 'y'}); sub f{ my ($x) = @_; return ($x**2.6)*log(1.0/$x); } =head2 gslinteg_qag - Adaptive integration This function applies an integration rule adaptively until an estimate of the integral of f over ($la,$lb) is achieved within the desired absolute and relative error limits, $epsabs and $epsrel. On each iteration the adaptive integration strategy bisects the interval with the largest error estimate; the maximum number of allowed subdivisions is given by the parameter $limit. The integration rule is determined by the value of $key, which has to be one of (1,2,3,4,5,6) and correspond to the 15, 21, 31, 41, 51 and 61 point Gauss-Kronrod rules respectively. It returns an array with the result, an estimate of the absolute error and an error flag. =for ref Please check the GSL documentation for more information. =for usage Usage: ($res,$abserr,$ierr) = gslinteg_qag($function_ref,$la,$lb,$epsrel, $epsabs,$limit,$key,[{Warn => $warn}]); =for example Example: my ($res,$abserr,$ierr) = gslinteg_qag(\&f,0,1,0,1e-10,1000,1); # with warnings on my ($res,$abserr,$ierr) = gslinteg_qag(\&f,0,1,0,1e-10,1000,1,{Warn => 'y'}); sub f{ my ($x) = @_; return ($x**2.6)*log(1.0/$x); } =head2 gslinteg_qags - Adaptive integration with singularities This function applies the Gauss-Kronrod 21-point integration rule adaptively until an estimate of the integral of f over ($la,$lb) is achieved within the desired absolute and relative error limits, $epsabs and $epsrel. The algorithm is such that it accelerates the convergence of the integral in the presence of discontinuities and integrable singularities. The maximum number of allowed subdivisions done by the adaptive algorithm must be supplied in the parameter $limit. =for ref Please check the GSL documentation for more information. =for usage Usage: ($res,$abserr,$ierr) = gslinteg_qags($function_ref,$la,$lb,$epsrel, $epsabs,$limit,[{Warn => $warn}]); =for example Example: my ($res,$abserr,$ierr) = gslinteg_qags(\&f,0,1,0,1e-10,1000); # with warnings on ($res,$abserr,$ierr) = gslinteg_qags(\&f,0,1,0,1e-10,1000,{Warn => 'y'}); sub f{ my ($x) = @_; return ($x)*log(1.0/$x); } =head2 gslinteg_qagp - Adaptive integration with known singular points This function applies the adaptive integration algorithm used by gslinteg_qags taking into account the location of singular points until an estimate of the integral of f over ($la,$lb) is achieved within the desired absolute and relative error limits, $epsabs and $epsrel. Singular points are supplied in the ndarray $points, whose endpoints determine the integration range. So, for example, if the function has singular points at x_1 and x_2 and the integral is desired from a to b (a < x_1 < x_2 < b), $points = pdl(a,x_1,x_2,b). The maximum number of allowed subdivisions done by the adaptive algorithm must be supplied in the parameter $limit. =for ref Please check the GSL documentation for more information. =for usage Usage: ($res,$abserr,$ierr) = gslinteg_qagp($function_ref,$points,$epsabs, $epsrel,$limit,[{Warn => $warn}]) =for example Example: my $points = pdl(0,1,sqrt(2),3); my ($res,$abserr,$ierr) = gslinteg_qagp(\&f,$points,0,1e-3,1000); # with warnings on ($res,$abserr,$ierr) = gslinteg_qagp(\&f,$points,0,1e-3,1000,{Warn => 'y'}); sub f{ my ($x) = @_; my $x2 = $x**2; my $x3 = $x**3; return $x3 * log(abs(($x2-1.0)*($x2-2.0))); } =head2 gslinteg_qagi - Adaptive integration on infinite interval This function estimates the integral of the function f over the infinite interval (-\infty,+\infty) within the desired absolute and relative error limits, $epsabs and $epsrel. After a transformation, the algorithm of gslinteg_qags with a 15-point Gauss-Kronrod rule is used. The maximum number of allowed subdivisions done by the adaptive algorithm must be supplied in the parameter $limit. =for ref Please check the GSL documentation for more information. =for usage Usage: ($res,$abserr,$ierr) = gslinteg_qagi($function_ref,$epsabs, $epsrel,$limit,[{Warn => $warn}]); =for example Example: my ($res,$abserr,$ierr) = gslinteg_qagi(\&myfn,1e-7,0,1000); # with warnings on ($res,$abserr,$ierr) = gslinteg_qagi(\&myfn,1e-7,0,1000,{Warn => 'y'}); sub myfn{ my ($x) = @_; return exp(-$x - $x*$x) ; } =head2 gslinteg_qagiu - Adaptive integration on infinite interval This function estimates the integral of the function f over the infinite interval (la,+\infty) within the desired absolute and relative error limits, $epsabs and $epsrel. After a transformation, the algorithm of gslinteg_qags with a 15-point Gauss-Kronrod rule is used. The maximum number of allowed subdivisions done by the adaptive algorithm must be supplied in the parameter $limit. =for ref Please check the GSL documentation for more information. =for usage Usage: ($res,$abserr,$ierr) = gslinteg_qagiu($function_ref,$la,$epsabs, $epsrel,$limit,[{Warn => $warn}]); =for example Example: my $alfa = 1; my ($res,$abserr,$ierr) = gslinteg_qagiu(\&f,99.9,1e-7,0,1000); # with warnings on ($res,$abserr,$ierr) = gslinteg_qagiu(\&f,99.9,1e-7,0,1000,{Warn => 'y'}); sub f{ my ($x) = @_; if (($x==0) && ($alfa == 1)) {return 1;} if (($x==0) && ($alfa > 1)) {return 0;} return ($x**($alfa-1))/((1+10*$x)**2); } =head2 gslinteg_qagil - Adaptive integration on infinite interval This function estimates the integral of the function f over the infinite interval (-\infty,lb) within the desired absolute and relative error limits, $epsabs and $epsrel. After a transformation, the algorithm of gslinteg_qags with a 15-point Gauss-Kronrod rule is used. The maximum number of allowed subdivisions done by the adaptive algorithm must be supplied in the parameter $limit. =for ref Please check the GSL documentation for more information. =for usage Usage: ($res,$abserr,$ierr) = gslinteg_qagl($function_ref,$lb,$epsabs, $epsrel,$limit,[{Warn => $warn}]); =for example Example: my ($res,$abserr,$ierr) = gslinteg_qagil(\&myfn,1.0,1e-7,0,1000); # with warnings on ($res,$abserr,$ierr) = gslinteg_qagil(\&myfn,1.0,1e-7,0,1000,{Warn => 'y'}); sub myfn{ my ($x) = @_; return exp($x); } =head2 gslinteg_qawc - Adaptive integration for Cauchy principal values This function computes the Cauchy principal value of the integral of f over (la,lb), with a singularity at c, I = \int_{la}^{lb} dx f(x)/(x - c). The integral is estimated within the desired absolute and relative error limits, $epsabs and $epsrel. The maximum number of allowed subdivisions done by the adaptive algorithm must be supplied in the parameter $limit. =for ref Please check the GSL documentation for more information. =for usage Usage: ($res,$abserr,$ierr) = gslinteg_qawc($function_ref,$la,$lb,$c,$epsabs,$epsrel,$limit) =for example Example: my ($res,$abserr,$ierr) = gslinteg_qawc(\&f,-1,5,0,0,1e-3,1000); # with warnings on ($res,$abserr,$ierr) = gslinteg_qawc(\&f,-1,5,0,0,1e-3,1000,{Warn => 'y'}); sub f{ my ($x) = @_; return 1.0 / (5.0 * $x * $x * $x + 6.0) ; } =head2 gslinteg_qaws - Adaptive integration for singular functions The algorithm in gslinteg_qaws is designed for integrands with algebraic-logarithmic singularities at the end-points of an integration region. Specifically, this function computes the integral given by I = \int_{la}^{lb} dx f(x) (x-la)^alpha (lb-x)^beta log^mu (x-la) log^nu (lb-x). The integral is estimated within the desired absolute and relative error limits, $epsabs and $epsrel. The maximum number of allowed subdivisions done by the adaptive algorithm must be supplied in the parameter $limit. =for ref Please check the GSL documentation for more information. =for usage Usage: ($res,$abserr,$ierr) = gslinteg_qawc($function_ref,$alpha,$beta,$mu,$nu,$la,$lb, $epsabs,$epsrel,$limit,[{Warn => $warn}]); =for example Example: my ($res,$abserr,$ierr) = gslinteg_qaws(\&f,0,0,1,0,0,1,0,1e-7,1000); # with warnings on ($res,$abserr,$ierr) = gslinteg_qaws(\&f,0,0,1,0,0,1,0,1e-7,1000,{Warn => 'y'}); sub f{ my ($x) = @_; if($x==0){return 0;} else{ my $u = log($x); my $v = 1 + $u*$u; return 1.0/($v*$v); } } =head2 gslinteg_qawo - Adaptive integration for oscillatory functions This function uses an adaptive algorithm to compute the integral of f over (la,lb) with the weight function sin(omega*x) or cos(omega*x) -- which of sine or cosine is used is determined by the parameter $opt ('cos' or 'sin'). The integral is estimated within the desired absolute and relative error limits, $epsabs and $epsrel. The maximum number of allowed subdivisions done by the adaptive algorithm must be supplied in the parameter $limit. =for ref Please check the GSL documentation for more information. =for usage Usage: ($res,$abserr,$ierr) = gslinteg_qawo($function_ref,$omega,$sin_or_cos, $la,$lb,$epsabs,$epsrel,$limit,[opt]) =for example Example: my $PI = 3.14159265358979323846264338328; my ($res,$abserr,$ierr) = PDL::GSL::INTEG::gslinteg_qawo(\&f,10*$PI,'sin',0,1,0,1e-7,1000); # with warnings on ($res,$abserr,$ierr) = PDL::GSL::INTEG::gslinteg_qawo(\&f,10*$PI,'sin',0,1,0,1e-7,1000,{Warn => 'y'}); sub f{ my ($x) = @_; if($x==0){return 0;} else{ return log($x);} } =head2 gslinteg_qawf - Adaptive integration for Fourier integrals This function attempts to compute a Fourier integral of the function f over the semi-infinite interval [la,+\infty). Specifically, it attempts tp compute I = \int_{la}^{+\infty} dx f(x)w(x), where w(x) is sin(omega*x) or cos(omega*x) -- which of sine or cosine is used is determined by the parameter $opt ('cos' or 'sin'). The integral is estimated within the desired absolute error limit $epsabs. The maximum number of allowed subdivisions done by the adaptive algorithm must be supplied in the parameter $limit. =for ref Please check the GSL documentation for more information. =for usage Usage: gslinteg_qawf($function_ref,$omega,$sin_or_cos,$la,$epsabs,$limit,[opt]) =for example Example: my ($res,$abserr,$ierr) = gslinteg_qawf(\&f,$PI/2.0,'cos',0,1e-7,1000); # with warnings on ($res,$abserr,$ierr) = gslinteg_qawf(\&f,$PI/2.0,'cos',0,1e-7,1000,{Warn => 'y'}); sub f{ my ($x) = @_; if ($x == 0){return 0;} return 1.0/sqrt($x) } =head1 BUGS Feedback is welcome. Log bugs in the PDL bug database (the database is always linked from L). =head1 SEE ALSO L The GSL documentation for numerical integration is online at L =head1 AUTHOR This file copyright (C) 2003,2005 Andres Jordan 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. The GSL integration routines were written by Brian Gough. QUADPACK was written by Piessens, Doncker-Kapenga, Uberhuber and Kahaner. =cut #line 1145 "INTEG.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSL/MROOT.pm0000644000175000017500000000575214200406312015674 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSL::MROOT; our @EXPORT_OK = qw(gslmroot_fsolver gslmroot_fsolver ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSL::MROOT ; #line 69 "gsl_mroot.pd" use strict; use warnings; =head1 NAME PDL::GSL::MROOT - PDL interface to multidimensional root-finding routines in GSL =head1 DESCRIPTION This is an interface to the multidimensional root-finding package present in the GNU Scientific Library. At the moment there is a single function B which provides an interface to the algorithms in the GSL library that do not use derivatives. =head1 SYNOPSIS use PDL; use PDL::GSL::MROOT; my $init = pdl (-10.00, -5.0); my $epsabs = 1e-7; $res = gslmroot_fsolver($init, \&rosenbrock, {Method => 0, EpsAbs => $epsabs}); sub rosenbrock{ my ($x) = @_; my $c = 1; my $d = 10; my $y = zeroes($x); my $y0 = $y->slice(0); $y0 .= $c * (1 - $x->slice(0)); my $y1 = $y->slice(1); $y1 .= $d * ($x->slice(1) - $x->slice(0)**2); return $y; } #line 69 "MROOT.pm" =head1 FUNCTIONS =cut #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gslmroot_fsolver =for sig Signature: (double [io]xfree(n); double epsabs(); int method(); SV* function1) =for ref info not available =for bad gslmroot_fsolver does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 105 "MROOT.pm" #line 1060 "../../../blib/lib/PDL/PP.pm" sub gslmroot_fsolver { my ($x, $f_vect) = @_; my $opt = ref($_[-1]) eq 'HASH' ? pop @_ : {Method => 0, EpsAbs => 1e-3}; if( (ref($x) ne 'PDL')){ barf("Have to pass ndarray as first argument to fsolver\n"); } my $res = $x->copy; _gslmroot_fsolver_int($res, $$opt{'EpsAbs'}, $$opt{'Method'}, $f_vect); return $res; } #line 120 "MROOT.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gslmroot_fsolver = \&PDL::GSL::MROOT::gslmroot_fsolver; #line 126 "MROOT.pm" #line 115 "gsl_mroot.pd" =head1 SEE ALSO L The GSL documentation is online at http://www.gnu.org/software/gsl/manual/ =head1 AUTHOR This file copyright (C) 2006 Andres Jordan and Simon Casassus 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 #line 151 "MROOT.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSL/DIFF.pm0000644000175000017500000001203014200406312015467 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSL::DIFF; our @EXPORT_OK = qw(gsldiff diff_central diff_backward diff_forward ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSL::DIFF ; #line 5 "gsl_diff.pd" use strict; use warnings; =head1 NAME PDL::GSL::DIFF - PDL interface to numerical differentiation routines in GSL =head1 DESCRIPTION This is an interface to the numerical differentiation package present in the GNU Scientific Library. =head1 SYNOPSIS use PDL; use PDL::GSL::DIFF; my $x0 = 3.3; my @res = gsldiff(\&myfunction,$x0); # same as above: @res = gsldiff(\&myfunction,$x0,{Method => 'central'}); # use only values greater than $x0 to get the derivative @res = gsldiff(\&myfunction,$x0,{Method => 'forward'}); # use only values smaller than $x0 to get the derivative @res = gsldiff(\&myfunction,$x0,{Method => 'backward'}); sub myfunction{ my ($x) = @_; return $x**2; } #line 60 "DIFF.pm" =head1 FUNCTIONS =cut #line 120 "gsl_diff.pd" sub gsldiff{ my $opt; if (ref($_[$#_]) eq 'HASH'){ $opt = pop @_; } else{ $opt = {Method => 'central'}; } die 'Usage: gsldiff(function_ref, x, {Options} )' if $#_<1 || $#_>2; my ($f,$x) = @_; my ($res,$abserr); if($$opt{Method}=~/cent/i){ ($res,$abserr) = PDL::GSL::DIFF::diff_central($x,$f); } elsif($$opt{Method}=~/back/i){ ($res,$abserr) = PDL::GSL::DIFF::diff_backward($x,$f); } elsif($$opt{Method}=~/forw/i){ ($res,$abserr) = PDL::GSL::DIFF::diff_forward($x,$f); } else{ barf("Unknown differentiation method $$opt{Method} in gsldiff\n"); } return ($res,$abserr); } #line 98 "DIFF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 diff_central =for sig Signature: (double x(); double [o] res(); double [o] abserr(); SV* function) =for ref info not available =for bad diff_central does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 124 "DIFF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *diff_central = \&PDL::diff_central; #line 130 "DIFF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 diff_backward =for sig Signature: (double x(); double [o] res(); double [o] abserr(); SV* function) =for ref info not available =for bad diff_backward does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 156 "DIFF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *diff_backward = \&PDL::diff_backward; #line 162 "DIFF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 diff_forward =for sig Signature: (double x(); double [o] res(); double [o] abserr(); SV* function) =for ref info not available =for bad diff_forward does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 188 "DIFF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *diff_forward = \&PDL::diff_forward; #line 194 "DIFF.pm" #line 42 "gsl_diff.pd" =head2 gsldiff =for ref This functions serves as an interface to the three differentiation functions present in GSL: gsl_diff_central, gsl_diff_backward and gsl_diff_forward. To compute the derivative, the central method uses values greater and smaller than the point at which the derivative is to be evaluated, while backward and forward use only values smaller and greater respectively. gsldiff() returns both the derivative and an absolute error estimate. The default method is 'central', others can be specified by passing an option. Please check the GSL documentation for more information. =for usage Usage: ($d,$abserr) = gsldiff($function_ref,$x,{Method => $method}); =for example Example: #derivative using default method ('central') ($d,$abserr) = gsldiff(\&myf,3.3); #same as above with method set explicitly ($d,$abserr) = gsldiff(\&myf,3.3,{Method => 'central'}); #using backward & forward methods ($d,$abserr) = gsldiff(\&myf,3.3,{Method => 'backward'}); ($d,$abserr) = gsldiff(\&myf,3.3,{Method => 'forward'}); sub myf{ my ($x) = @_; return exp($x); } =head1 BUGS Feedback is welcome. Log bugs in the PDL bug database (the database is always linked from L). =head1 SEE ALSO L The GSL documentation is online at http://www.gnu.org/software/gsl/manual/ =head1 AUTHOR This file copyright (C) 2003 Andres Jordan 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. The GSL differentiation routines were written by David Morrison. =cut #line 265 "DIFF.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSL/INTERP.pm0000644000175000017500000001726214200406312015774 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSL::INTERP; our @EXPORT_OK = qw( ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSL::INTERP ; #line 7 "gsl_interp.pd" use strict; use warnings; =head1 NAME PDL::GSL::INTERP - PDL interface to Interpolation routines in GSL =head1 DESCRIPTION This is an interface to the interpolation package present in the GNU Scientific Library. =head1 SYNOPSIS use PDL; use PDL::GSL::INTERP; my $x = sequence(10); my $y = exp($x); my $spl = PDL::GSL::INTERP->init('cspline',$x,$y); my $res = $spl->eval(4.35); $res = $spl->deriv(4.35); $res = $spl->deriv2(4.35); $res = $spl->integ(2.1,7.4); =head1 NOMENCLATURE Throughout this documentation we strive to use the same variables that are present in the original GSL documentation (see L). Oftentimes those variables are called C and C. Since good Perl coding practices discourage the use of Perl variables C<$a> and C<$b>, here we refer to Parameters C and C as C<$pa> and C<$pb>, respectively, and Limits (of domain or integration) as C<$la> and C<$lb>. #line 62 "INTERP.pm" =head1 FUNCTIONS =cut #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 init =for sig Signature: (double x(n); double y(n); gsl_spline *spl) =for ref The init method initializes a new instance of INTERP. It needs as input an interpolation type and two ndarrays holding the x and y values to be interpolated. The GSL routines require that x be monotonically increasing and a quicksort is performed by default to ensure that. You can skip the quicksort by passing the option {Sort => 0}. The available interpolation types are : =over 2 =item linear =item polynomial =item cspline (natural cubic spline) =item cspline_periodic (periodic cubic spline) =item akima (natural akima spline) =item akima_periodic (periodic akima spline) =back Please check the GSL documentation for more information. =for usage Usage: $blessed_ref = PDL::GSL::INTERP->init($interp_method,$x,$y,$opt); =for example Example: $x = sequence(10); $y = exp($x); $spl = PDL::GSL::INTERP->init('cspline',$x,$y) $spl = PDL::GSL::INTERP->init('cspline',$x,$y,{Sort => 1}) #same as above # no sorting done on x, user is certain that x is monotonically increasing $spl = PDL::GSL::INTERP->init('cspline',$x,$y,{Sort => 0}); =for bad init does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 141 "INTERP.pm" #line 1060 "../../../blib/lib/PDL/PP.pm" sub init { my $opt; if (ref($_[$#_]) eq 'HASH'){ $opt = pop @_; } else{ $opt = {Sort => 1}; } my ($class,$type,$x,$y) = @_; if( (ref($x) ne 'PDL') || (ref($y) ne 'PDL') ){ barf("Have to pass ndarrays as arguments to init method\n"); } if($$opt{Sort} != 0){ my $idx = PDL::Ufunc::qsorti($x); $x = $x->index($idx); $y = $y->index($idx); } my $ene = nelem($x); my $obj1 = new_spline($type,$ene); my $obj2 = new_accel(); _init_int($x,$y,$$obj1); my @ret_a = ($obj1,$obj2); return bless(\@ret_a, $class); } #line 166 "INTERP.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *init = \&PDL::GSL::INTERP::init; #line 172 "INTERP.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 eval =for sig Signature: (double x(); double [o] out(); gsl_spline *spl;gsl_interp_accel *acc) =for ref The function eval returns the interpolating function at a given point. It will barf with an "input domain error" if you try to extrapolate. =for usage Usage: $result = $spl->eval($points); =for example Example: my $res = $spl->eval($x) =for bad eval processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 211 "INTERP.pm" #line 1060 "../../../blib/lib/PDL/PP.pm" sub eval { my $opt; my ($obj,$x) = @_; my $s_obj = $$obj[0]; my $a_obj = $$obj[1]; _eval_int($x,my $o=PDL->null,$$s_obj,$$a_obj); $o; } #line 224 "INTERP.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *eval = \&PDL::GSL::INTERP::eval; #line 230 "INTERP.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 deriv =for sig Signature: (double x(); double [o] out(); gsl_spline *spl;gsl_interp_accel *acc) =for ref The deriv function returns the derivative of the interpolating function at a given point. It will barf with an "input domain error" if you try to extrapolate. =for usage Usage: $result = $spl->deriv($points); =for example Example: my $res = $spl->deriv($x) =for bad deriv does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 270 "INTERP.pm" #line 1060 "../../../blib/lib/PDL/PP.pm" sub deriv { my ($obj,$x) = @_; my $s_obj = $$obj[0]; my $a_obj = $$obj[1]; _deriv_int($x,my $o=PDL->null,$$s_obj,$$a_obj); $o; } #line 282 "INTERP.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *deriv = \&PDL::GSL::INTERP::deriv; #line 288 "INTERP.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 deriv2 =for sig Signature: (double x(); double [o] out(); gsl_spline *spl;gsl_interp_accel *acc) =for ref The deriv2 function returns the second derivative of the interpolating function at a given point. It will barf with an "input domain error" if you try to extrapolate. =for usage Usage: $result = $spl->deriv2($points); =for example Example: my $res = $spl->deriv2($x) =for bad deriv2 does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 328 "INTERP.pm" #line 1060 "../../../blib/lib/PDL/PP.pm" sub deriv2 { my ($obj,$x) = @_; my $s_obj = $$obj[0]; my $a_obj = $$obj[1]; _deriv2_int($x,my $o=PDL->null,$$s_obj,$$a_obj); $o; } #line 340 "INTERP.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *deriv2 = \&PDL::GSL::INTERP::deriv2; #line 346 "INTERP.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 integ =for sig Signature: (double a(); double b(); double [o] out(); gsl_spline *spl;gsl_interp_accel *acc) =for ref The integ function returns the integral of the interpolating function between two points. It will barf with an "input domain error" if you try to extrapolate. =for usage Usage: $result = $spl->integ($la,$lb); =for example Example: my $res = $spl->integ($la,$lb) =for bad integ does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 386 "INTERP.pm" #line 1060 "../../../blib/lib/PDL/PP.pm" sub integ { my ($obj,$la,$lb) = @_; my $s_obj = $$obj[0]; my $a_obj = $$obj[1]; _integ_int($la,$lb,my $o=PDL->null,$$s_obj,$$a_obj); $o; } #line 398 "INTERP.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *integ = \&PDL::GSL::INTERP::integ; #line 404 "INTERP.pm" #line 46 "gsl_interp.pd" =head1 BUGS Feedback is welcome. =head1 SEE ALSO L The GSL documentation for interpolation is online at L =head1 AUTHOR This file copyright (C) 2003 Andres Jordan 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. The GSL interpolation module was written by Gerard Jungman. =cut #line 433 "INTERP.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSL/LINALG.pm0000644000175000017500000000722014200406312015732 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSL::LINALG; our @EXPORT_OK = qw(LU_decomp LU_solve LU_det solve_tridiag ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSL::LINALG ; #line 5 "gsl_linalg.pd" use strict; use warnings; =head1 NAME PDL::GSL::LINALG - PDL interface to linear algebra routines in GSL =head1 SYNOPSIS use PDL::LiteF; use PDL::MatrixOps; # for 'x' use PDL::GSL::LINALG; my $A = pdl [ [0.18, 0.60, 0.57, 0.96], [0.41, 0.24, 0.99, 0.58], [0.14, 0.30, 0.97, 0.66], [0.51, 0.13, 0.19, 0.85], ]; my $B = sequence(2,4); # column vectors LU_decomp(my $lu=$A->copy, my $p=null, my $signum=null); # transpose so first dim means is vector, higher dims thread LU_solve($lu, $p, $B->transpose, my $x=null); $x = $x->inplace->transpose; # now can be matrix-multiplied =head1 DESCRIPTION This is an interface to the linear algebra package present in the GNU Scientific Library. Functions are named as in GSL, but with the initial C removed. They are provided in both real and complex double precision. Currently only LU decomposition interfaces here. Pull requests welcome! #line 58 "LINALG.pm" =head1 FUNCTIONS =cut #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 LU_decomp =for sig Signature: ([io,phys]A(n,m); indx [o,phys]ipiv(p); int [o,phys]signum()) =for ref LU decomposition of the given (real or complex) matrix. =for bad LU_decomp ignores the bad-value flag of the input ndarrays. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 94 "LINALG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *LU_decomp = \&PDL::LU_decomp; #line 100 "LINALG.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 LU_solve =for sig Signature: ([phys]LU(n,m); indx [phys]ipiv(p); [phys]B(n); [o,phys]x(n)) =for ref Solve C using the LU and permutation from L, real or complex. =for bad LU_solve ignores the bad-value flag of the input ndarrays. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 127 "LINALG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *LU_solve = \&PDL::LU_solve; #line 133 "LINALG.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 LU_det =for sig Signature: ([phys]LU(n,m); int [phys]signum(); [o]det()) =for ref Find the determinant from the LU decomp. =for bad LU_det ignores the bad-value flag of the input ndarrays. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 159 "LINALG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *LU_det = \&PDL::LU_det; #line 165 "LINALG.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 solve_tridiag =for sig Signature: ([phys]diag(n); [phys]superdiag(n); [phys]subdiag(n); [phys]B(n); [o,phys]x(n)) =for ref Solve C where A is a tridiagonal system. Real only, because GSL does not have a complex function. =for bad solve_tridiag ignores the bad-value flag of the input ndarrays. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 192 "LINALG.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *solve_tridiag = \&PDL::solve_tridiag; #line 198 "LINALG.pm" #line 41 "gsl_linalg.pd" =head1 SEE ALSO L The GSL documentation for linear algebra is online at L =cut #line 213 "LINALG.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/GSL/CDF.pm0000644000175000017500000014075214200406311015367 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::GSL::CDF; our @EXPORT_OK = qw(gsl_cdf_beta_P gsl_cdf_beta_Pinv gsl_cdf_beta_Q gsl_cdf_beta_Qinv gsl_cdf_binomial_P gsl_cdf_binomial_Q gsl_cdf_cauchy_P gsl_cdf_cauchy_Pinv gsl_cdf_cauchy_Q gsl_cdf_cauchy_Qinv gsl_cdf_chisq_P gsl_cdf_chisq_Pinv gsl_cdf_chisq_Q gsl_cdf_chisq_Qinv gsl_cdf_exponential_P gsl_cdf_exponential_Pinv gsl_cdf_exponential_Q gsl_cdf_exponential_Qinv gsl_cdf_exppow_P gsl_cdf_exppow_Q gsl_cdf_fdist_P gsl_cdf_fdist_Pinv gsl_cdf_fdist_Q gsl_cdf_fdist_Qinv gsl_cdf_flat_P gsl_cdf_flat_Pinv gsl_cdf_flat_Q gsl_cdf_flat_Qinv gsl_cdf_gamma_P gsl_cdf_gamma_Pinv gsl_cdf_gamma_Q gsl_cdf_gamma_Qinv gsl_cdf_gaussian_P gsl_cdf_gaussian_Pinv gsl_cdf_gaussian_Q gsl_cdf_gaussian_Qinv gsl_cdf_geometric_P gsl_cdf_geometric_Q gsl_cdf_gumbel1_P gsl_cdf_gumbel1_Pinv gsl_cdf_gumbel1_Q gsl_cdf_gumbel1_Qinv gsl_cdf_gumbel2_P gsl_cdf_gumbel2_Pinv gsl_cdf_gumbel2_Q gsl_cdf_gumbel2_Qinv gsl_cdf_hypergeometric_P gsl_cdf_hypergeometric_Q gsl_cdf_laplace_P gsl_cdf_laplace_Pinv gsl_cdf_laplace_Q gsl_cdf_laplace_Qinv gsl_cdf_logistic_P gsl_cdf_logistic_Pinv gsl_cdf_logistic_Q gsl_cdf_logistic_Qinv gsl_cdf_lognormal_P gsl_cdf_lognormal_Pinv gsl_cdf_lognormal_Q gsl_cdf_lognormal_Qinv gsl_cdf_negative_binomial_P gsl_cdf_negative_binomial_Q gsl_cdf_pareto_P gsl_cdf_pareto_Pinv gsl_cdf_pareto_Q gsl_cdf_pareto_Qinv gsl_cdf_pascal_P gsl_cdf_pascal_Q gsl_cdf_poisson_P gsl_cdf_poisson_Q gsl_cdf_rayleigh_P gsl_cdf_rayleigh_Pinv gsl_cdf_rayleigh_Q gsl_cdf_rayleigh_Qinv gsl_cdf_tdist_P gsl_cdf_tdist_Pinv gsl_cdf_tdist_Q gsl_cdf_tdist_Qinv gsl_cdf_ugaussian_P gsl_cdf_ugaussian_Pinv gsl_cdf_ugaussian_Q gsl_cdf_ugaussian_Qinv gsl_cdf_weibull_P gsl_cdf_weibull_Pinv gsl_cdf_weibull_Q gsl_cdf_weibull_Qinv ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::GSL::CDF ; #line 5 "gsl_cdf.pd" use strict; use warnings; =head1 NAME PDL::GSL::CDF - PDL interface to GSL Cumulative Distribution Functions =head1 DESCRIPTION This is an interface to the Cumulative Distribution Function package present in the GNU Scientific Library. Let us have a continuous random number distributions are defined by a probability density function C. The cumulative distribution function for the lower tail C is defined by the integral of C, and gives the probability of a variate taking a value less than C. These functions are named B. The cumulative distribution function for the upper tail C is defined by the integral of C, and gives the probability of a variate taking a value greater than C. These functions are named B. The upper and lower cumulative distribution functions are related by C and satisfy C<0 E= P(x) E= 1> and C<0 E= Q(x) E= 1>. The inverse cumulative distributions, C and C give the values of C which correspond to a specific value of C

or C. They can be used to find confidence limits from probability values. These functions are named B and B. For discrete distributions the probability of sampling the integer value C is given by C, where C. The cumulative distribution for the lower tail C of a discrete distribution is defined as, where the sum is over the allowed range of the distribution less than or equal to C. The cumulative distribution for the upper tail of a discrete distribution C is defined as giving the sum of probabilities for all values greater than C. These two definitions satisfy the identity C. If the range of the distribution is C<1> to C inclusive then C, C while C, C. =head1 SYNOPSIS use PDL; use PDL::GSL::CDF; my $p = gsl_cdf_tdist_P( $t, $df ); my $t = gsl_cdf_tdist_Pinv( $p, $df ); =cut #line 73 "CDF.pm" =head1 FUNCTIONS =cut #line 145 "gsl_cdf.pd" =head2 The Beta Distribution (gsl_cdf_beta_*) These functions compute the cumulative distribution functions P(x), Q(x) and their inverses for the beta distribution with parameters I and I. =cut #line 94 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_beta_P =for sig Signature: (double x(); double a(); double b(); double [o]out()) =for ref =for bad gsl_cdf_beta_P processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 118 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_beta_P = \&PDL::gsl_cdf_beta_P; #line 124 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_beta_Pinv =for sig Signature: (double p(); double a(); double b(); double [o]out()) =for ref =for bad gsl_cdf_beta_Pinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 148 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_beta_Pinv = \&PDL::gsl_cdf_beta_Pinv; #line 154 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_beta_Q =for sig Signature: (double x(); double a(); double b(); double [o]out()) =for ref =for bad gsl_cdf_beta_Q processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 178 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_beta_Q = \&PDL::gsl_cdf_beta_Q; #line 184 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_beta_Qinv =for sig Signature: (double q(); double a(); double b(); double [o]out()) =for ref =for bad gsl_cdf_beta_Qinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 208 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_beta_Qinv = \&PDL::gsl_cdf_beta_Qinv; #line 214 "CDF.pm" #line 145 "gsl_cdf.pd" =head2 The Binomial Distribution (gsl_cdf_binomial_*) These functions compute the cumulative distribution functions P(k), Q(k) for the binomial distribution with parameters I

and I. =cut #line 225 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_binomial_P =for sig Signature: (ushort k(); double p(); ushort n(); double [o]out()) =for ref =for bad gsl_cdf_binomial_P processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 249 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_binomial_P = \&PDL::gsl_cdf_binomial_P; #line 255 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_binomial_Q =for sig Signature: (ushort k(); double p(); ushort n(); double [o]out()) =for ref =for bad gsl_cdf_binomial_Q processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 279 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_binomial_Q = \&PDL::gsl_cdf_binomial_Q; #line 285 "CDF.pm" #line 145 "gsl_cdf.pd" =head2 The Cauchy Distribution (gsl_cdf_cauchy_*) These functions compute the cumulative distribution functions P(x), Q(x) and their inverses for the Cauchy distribution with scale parameter I. =cut #line 296 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_cauchy_P =for sig Signature: (double x(); double a(); double [o]out()) =for ref =for bad gsl_cdf_cauchy_P processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 320 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_cauchy_P = \&PDL::gsl_cdf_cauchy_P; #line 326 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_cauchy_Pinv =for sig Signature: (double p(); double a(); double [o]out()) =for ref =for bad gsl_cdf_cauchy_Pinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 350 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_cauchy_Pinv = \&PDL::gsl_cdf_cauchy_Pinv; #line 356 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_cauchy_Q =for sig Signature: (double x(); double a(); double [o]out()) =for ref =for bad gsl_cdf_cauchy_Q processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 380 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_cauchy_Q = \&PDL::gsl_cdf_cauchy_Q; #line 386 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_cauchy_Qinv =for sig Signature: (double q(); double a(); double [o]out()) =for ref =for bad gsl_cdf_cauchy_Qinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 410 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_cauchy_Qinv = \&PDL::gsl_cdf_cauchy_Qinv; #line 416 "CDF.pm" #line 145 "gsl_cdf.pd" =head2 The Chi-squared Distribution (gsl_cdf_chisq_*) These functions compute the cumulative distribution functions P(x), Q(x) and their inverses for the chi-squared distribution with I degrees of freedom. =cut #line 427 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_chisq_P =for sig Signature: (double x(); double nu(); double [o]out()) =for ref =for bad gsl_cdf_chisq_P processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 451 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_chisq_P = \&PDL::gsl_cdf_chisq_P; #line 457 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_chisq_Pinv =for sig Signature: (double p(); double nu(); double [o]out()) =for ref =for bad gsl_cdf_chisq_Pinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 481 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_chisq_Pinv = \&PDL::gsl_cdf_chisq_Pinv; #line 487 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_chisq_Q =for sig Signature: (double x(); double nu(); double [o]out()) =for ref =for bad gsl_cdf_chisq_Q processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 511 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_chisq_Q = \&PDL::gsl_cdf_chisq_Q; #line 517 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_chisq_Qinv =for sig Signature: (double q(); double nu(); double [o]out()) =for ref =for bad gsl_cdf_chisq_Qinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 541 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_chisq_Qinv = \&PDL::gsl_cdf_chisq_Qinv; #line 547 "CDF.pm" #line 145 "gsl_cdf.pd" =head2 The Exponential Distribution (gsl_cdf_exponential_*) These functions compute the cumulative distribution functions P(x), Q(x) and their inverses for the exponential distribution with mean I. =cut #line 558 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_exponential_P =for sig Signature: (double x(); double mu(); double [o]out()) =for ref =for bad gsl_cdf_exponential_P processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 582 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_exponential_P = \&PDL::gsl_cdf_exponential_P; #line 588 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_exponential_Pinv =for sig Signature: (double p(); double mu(); double [o]out()) =for ref =for bad gsl_cdf_exponential_Pinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 612 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_exponential_Pinv = \&PDL::gsl_cdf_exponential_Pinv; #line 618 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_exponential_Q =for sig Signature: (double x(); double mu(); double [o]out()) =for ref =for bad gsl_cdf_exponential_Q processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 642 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_exponential_Q = \&PDL::gsl_cdf_exponential_Q; #line 648 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_exponential_Qinv =for sig Signature: (double q(); double mu(); double [o]out()) =for ref =for bad gsl_cdf_exponential_Qinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 672 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_exponential_Qinv = \&PDL::gsl_cdf_exponential_Qinv; #line 678 "CDF.pm" #line 145 "gsl_cdf.pd" =head2 The Exponential Power Distribution (gsl_cdf_exppow_*) These functions compute the cumulative distribution functions P(x), Q(x) for the exponential power distribution with parameters I and I. =cut #line 689 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_exppow_P =for sig Signature: (double x(); double a(); double b(); double [o]out()) =for ref =for bad gsl_cdf_exppow_P processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 713 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_exppow_P = \&PDL::gsl_cdf_exppow_P; #line 719 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_exppow_Q =for sig Signature: (double x(); double a(); double b(); double [o]out()) =for ref =for bad gsl_cdf_exppow_Q processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 743 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_exppow_Q = \&PDL::gsl_cdf_exppow_Q; #line 749 "CDF.pm" #line 145 "gsl_cdf.pd" =head2 The F-distribution (gsl_cdf_fdist_*) These functions compute the cumulative distribution functions P(x), Q(x) and their inverses for the F-distribution with I and I degrees of freedom. =cut #line 760 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_fdist_P =for sig Signature: (double x(); double nua(); double nub(); double [o]out()) =for ref =for bad gsl_cdf_fdist_P processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 784 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_fdist_P = \&PDL::gsl_cdf_fdist_P; #line 790 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_fdist_Pinv =for sig Signature: (double p(); double nua(); double nub(); double [o]out()) =for ref =for bad gsl_cdf_fdist_Pinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 814 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_fdist_Pinv = \&PDL::gsl_cdf_fdist_Pinv; #line 820 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_fdist_Q =for sig Signature: (double x(); double nua(); double nub(); double [o]out()) =for ref =for bad gsl_cdf_fdist_Q processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 844 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_fdist_Q = \&PDL::gsl_cdf_fdist_Q; #line 850 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_fdist_Qinv =for sig Signature: (double q(); double nua(); double nub(); double [o]out()) =for ref =for bad gsl_cdf_fdist_Qinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 874 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_fdist_Qinv = \&PDL::gsl_cdf_fdist_Qinv; #line 880 "CDF.pm" #line 145 "gsl_cdf.pd" =head2 The Flat (Uniform) Distribution (gsl_cdf_flat_*) These functions compute the cumulative distribution functions P(x), Q(x) and their inverses for a uniform distribution from I to I. =cut #line 891 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_flat_P =for sig Signature: (double x(); double a(); double b(); double [o]out()) =for ref =for bad gsl_cdf_flat_P processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 915 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_flat_P = \&PDL::gsl_cdf_flat_P; #line 921 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_flat_Pinv =for sig Signature: (double p(); double a(); double b(); double [o]out()) =for ref =for bad gsl_cdf_flat_Pinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 945 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_flat_Pinv = \&PDL::gsl_cdf_flat_Pinv; #line 951 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_flat_Q =for sig Signature: (double x(); double a(); double b(); double [o]out()) =for ref =for bad gsl_cdf_flat_Q processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 975 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_flat_Q = \&PDL::gsl_cdf_flat_Q; #line 981 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_flat_Qinv =for sig Signature: (double q(); double a(); double b(); double [o]out()) =for ref =for bad gsl_cdf_flat_Qinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1005 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_flat_Qinv = \&PDL::gsl_cdf_flat_Qinv; #line 1011 "CDF.pm" #line 145 "gsl_cdf.pd" =head2 The Gamma Distribution (gsl_cdf_gamma_*) These functions compute the cumulative distribution functions P(x), Q(x) and their inverses for the gamma distribution with parameters I and I. =cut #line 1022 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_gamma_P =for sig Signature: (double x(); double a(); double b(); double [o]out()) =for ref =for bad gsl_cdf_gamma_P processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1046 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_gamma_P = \&PDL::gsl_cdf_gamma_P; #line 1052 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_gamma_Pinv =for sig Signature: (double p(); double a(); double b(); double [o]out()) =for ref =for bad gsl_cdf_gamma_Pinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1076 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_gamma_Pinv = \&PDL::gsl_cdf_gamma_Pinv; #line 1082 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_gamma_Q =for sig Signature: (double x(); double a(); double b(); double [o]out()) =for ref =for bad gsl_cdf_gamma_Q processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1106 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_gamma_Q = \&PDL::gsl_cdf_gamma_Q; #line 1112 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_gamma_Qinv =for sig Signature: (double q(); double a(); double b(); double [o]out()) =for ref =for bad gsl_cdf_gamma_Qinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1136 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_gamma_Qinv = \&PDL::gsl_cdf_gamma_Qinv; #line 1142 "CDF.pm" #line 145 "gsl_cdf.pd" =head2 The Gaussian Distribution (gsl_cdf_gaussian_*) These functions compute the cumulative distribution functions P(x), Q(x) and their inverses for the Gaussian distribution with standard deviation I. =cut #line 1153 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_gaussian_P =for sig Signature: (double x(); double sigma(); double [o]out()) =for ref =for bad gsl_cdf_gaussian_P processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1177 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_gaussian_P = \&PDL::gsl_cdf_gaussian_P; #line 1183 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_gaussian_Pinv =for sig Signature: (double p(); double sigma(); double [o]out()) =for ref =for bad gsl_cdf_gaussian_Pinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1207 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_gaussian_Pinv = \&PDL::gsl_cdf_gaussian_Pinv; #line 1213 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_gaussian_Q =for sig Signature: (double x(); double sigma(); double [o]out()) =for ref =for bad gsl_cdf_gaussian_Q processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1237 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_gaussian_Q = \&PDL::gsl_cdf_gaussian_Q; #line 1243 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_gaussian_Qinv =for sig Signature: (double q(); double sigma(); double [o]out()) =for ref =for bad gsl_cdf_gaussian_Qinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1267 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_gaussian_Qinv = \&PDL::gsl_cdf_gaussian_Qinv; #line 1273 "CDF.pm" #line 145 "gsl_cdf.pd" =head2 The Geometric Distribution (gsl_cdf_geometric_*) These functions compute the cumulative distribution functions P(k), Q(k) for the geometric distribution with parameter I

. =cut #line 1284 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_geometric_P =for sig Signature: (ushort k(); double p(); double [o]out()) =for ref =for bad gsl_cdf_geometric_P processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1308 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_geometric_P = \&PDL::gsl_cdf_geometric_P; #line 1314 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_geometric_Q =for sig Signature: (ushort k(); double p(); double [o]out()) =for ref =for bad gsl_cdf_geometric_Q processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1338 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_geometric_Q = \&PDL::gsl_cdf_geometric_Q; #line 1344 "CDF.pm" #line 145 "gsl_cdf.pd" =head2 The Type-1 Gumbel Distribution (gsl_cdf_gumbel1_*) These functions compute the cumulative distribution functions P(x), Q(x) and their inverses for the Type-1 Gumbel distribution with parameters I and I. =cut #line 1355 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_gumbel1_P =for sig Signature: (double x(); double a(); double b(); double [o]out()) =for ref =for bad gsl_cdf_gumbel1_P processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1379 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_gumbel1_P = \&PDL::gsl_cdf_gumbel1_P; #line 1385 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_gumbel1_Pinv =for sig Signature: (double p(); double a(); double b(); double [o]out()) =for ref =for bad gsl_cdf_gumbel1_Pinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1409 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_gumbel1_Pinv = \&PDL::gsl_cdf_gumbel1_Pinv; #line 1415 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_gumbel1_Q =for sig Signature: (double x(); double a(); double b(); double [o]out()) =for ref =for bad gsl_cdf_gumbel1_Q processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1439 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_gumbel1_Q = \&PDL::gsl_cdf_gumbel1_Q; #line 1445 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_gumbel1_Qinv =for sig Signature: (double q(); double a(); double b(); double [o]out()) =for ref =for bad gsl_cdf_gumbel1_Qinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1469 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_gumbel1_Qinv = \&PDL::gsl_cdf_gumbel1_Qinv; #line 1475 "CDF.pm" #line 145 "gsl_cdf.pd" =head2 The Type-2 Gumbel Distribution (gsl_cdf_gumbel2_*) These functions compute the cumulative distribution functions P(x), Q(x) and their inverses for the Type-2 Gumbel distribution with parameters I and I. =cut #line 1486 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_gumbel2_P =for sig Signature: (double x(); double a(); double b(); double [o]out()) =for ref =for bad gsl_cdf_gumbel2_P processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1510 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_gumbel2_P = \&PDL::gsl_cdf_gumbel2_P; #line 1516 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_gumbel2_Pinv =for sig Signature: (double p(); double a(); double b(); double [o]out()) =for ref =for bad gsl_cdf_gumbel2_Pinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1540 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_gumbel2_Pinv = \&PDL::gsl_cdf_gumbel2_Pinv; #line 1546 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_gumbel2_Q =for sig Signature: (double x(); double a(); double b(); double [o]out()) =for ref =for bad gsl_cdf_gumbel2_Q processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1570 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_gumbel2_Q = \&PDL::gsl_cdf_gumbel2_Q; #line 1576 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_gumbel2_Qinv =for sig Signature: (double q(); double a(); double b(); double [o]out()) =for ref =for bad gsl_cdf_gumbel2_Qinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1600 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_gumbel2_Qinv = \&PDL::gsl_cdf_gumbel2_Qinv; #line 1606 "CDF.pm" #line 145 "gsl_cdf.pd" =head2 The Hypergeometric Distribution (gsl_cdf_hypergeometric_*) These functions compute the cumulative distribution functions P(k), Q(k) for the hypergeometric distribution with parameters I, I and I. =cut #line 1617 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_hypergeometric_P =for sig Signature: (ushort k(); ushort na(); ushort nb(); ushort t(); double [o]out()) =for ref =for bad gsl_cdf_hypergeometric_P processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1641 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_hypergeometric_P = \&PDL::gsl_cdf_hypergeometric_P; #line 1647 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_hypergeometric_Q =for sig Signature: (ushort k(); ushort na(); ushort nb(); ushort t(); double [o]out()) =for ref =for bad gsl_cdf_hypergeometric_Q processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1671 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_hypergeometric_Q = \&PDL::gsl_cdf_hypergeometric_Q; #line 1677 "CDF.pm" #line 145 "gsl_cdf.pd" =head2 The Laplace Distribution (gsl_cdf_laplace_*) These functions compute the cumulative distribution functions P(x), Q(x) and their inverses for the Laplace distribution with width I. =cut #line 1688 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_laplace_P =for sig Signature: (double x(); double a(); double [o]out()) =for ref =for bad gsl_cdf_laplace_P processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1712 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_laplace_P = \&PDL::gsl_cdf_laplace_P; #line 1718 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_laplace_Pinv =for sig Signature: (double p(); double a(); double [o]out()) =for ref =for bad gsl_cdf_laplace_Pinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1742 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_laplace_Pinv = \&PDL::gsl_cdf_laplace_Pinv; #line 1748 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_laplace_Q =for sig Signature: (double x(); double a(); double [o]out()) =for ref =for bad gsl_cdf_laplace_Q processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1772 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_laplace_Q = \&PDL::gsl_cdf_laplace_Q; #line 1778 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_laplace_Qinv =for sig Signature: (double q(); double a(); double [o]out()) =for ref =for bad gsl_cdf_laplace_Qinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1802 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_laplace_Qinv = \&PDL::gsl_cdf_laplace_Qinv; #line 1808 "CDF.pm" #line 145 "gsl_cdf.pd" =head2 The Logistic Distribution (gsl_cdf_logistic_*) These functions compute the cumulative distribution functions P(x), Q(x) and their inverses for the logistic distribution with scale parameter I. =cut #line 1819 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_logistic_P =for sig Signature: (double x(); double a(); double [o]out()) =for ref =for bad gsl_cdf_logistic_P processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1843 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_logistic_P = \&PDL::gsl_cdf_logistic_P; #line 1849 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_logistic_Pinv =for sig Signature: (double p(); double a(); double [o]out()) =for ref =for bad gsl_cdf_logistic_Pinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1873 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_logistic_Pinv = \&PDL::gsl_cdf_logistic_Pinv; #line 1879 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_logistic_Q =for sig Signature: (double x(); double a(); double [o]out()) =for ref =for bad gsl_cdf_logistic_Q processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1903 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_logistic_Q = \&PDL::gsl_cdf_logistic_Q; #line 1909 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_logistic_Qinv =for sig Signature: (double q(); double a(); double [o]out()) =for ref =for bad gsl_cdf_logistic_Qinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1933 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_logistic_Qinv = \&PDL::gsl_cdf_logistic_Qinv; #line 1939 "CDF.pm" #line 145 "gsl_cdf.pd" =head2 The Lognormal Distribution (gsl_cdf_lognormal_*) These functions compute the cumulative distribution functions P(x), Q(x) and their inverses for the lognormal distribution with parameters I and I. =cut #line 1950 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_lognormal_P =for sig Signature: (double x(); double zeta(); double sigma(); double [o]out()) =for ref =for bad gsl_cdf_lognormal_P processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1974 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_lognormal_P = \&PDL::gsl_cdf_lognormal_P; #line 1980 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_lognormal_Pinv =for sig Signature: (double p(); double zeta(); double sigma(); double [o]out()) =for ref =for bad gsl_cdf_lognormal_Pinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2004 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_lognormal_Pinv = \&PDL::gsl_cdf_lognormal_Pinv; #line 2010 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_lognormal_Q =for sig Signature: (double x(); double zeta(); double sigma(); double [o]out()) =for ref =for bad gsl_cdf_lognormal_Q processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2034 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_lognormal_Q = \&PDL::gsl_cdf_lognormal_Q; #line 2040 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_lognormal_Qinv =for sig Signature: (double q(); double zeta(); double sigma(); double [o]out()) =for ref =for bad gsl_cdf_lognormal_Qinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2064 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_lognormal_Qinv = \&PDL::gsl_cdf_lognormal_Qinv; #line 2070 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_negative_binomial_P =for sig Signature: (ushort k(); double p(); double n(); double [o]out()) =for ref =for bad gsl_cdf_negative_binomial_P processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2094 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_negative_binomial_P = \&PDL::gsl_cdf_negative_binomial_P; #line 2100 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_negative_binomial_Q =for sig Signature: (ushort k(); double p(); double n(); double [o]out()) =for ref =for bad gsl_cdf_negative_binomial_Q processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2124 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_negative_binomial_Q = \&PDL::gsl_cdf_negative_binomial_Q; #line 2130 "CDF.pm" #line 145 "gsl_cdf.pd" =head2 The Pareto Distribution (gsl_cdf_pareto_*) These functions compute the cumulative distribution functions P(x), Q(x) and their inverses for the Pareto distribution with exponent I and scale I. =cut #line 2141 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_pareto_P =for sig Signature: (double x(); double a(); double b(); double [o]out()) =for ref =for bad gsl_cdf_pareto_P processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2165 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_pareto_P = \&PDL::gsl_cdf_pareto_P; #line 2171 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_pareto_Pinv =for sig Signature: (double p(); double a(); double b(); double [o]out()) =for ref =for bad gsl_cdf_pareto_Pinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2195 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_pareto_Pinv = \&PDL::gsl_cdf_pareto_Pinv; #line 2201 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_pareto_Q =for sig Signature: (double x(); double a(); double b(); double [o]out()) =for ref =for bad gsl_cdf_pareto_Q processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2225 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_pareto_Q = \&PDL::gsl_cdf_pareto_Q; #line 2231 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_pareto_Qinv =for sig Signature: (double q(); double a(); double b(); double [o]out()) =for ref =for bad gsl_cdf_pareto_Qinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2255 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_pareto_Qinv = \&PDL::gsl_cdf_pareto_Qinv; #line 2261 "CDF.pm" #line 145 "gsl_cdf.pd" =head2 The Pascal Distribution (gsl_cdf_pascal_*) These functions compute the cumulative distribution functions P(k), Q(k) for the Pascal distribution with parameters I

and I. =cut #line 2272 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_pascal_P =for sig Signature: (ushort k(); double p(); ushort n(); double [o]out()) =for ref =for bad gsl_cdf_pascal_P processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2296 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_pascal_P = \&PDL::gsl_cdf_pascal_P; #line 2302 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_pascal_Q =for sig Signature: (ushort k(); double p(); ushort n(); double [o]out()) =for ref =for bad gsl_cdf_pascal_Q processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2326 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_pascal_Q = \&PDL::gsl_cdf_pascal_Q; #line 2332 "CDF.pm" #line 145 "gsl_cdf.pd" =head2 The Poisson Distribution (gsl_cdf_poisson_*) These functions compute the cumulative distribution functions P(k), Q(k) for the Poisson distribution with parameter I. =cut #line 2343 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_poisson_P =for sig Signature: (ushort k(); double mu(); double [o]out()) =for ref =for bad gsl_cdf_poisson_P processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2367 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_poisson_P = \&PDL::gsl_cdf_poisson_P; #line 2373 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_poisson_Q =for sig Signature: (ushort k(); double mu(); double [o]out()) =for ref =for bad gsl_cdf_poisson_Q processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2397 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_poisson_Q = \&PDL::gsl_cdf_poisson_Q; #line 2403 "CDF.pm" #line 145 "gsl_cdf.pd" =head2 The Rayleigh Distribution (gsl_cdf_rayleigh_*) These functions compute the cumulative distribution functions P(x), Q(x) and their inverses for the Rayleigh distribution with scale parameter I. =cut #line 2414 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_rayleigh_P =for sig Signature: (double x(); double sigma(); double [o]out()) =for ref =for bad gsl_cdf_rayleigh_P processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2438 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_rayleigh_P = \&PDL::gsl_cdf_rayleigh_P; #line 2444 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_rayleigh_Pinv =for sig Signature: (double p(); double sigma(); double [o]out()) =for ref =for bad gsl_cdf_rayleigh_Pinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2468 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_rayleigh_Pinv = \&PDL::gsl_cdf_rayleigh_Pinv; #line 2474 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_rayleigh_Q =for sig Signature: (double x(); double sigma(); double [o]out()) =for ref =for bad gsl_cdf_rayleigh_Q processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2498 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_rayleigh_Q = \&PDL::gsl_cdf_rayleigh_Q; #line 2504 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_rayleigh_Qinv =for sig Signature: (double q(); double sigma(); double [o]out()) =for ref =for bad gsl_cdf_rayleigh_Qinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2528 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_rayleigh_Qinv = \&PDL::gsl_cdf_rayleigh_Qinv; #line 2534 "CDF.pm" #line 145 "gsl_cdf.pd" =head2 The t-distribution (gsl_cdf_tdist_*) These functions compute the cumulative distribution functions P(x), Q(x) and their inverses for the t-distribution with I degrees of freedom. =cut #line 2545 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_tdist_P =for sig Signature: (double x(); double nu(); double [o]out()) =for ref =for bad gsl_cdf_tdist_P processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2569 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_tdist_P = \&PDL::gsl_cdf_tdist_P; #line 2575 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_tdist_Pinv =for sig Signature: (double p(); double nu(); double [o]out()) =for ref =for bad gsl_cdf_tdist_Pinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2599 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_tdist_Pinv = \&PDL::gsl_cdf_tdist_Pinv; #line 2605 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_tdist_Q =for sig Signature: (double x(); double nu(); double [o]out()) =for ref =for bad gsl_cdf_tdist_Q processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2629 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_tdist_Q = \&PDL::gsl_cdf_tdist_Q; #line 2635 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_tdist_Qinv =for sig Signature: (double q(); double nu(); double [o]out()) =for ref =for bad gsl_cdf_tdist_Qinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2659 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_tdist_Qinv = \&PDL::gsl_cdf_tdist_Qinv; #line 2665 "CDF.pm" #line 145 "gsl_cdf.pd" =head2 The Unit Gaussian Distribution (gsl_cdf_ugaussian_*) These functions compute the cumulative distribution functions P(x), Q(x) and their inverses for the unit Gaussian distribution. =cut #line 2676 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_ugaussian_P =for sig Signature: (double x(); double [o]out()) =for ref =for bad gsl_cdf_ugaussian_P processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2700 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_ugaussian_P = \&PDL::gsl_cdf_ugaussian_P; #line 2706 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_ugaussian_Pinv =for sig Signature: (double p(); double [o]out()) =for ref =for bad gsl_cdf_ugaussian_Pinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2730 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_ugaussian_Pinv = \&PDL::gsl_cdf_ugaussian_Pinv; #line 2736 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_ugaussian_Q =for sig Signature: (double x(); double [o]out()) =for ref =for bad gsl_cdf_ugaussian_Q processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2760 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_ugaussian_Q = \&PDL::gsl_cdf_ugaussian_Q; #line 2766 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_ugaussian_Qinv =for sig Signature: (double q(); double [o]out()) =for ref =for bad gsl_cdf_ugaussian_Qinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2790 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_ugaussian_Qinv = \&PDL::gsl_cdf_ugaussian_Qinv; #line 2796 "CDF.pm" #line 145 "gsl_cdf.pd" =head2 The Weibull Distribution (gsl_cdf_weibull_*) These functions compute the cumulative distribution functions P(x), Q(x) and their inverses for the Weibull distribution with scale I and exponent I. =cut #line 2807 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_weibull_P =for sig Signature: (double x(); double a(); double b(); double [o]out()) =for ref =for bad gsl_cdf_weibull_P processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2831 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_weibull_P = \&PDL::gsl_cdf_weibull_P; #line 2837 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_weibull_Pinv =for sig Signature: (double p(); double a(); double b(); double [o]out()) =for ref =for bad gsl_cdf_weibull_Pinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2861 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_weibull_Pinv = \&PDL::gsl_cdf_weibull_Pinv; #line 2867 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_weibull_Q =for sig Signature: (double x(); double a(); double b(); double [o]out()) =for ref =for bad gsl_cdf_weibull_Q processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2891 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_weibull_Q = \&PDL::gsl_cdf_weibull_Q; #line 2897 "CDF.pm" #line 1059 "../../../blib/lib/PDL/PP.pm" =head2 gsl_cdf_weibull_Qinv =for sig Signature: (double q(); double a(); double b(); double [o]out()) =for ref =for bad gsl_cdf_weibull_Qinv processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2921 "CDF.pm" #line 1061 "../../../blib/lib/PDL/PP.pm" *gsl_cdf_weibull_Qinv = \&PDL::gsl_cdf_weibull_Qinv; #line 2927 "CDF.pm" #line 195 "gsl_cdf.pd" =head1 AUTHOR Copyright (C) 2009 Maggie J. Xiong The GSL CDF module was written by J. Stover. All rights reserved. There is no warranty. You are allowed to redistribute this software / documentation as described in the file COPYING in the PDL distribution. =cut #line 2944 "CDF.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/ImageRGB.pm0000644000175000017500000001532414200406317015725 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::ImageRGB; our @EXPORT_OK = qw(interlrgb rgbtogr bytescl cquant cquant_c ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::ImageRGB ; #line 10 "imagergb.pd" use strict; use warnings; =head1 NAME PDL::ImageRGB -- some utility functions for RGB image data handling =head1 DESCRIPTION Collection of a few commonly used routines involved in handling of RGB, palette and grayscale images. Not much more than a start. Should be a good place to exercise some of the thread/map/clump PP stuff. Other stuff that should/could go here: =over 3 =item * color space conversion =item * common image filters =item * image rebinning =back =head1 SYNOPSIS use PDL::ImageRGB; =cut use vars qw( $typecheck $EPS ); use PDL::Core; use PDL::Basic; use PDL::Primitive; use PDL::Types; use Carp; use strict 'vars'; $PDL::ImageRGB::EPS = 1e-7; # there is probably a more portable way =head1 FUNCTIONS =head2 cquant =for ref quantize and reduce colours in 8-bit images =for usage ($out, $lut) = cquant($image [,$ncols]); This function does color reduction for <=8bit displays and accepts 8bit RGB and 8bit palette images. It does this through an interface to the ppm_quant routine from the pbmplus package that implements the median cut routine which intellegently selects the 'best' colors to represent your image on a <= 8bit display (based on the median cut algorithm). Optional args: $ncols sets the maximum nunmber of colours used for the output image (defaults to 256). There are images where a different color reduction scheme gives better results (it seems this is true for images containing large areas with very smoothly changing colours). Returns a list containing the new palette image (type PDL_Byte) and the RGB colormap. =cut # full threading support intended *cquant = \&PDL::cquant; sub PDL::cquant { barf 'Usage: ($out,$olut) = cquant($image[,$ncols])' if $#_<0 || $#_>1; my $image = shift; my $ncols; if ($#_ >= 0 ) { $ncols=shift; } else { $ncols = 256; }; my @Dims = $image->dims; my ($out, $olut) = (null,null); barf "input must be byte (3,x,x)" if (@Dims < 2) || ($Dims[0] != 3) || ($image->get_datatype != $PDL_B); cquant_c($image,$out,$olut,$ncols); return ($out,$olut); } =head2 interlrgb =for ref Make an RGB image from a palette image and its lookup table. =for usage $rgb = $palette_im->interlrgb($lut) Input should be of an integer type and the lookup table (3,x,...). Will perform the lookup for any N-dimensional input pdl (i.e. 0D, 1D, 2D, ...). Uses the index command but will not dataflow by default. If you want it to dataflow the dataflow_forward flag must be set in the $lut ndarray (you can do that by saying $lut->set_dataflow_f(1)). =cut # interlace a palette image, input as 8bit-image, RGB-lut (3,x,..) to # (R,G,B) format for each pixel in the image # should already support threading *interlrgb=\&PDL::interlrgb; sub PDL::interlrgb { my ($pdl,$lut) = @_; my $res; # for our purposes $lut should be (3,z) where z is the number # of colours in the lut barf "expecting (3,x) input" if ($lut->dims)[0] != 3; # do the conversion as an implicitly threaded index lookup if ($lut->fflows) { $res = $lut->transpose->index($pdl->dummy(0)); } else { $res = $lut->transpose->index($pdl->dummy(0))->sever; } return $res; } =head2 rgbtogr =for ref Converts an RGB image to a grey scale using standard transform =for usage $gr = $rgb->rgbtogr Performs a conversion of an RGB input image (3,x,....) to a greyscale image (x,.....) using standard formula: Grey = 0.301 R + 0.586 G + 0.113 B =cut # convert interlaced rgb image to grayscale # will convert any (3,...) dim pdl, i.e. also single lines, # stacks of RGB images, etc since implicit threading takes care of this # should already support threading *rgbtogr = \&PDL::rgbtogr; sub PDL::rgbtogr { barf "Usage: \$im->rgbtogr" if $#_ < 0; my $im = shift; barf "rgbtogr: expecting RGB (3,...) input" if (($im->dims)[0] != 3); my $type = $im->get_datatype; my $rgb = float([77,150,29])/256; # vector for rgb conversion my $oim = null; # flag PP we want it to allocate inner($im,$rgb,$oim); # do the conversion as a threaded inner prod return $oim->convert($type); # convert back to original type } =head2 bytescl =for ref Scales a pdl into a specified data range (default 0-255) =for usage $scale = $im->bytescl([$top]) By default $top=255, otherwise you have to give the desired top value as an argument to C. Normally C doesn't rescale data that fits already in the bounds 0..$top (it only does the type conversion if required). If you want to force it to rescale so that the max of the output is at $top and the min at 0 you give a negative $top value to indicate this. =cut # scale any pdl linearly so that its data fits into the range # 0<=x<=$ncols where $ncols<=255 # returns scaled data with type converted to byte # doesn't rescale but just typecasts if data already fits into range, i.e. # data ist not necessarily stretched to 0..$ncols # needs some changes for full threading support ?? (explicit threading?) *bytescl = \&PDL::bytescl; sub PDL::bytescl { barf 'Usage: bytescl $im[,$top]' if $#_ < 0; my $pdl = shift; my ($top,$force) = (255,0); $top = shift if $#_ > -1; if ($top < 0) { $force=1; $top *= -1; } $top = 255 if $top > 255; print "bytescl: scaling from 0..$top\n" if $PDL::debug; my ($max, $min); $max = max $pdl; $min = min $pdl; return byte $pdl if ($min >= 0 && $max <= $top && !$force); # check for pathological cases if (($max-$min) < $EPS) { print "bytescl: pathological case\n" if $PDL::debug; return byte $pdl if (abs($max) < $EPS) || ($max >= 0 && $max <= $top); return byte ($pdl/$max); } my $type = $pdl->get_datatype > $PDL_F ? $PDL_D : $PDL_F; return byte ($top*($pdl->convert($type)-$min)/($max-$min)+0.5); } ;# Exit with OK status 1; =head1 BUGS This package doesn't yet contain enough useful functions! =head1 AUTHOR Copyright 1997 Christian Soeller 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 #line 263 "ImageRGB.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *cquant_c = \&PDL::cquant_c; #line 273 "ImageRGB.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/Compression.pm0000644000175000017500000001407114200406311016641 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::Compression; our @EXPORT_OK = qw(rice_compress rice_expand ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Compression ; #line 6 "compression.pd" =head1 NAME PDL::Compression - compression utilities =head1 DESCRIPTION These routines generally accept some data as a PDL and compress it into a smaller PDL. Algorithms typically work on a single dimension and thread over other dimensions, producing a threaded table of compressed values if more than one dimension is fed in. The Rice algorithm, in particular, is designed to be identical to the RICE_1 algorithm used in internal FITS-file compression (see PDL::IO::FITS). =head1 SYNOPSIS use PDL::Compression ($y,$xsize) = $x->rice_compress(); $c = $y->rice_expand($xsize); =cut use strict; use warnings; #line 52 "Compression.pm" =head1 FUNCTIONS =cut #line 75 "compression.pd" =head1 METHODS =cut #line 71 "Compression.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 rice_compress =for sig Signature: (in(n); [o]out(m); int[o]len(); int blocksize) =for ref Squishes an input PDL along the 0 dimension by Rice compression. In scalar context, you get back only the compressed PDL; in list context, you also get back ancillary information that is required to uncompress the data with rice_uncompress. Multidimensional data are threaded over - each row is compressed separately, and the returned PDL is squished to the maximum compressed size of any row. If any of the streams could not be compressed (the algorithm produced longer output), the corresponding length is set to -1 and the row is treated as if it had length 0. Rice compression only works on integer data types -- if you have floating point data you must first quantize them. The underlying algorithm is identical to the Rice compressor used in CFITSIO (and is used by PDL::IO::FITS to load and save compressed FITS images). The optional blocksize indicates how many samples are to be compressed as a unit; it defaults to 32. How it works: Rice compression is a subset of Golomb compression, and works on data sets where variation between adjacent samples is typically small compared to the dynamic range of each sample. In this implementation (originally written by Richard White and contributed to CFITSIO in 1999), the data are divided into blocks of samples (by default 32 samples per block). Each block has a running difference applied, and the difference is bit-folded to make it positive definite. High order bits of the difference stream are discarded, and replaced with a unary representation; low order bits are preserved. Unary representation is very efficient for small numbers, but large jumps could give rise to ludicrously large bins in a plain Golomb code; such large jumps ("high entropy" samples) are simply recorded directly in the output stream. Working on astronomical or solar image data, typical compression ratios of 2-3 are achieved. =for usage $out = $pdl->rice_compress($blocksize); ($out, $len, $blocksize, $dim0) = $pdl->rice_compress; $new = $out->rice_expand; =for bad rice_compress ignores the bad-value flag of the input ndarrays. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 139 "Compression.pm" #line 1060 "../../blib/lib/PDL/PP.pm" sub PDL::rice_compress { my $in = shift; my $blocksize = shift || 32; ## Reject floating-point inputs if( $in->type != byte && $in->type != short && $in->type != ushort && $in->type != long ) { die("rice_compress: input needs to have type byte, short, ushort, or long, not ".($in->type)."\n"); } # output buffer starts the same size; truncate at the end. my ($out) = zeroes($in); # lengths go here my ($len) = zeroes(long, $in->slice("(0)")->dims); PDL::_rice_compress_int( $in, $out, $len, $blocksize ); my $l = $len->max; $out = $out->slice("0:".($l-1))->sever; return wantarray ? ($out, $in->dim(0), $blocksize, $len) : $out; } #line 164 "Compression.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *rice_compress = \&PDL::rice_compress; #line 170 "Compression.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 rice_expand =for sig Signature: (in(n); [o]out(m); int blocksize) =for ref Unsquishes a PDL that has been squished by rice_compress. =for usage ($out, $len, $blocksize, $dim0) = $pdl->rice_compress; $copy = $out->rice_expand($dim0, $blocksize); =for bad rice_expand ignores the bad-value flag of the input ndarrays. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 200 "Compression.pm" #line 1060 "../../blib/lib/PDL/PP.pm" sub PDL::rice_expand { my $squished = shift; my $dim0 =shift; my $blocksize = shift || 32; # Allocate output array my $out = zeroes( $squished->slice("(0),*$dim0") ); PDL::_rice_expand_int( $squished, $out, $blocksize ); return $out; } #line 214 "Compression.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *rice_expand = \&PDL::rice_expand; #line 220 "Compression.pm" #line 36 "compression.pd" =head1 AUTHORS Copyright (C) 2010 Craig DeForest. 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. The Rice compression library is derived from the similar library in the CFITSIO 3.24 release, and is licensed under yet more more lenient terms than PDL itself; that notice is present in the file "ricecomp.c". =head1 BUGS =over 3 =item * Currently headers are ignored. =item * Currently there is only one compression algorithm. =back =head1 TODO =over 3 =item * Add object encapsulation =item * Add test suite =back =cut #line 262 "Compression.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/IO/0000755000175000017500000000000014200406311014306 5ustar osboxesosboxesPDL-2.074/GENERATED/PDL/IO/GD.pm0000644000175000017500000016135314200406310015146 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::IO::GD; our @EXPORT_OK = qw(write_png write_png_ex write_true_png write_true_png_ex write_png_best write_true_png_best recompress_png_best load_lut read_png read_true_png _read_true_png _read_png _gd_image_to_pdl_true _gd_image_to_pdl _pdl_to_gd_image_true _pdl_to_gd_image_lut read_png_lut _read_png_lut _gdImageColorAllocates _gdImageColorAllocateAlphas _gdImageSetPixels _gdImageLines _gdImageDashedLines _gdImageRectangles _gdImageFilledRectangles _gdImageFilledArcs _gdImageArcs _gdImageFilledEllipses gdAlphaBlend gdTrueColor gdTrueColorAlpha gdFree gdFontGetLarge gdFontGetSmall gdFontGetMediumBold gdFontGetGiant gdFontGetTiny ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::IO::GD ; #line 23 "GD.pd" use strict; use warnings; =head1 NAME PDL::IO::GD - Interface to the GD image library. =head1 SYNOPSIS my $pdl = sequence(byte, 30, 30); write_png($pdl, load_lut($lutfile), "test.png"); write_true_png(sequence(100, 100, 3), "test_true.png"); my $image = read_png("test.png"); my $image = read_true_png("test_true_read.png"); write_true_png($image, "test_true_read.out.png"); my $lut = read_png_lut("test.png"); $pdl = sequence(byte, 30, 30); write_png_ex($pdl, load_lut($lutfile), "test_nocomp.png", 0); write_png_ex($pdl, load_lut($lutfile), "test_bestcomp1.png", 9); write_png_best($pdl, load_lut($lutfile), "test_bestcomp2.png"); $pdl = sequence(100, 100, 3); write_true_png_ex($pdl, "test_true_nocomp.png", 0); write_true_png_ex($pdl, "test_true_bestcomp1.png", 9); write_true_png_best($pdl, "test_true_bestcomp2.png"); recompress_png_best("test_recomp_best.png"); =head1 DESCRIPTION This is the "General Interface" for the PDL::IO::GD library, and is actually several years old at this point (read: stable). If you're feeling frisky, try the new OO interface described below. The general version just provides several image IO utility functions you can use with ndarray variables. It's deceptively useful, however. =cut #line 69 "GD.pm" =head1 FUNCTIONS =cut #line 1059 "../../blib/lib/PDL/PP.pm" =head2 write_png =for sig Signature: (byte img(x,y); byte lut(i,j); char* filename) Writes a 2-d PDL variable out to a PNG file, using the supplied color look-up-table ndarray (hereafter referred to as a LUT). The LUT contains a line for each value 0-255 with a corresponding R, G, and B value. =for bad write_png does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 105 "GD.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *write_png = \&PDL::write_png; #line 111 "GD.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 write_png_ex =for sig Signature: (img(x,y); lut(i,j); char* filename; int level) Same as write_png(), except you can specify the compression level (0-9) as the last argument. =for bad write_png_ex does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 134 "GD.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *write_png_ex = \&PDL::write_png_ex; #line 140 "GD.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 write_true_png =for sig Signature: (img(x,y,z); char* filename) Writes an (x, y, z(3)) PDL variable out to a PNG file, using a true color format. This means a larger file on disk, but can contain more than 256 colors. =for bad write_true_png does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 165 "GD.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *write_true_png = \&PDL::write_true_png; #line 171 "GD.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 write_true_png_ex =for sig Signature: (img(x,y,z); char* filename; int level) Same as write_true_png(), except you can specify the compression level (0-9) as the last argument. =for bad write_true_png_ex does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 194 "GD.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *write_true_png_ex = \&PDL::write_true_png_ex; #line 200 "GD.pm" #line 316 "GD.pd" =head2 write_png_best Like write_png(), but it assumes the best PNG compression (9). =for example write_png_best( $img(ndarray), $lut(ndarray), $filename ) =cut sub write_png_best { my $img = shift; my $lut = shift; my $filename = shift; return write_png_ex( $img, $lut, $filename, 9 ); } # End of write_png_best()... =head2 write_true_png_best Like write_true_png(), but it assumes the best PNG compression (9). =for example write_true_png_best( $img(ndarray), $filename ) =cut sub write_true_png_best { my $img = shift; my $filename = shift; return write_true_png_ex( $img, $filename, 9 ); } # End of write_true_png_best()... #line 242 "GD.pm" #line 362 "GD.pd" #line 247 "GD.pm" #line 390 "GD.pd" =head2 load_lut( $filename ) Loads a color look up table from an ASCII file. returns an ndarray =cut sub load_lut { return xchg(byte(cat(rcols(shift))), 0, 1); } # end of load_lut()... =head2 read_png( $filename ) Reads a (palette) PNG image into a (new) PDL variable. =cut sub read_png { my $filename = shift; # Get the image dims... my $x = _get_png_xs($filename); my $y = _get_png_ys($filename); #print "\$x=$x\t\$y=$y\n"; my $temp = zeroes(long, $x, $y); _read_png($temp, $filename); return byte($temp); } # End of read_png()... =head2 read_png_true( $filename ) Reads a true color PNG image into a (new) PDL variable. =cut sub read_true_png { my $filename = shift; # Get the image dims... my $x = _get_png_xs($filename); my $y = _get_png_ys($filename); #print "\$x=$x\t\$y=$y\n"; my $temp = zeroes(long, $x, $y, 3); _read_true_png($temp, $filename); return byte($temp); } # End of read_png()... #line 307 "GD.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *_read_true_png = \&PDL::_read_true_png; #line 313 "GD.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *_read_png = \&PDL::_read_png; #line 319 "GD.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *_gd_image_to_pdl_true = \&PDL::_gd_image_to_pdl_true; #line 325 "GD.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *_gd_image_to_pdl = \&PDL::_gd_image_to_pdl; #line 331 "GD.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *_pdl_to_gd_image_true = \&PDL::_pdl_to_gd_image_true; #line 337 "GD.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *_pdl_to_gd_image_lut = \&PDL::_pdl_to_gd_image_lut; #line 343 "GD.pm" #line 718 "GD.pd" =head2 read_png_lut( $filename ) Reads a color LUT from an already-existing palette PNG file. =cut sub read_png_lut { my $filename = shift; my $lut = zeroes(byte, 3, 256); _read_png_lut($lut, $filename); return $lut; } # End of read_png_lut()... #line 363 "GD.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *_read_png_lut = \&PDL::_read_png_lut; #line 369 "GD.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *_gdImageColorAllocates = \&PDL::_gdImageColorAllocates; #line 375 "GD.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *_gdImageColorAllocateAlphas = \&PDL::_gdImageColorAllocateAlphas; #line 381 "GD.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *_gdImageSetPixels = \&PDL::_gdImageSetPixels; #line 387 "GD.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *_gdImageLines = \&PDL::_gdImageLines; #line 393 "GD.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *_gdImageDashedLines = \&PDL::_gdImageDashedLines; #line 399 "GD.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *_gdImageRectangles = \&PDL::_gdImageRectangles; #line 405 "GD.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *_gdImageFilledRectangles = \&PDL::_gdImageFilledRectangles; #line 411 "GD.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *_gdImageFilledArcs = \&PDL::_gdImageFilledArcs; #line 417 "GD.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *_gdImageArcs = \&PDL::_gdImageArcs; #line 423 "GD.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *_gdImageFilledEllipses = \&PDL::_gdImageFilledEllipses; #line 429 "GD.pm" #line 805 "GD.pd" =head1 OO INTERFACE Object Oriented interface to the GD image library. =head1 SYNOPSIS # Open an existing file: # my $gd = PDL::IO::GD->new( { filename => "test.png" } ); # Query the x and y sizes: my $x = $gd->SX(); my $y = $gd->SY(); # Grab the PDL of the data: my $pdl = $gd->to_pdl(); # Kill this thing: $gd->DESTROY(); # Create a new object: # my $im = PDL::IO::GD->new( { x => 300, y => 300 } ); # Allocate some colors: # my $black = $im->ColorAllocate( 0, 0, 0 ); my $red = $im->ColorAllocate( 255, 0, 0 ); my $green = $im->ColorAllocate( 0, 255, 0 ); my $blue = $im->ColorAllocate( 0, 0, 255 ); # Draw a rectangle: $im->Rectangle( 10, 10, 290, 290, $red ); # Add some text: $im->String( gdFontGetLarge(), 20, 20, "Test Large Font!", $green ); # Write the output file: $im->write_Png( "test2.png" ); =head1 DESCRIPTION This is the Object-Oriented interface from PDL to the GD image library. See L for more information on the GD library and how it works. =head2 IMPLEMENTATION NOTES Surprisingly enough, this interface has nothing to do with the other Perl->GD interface module, aka 'GD' (as in 'use GD;'). This is done from scratch over the years. Requires at least version 2.0.22 of the GD library, but it's only been thoroughly tested with gd-2.0.33, so it would be best to use that. The 2.0.22 requirement has to do with a change in GD's font handling functions, so if you don't use those, then don't worry about it. I should also add, the statement about "thoroughly tested" above is mostly a joke. This OO interface is very young, and it has I been tested at all, so if something breaks, email me and I'll get it fixed ASAP (for me). Functions that manipulate and query the image objects generally have a 'gdImage' prefix on the function names (ex: gdImageString()). I've created aliases here for all of those member functions so you don't have to keep typing 'gdImage' in your code, but the long version are in there as well. =head1 METHODS =cut use PDL; use PDL::Slices; use PDL::IO::Misc; # # Some helper functions: # sub _pkg_name { return "PDL::IO::GD::" . (shift) . "()"; } # ID a file type from it's filename: sub _id_image_file { my $filename = shift; return 'png' if( $filename =~ /\.png$/ ); return 'jpg' if( $filename =~ /\.jpe?g$/ ); return 'wbmp' if( $filename =~ /\.w?bmp$/ ); return 'gd' if( $filename =~ /\.gd$/ ); return 'gd2' if( $filename =~ /\.gd2$/ ); return 'gif' if( $filename =~ /\.gif$/ ); return 'xbm' if( $filename =~ /\.xbm$/ ); return undef; } # End of _id_image_file()... # Load a new file up (don't read it yet): sub _img_ptr_from_file { my $filename = shift; my $type = shift; return _gdImageCreateFromPng( $filename ) if( $type eq 'png' ); return _gdImageCreateFromJpeg( $filename ) if( $type eq 'jpg' ); return _gdImageCreateFromWBMP( $filename ) if( $type eq 'wbmp' ); return _gdImageCreateFromGd( $filename ) if( $type eq 'gd' ); return _gdImageCreateFromGd2( $filename ) if( $type eq 'gd2' ); return _gdImageCreateFromGif( $filename ) if( $type eq 'gif' ); return _gdImageCreateFromXbm( $filename ) if( $type eq 'xbm' ); return undef; } # End of _img_ptr_from_file()... # ID a file type from it's "magic" header in the image data: sub _id_image_data { my $data = shift; my $magic = substr($data,0,4); return 'png' if( $magic eq "\x89PNG" ); return 'jpg' if( $magic eq "\377\330\377\340" ); return 'jpg' if( $magic eq "\377\330\377\341" ); return 'jpg' if( $magic eq "\377\330\377\356" ); return 'gif' if( $magic eq "GIF8" ); return 'gd2' if( $magic eq "gd2\000" ); # Still need filters for WBMP and .gd! return undef; } # End of _id_image_data()... # Load a new data scalar up: sub _img_ptr_from_data { my $data = shift; my $type = shift; return _gdImageCreateFromPngPtr( $data ) if( $type eq 'png' ); return _gdImageCreateFromJpegPtr( $data ) if( $type eq 'jpg' ); return _gdImageCreateFromWBMPPtr( $data ) if( $type eq 'wbmp' ); return _gdImageCreateFromGdPtr( $data ) if( $type eq 'gd' ); return _gdImageCreateFromGd2Ptr( $data ) if( $type eq 'gd2' ); return _gdImageCreateFromGifPtr( $data ) if( $type eq 'gif' ); return undef; } # End of _img_ptr_from_data()... =head2 new Creates a new PDL::IO::GD object. Accepts a hash describing how to create the object. Accepts a single hash ( with curly braces ), an inline hash (the same, but without the braces) or a single string interpreted as a filename. Thus the following are all equivalent: PDL::IO::GD->new( {filename => 'image.png'} ); PDL::IO::GD->new( filename => 'image.png' ); PDL::IO::GD->new( 'image.png' ); If the hash has: pdl => $pdl_var (lut => $lut_ndarray) Then a new GD is created from that PDL variable. filename => $file Then a new GD is created from the image file. x => $num, y => $num Then a new GD is created as a palette image, with size x, y x => $num, y => $num, true_color => 1 Then a new GD is created as a true color image, with size x, y data => $scalar (type => $typename) Then a new GD is created from the file data stored in $scalar. If no type is given, then it will try to guess the type of the data, but this will not work for WBMP and gd image types. For those types, you _must_ specify the type of the data, or the operation will fail. Valid types are: 'jpg', 'png', 'gif', 'gd', 'gd2', 'wbmp'. Example: my $gd = PDL::IO::GD->new({ pdl => $pdl_var }); my $gd = PDL::IO::GD->new({ pdl => $pdl_var, lut => $lut_ndarray }); my $gd = PDL::IO::GD->new({ filename => "image.png" }); my $gd = PDL::IO::GD->new({ x => 100, y => 100 }); my $gd = PDL::IO::GD->new({ x => 100, y => 100, true_color => 1 }); my $gd = PDL::IO::GD->new({ data => $imageData }); my $gd = PDL::IO::GD->new({ data => $imageData, type => 'wbmp' }); =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; #my $self = $class->SUPER::new( @_ ); my $self = {}; my $sub = _pkg_name( "new" ); # Figure out our options: # I want a single hash. I handle several cases here my $options; if( @_ == 1 && ref $_[0] eq 'HASH' ) { # single hash argument. Just take it $options = shift; } elsif( @_ == 1 && ! ref $_[0] ) { # single scalar argument. Treat it as a filename by default my $filename = shift; $options = { filename => $filename }; } else { # the only other acceptable option is an inline hash. This is valid if I # have an even number of arguments, and the even-indexed ones (the keys) # are scalars if( @_ % 2 == 0 ) { my @pairs = @_; my $Npairs = scalar(@pairs)/2; use List::Util 'none'; if( none { ref $pairs[2*$_] } 0..$Npairs-1 ) { # treat the arguments as a hash $options = { @pairs } } } } if( !defined $options ) { die <{pdl} ) ) { # Create it from a PDL variable: my $pdl = $options->{pdl}; $pdl->make_physical(); my $num_dims = scalar( $pdl->dims() ); if( $num_dims == 2 ) { if( defined( $options->{lut} ) ) { my $ptr = zeroes( longlong, 1 ); my $lut = $options->{lut}; _pdl_to_gd_image_lut( $pdl, $lut, $ptr ); # print STDERR "in new (with lut), setting IMG_PTR to " . $ptr->at(0) . "\n"; $self->{IMG_PTR} = $ptr->at(0); $ptr = null; die "$sub: _pdl_to_gd_image_lut() failed!\n" if( $self->{IMG_PTR} == 0 ); } else { my $ptr = zeroes( longlong, 1 ); my $lut = sequence(byte, 255)->slice("*3,:"); _pdl_to_gd_image_lut( $pdl, $lut, $ptr ); # print STDERR "in new (no lut), setting IMG_PTR to " . $ptr->at(0) . "\n"; $self->{IMG_PTR} = $ptr->at(0); $ptr = null; die "$sub: _pdl_to_gd_image_lut() failed!\n" if( $self->{IMG_PTR} == 0 ); } } elsif( $num_dims == 3 ) { my $ptr = zeroes( longlong, 1 ); _pdl_to_gd_image_true( $pdl, $ptr ); # print STDERR "in new (ndims=3), setting IMG_PTR to " . $ptr->at(0) . "\n"; $self->{IMG_PTR} = $ptr->at(0); $ptr = null; die "$sub: _pdl_to_gd_image_true() failed!\n" if( $self->{IMG_PTR} == 0 ); } else { die "Can't create a PDL::IO::GD from a PDL with bad dims!\n"; } } elsif( exists( $options->{filename} ) ) { # Create it from a file: if( !defined $options->{filename} ) { die "PDL::IO::GD::new got an undefined filename. Giving up.\n"; } # Figure out what type of file it is: $self->{input_type} = _id_image_file( $options->{filename} ) or die "$sub: Can't determine image type of filename => \'$options->{filename}\'!\n"; # Read in the file: $self->{IMG_PTR} = _img_ptr_from_file( $options->{filename}, $self->{input_type} ) or die "$sub: Can't read in the input file!\n"; } elsif( defined( $options->{x} ) && defined( $options->{y} ) ) { # Create an empty image: my $done = 0; if( defined( $options->{true_color} ) ) { if( $options->{true_color} ) { # Create an empty true color image: $self->{IMG_PTR} = _gdImageCreateTrueColor( $options->{x}, $options->{y} ); die "$sub: _gdImageCreateTrueColor() failed!\n" if( $self->{IMG_PTR} == 0 ); $done = 1; } } unless( $done ) { # Create an empty palette image: $self->{IMG_PTR} = _gdImageCreatePalette( $options->{x}, $options->{y} ); die "$sub: _gdImageCreatePalette() failed!\n" if( $self->{IMG_PTR} == 0 ); } } elsif( defined( $options->{data} ) ) { # Create an image from the given image data: # Figure out what type of file it is: if( defined( $options->{type} ) && ( $options->{type} eq 'jpg' || $options->{type} eq 'png' || $options->{type} eq 'gif' || $options->{type} eq 'wbmp' || $options->{type} eq 'gd' || $options->{type} eq 'gd2' ) ) { $self->{input_type} = $options->{type}; } else { $self->{input_type} = _id_image_data( $options->{data} ) or die "$sub: Can't determine image type given data!\n"; } # Load the data: $self->{IMG_PTR} = _img_ptr_from_data( $options->{data}, $self->{input_type} ) or die "$sub: Can't load the input image data!\n"; } # Bless and return: # bless ($self, $class); return $self; } # End of new()... =head2 to_pdl When you're done playing with your GDImage and want an ndarray back, use this function to return one. =cut sub to_pdl { my $self = shift; my $sub = _pkg_name( "to_pdl" ); my $x = $self->gdImageSX(); my $y = $self->gdImageSY(); if( $self->gdImageTrueColor() ) { my $pdl = zeroes(byte, $x, $y, 3); _gd_image_to_pdl_true( $pdl, $self->{IMG_PTR} ); return $pdl; } my $pdl = zeroes(byte, $x, $y); _gd_image_to_pdl( $pdl, $self->{IMG_PTR} ); return $pdl; } # End of to_pdl()... =head2 apply_lut( $lut(ndarray) ) Does a $im->ColorAllocate() for and entire LUT ndarray at once. The LUT ndarray format is the same as for the general interface above. =cut sub apply_lut { my $self = shift; my $lut = shift; # Let the PDL threading engine sort this out: $self->ColorAllocates( $lut->slice("(0),:"), $lut->slice("(1),:"), $lut->slice("(2),:") ); } # End of apply_lut()... sub DESTROY { my $self = shift; my $sub = _pkg_name( "DESTROY" ); #print STDERR sprintf("$sub: destroying gdImagePtr: 0x%p (%d) (%ld) (%lld)!\n", $self->{IMG_PTR}, $self->{IMG_PTR},$self->{IMG_PTR},$self->{IMG_PTR}); if( defined( $self->{IMG_PTR} ) ) { _gdImageDestroy( $self->{IMG_PTR} ); delete( $self->{IMG_PTR} ); } } # End of DESTROY()... =head2 WARNING: All of the docs below this point are auto-generated (not to mention the actual code), so read with a grain of salt, and B check the main GD documentation about how that function works and what it does. =cut #line 906 "GD.pm" #line 1748 "GD.pd" =head2 write_Png $image->write_Png( $filename ) =cut sub write_Png { my $self = shift; return _gdImagePng ( $self->{IMG_PTR}, @_ ); } # End of write_Png()... #line 923 "GD.pm" #line 1748 "GD.pd" =head2 write_PngEx $image->write_PngEx( $filename, $level ) =cut sub write_PngEx { my $self = shift; return _gdImagePngEx ( $self->{IMG_PTR}, @_ ); } # End of write_PngEx()... #line 940 "GD.pm" #line 1748 "GD.pd" =head2 write_WBMP $image->write_WBMP( $fg, $filename ) =cut sub write_WBMP { my $self = shift; return _gdImageWBMP ( $self->{IMG_PTR}, @_ ); } # End of write_WBMP()... #line 957 "GD.pm" #line 1748 "GD.pd" =head2 write_Jpeg $image->write_Jpeg( $filename, $quality ) =cut sub write_Jpeg { my $self = shift; return _gdImageJpeg ( $self->{IMG_PTR}, @_ ); } # End of write_Jpeg()... #line 974 "GD.pm" #line 1748 "GD.pd" =head2 write_Gd $image->write_Gd( $filename ) =cut sub write_Gd { my $self = shift; return _gdImageGd ( $self->{IMG_PTR}, @_ ); } # End of write_Gd()... #line 991 "GD.pm" #line 1748 "GD.pd" =head2 write_Gd2 $image->write_Gd2( $filename, $cs, $fmt ) =cut sub write_Gd2 { my $self = shift; return _gdImageGd2 ( $self->{IMG_PTR}, @_ ); } # End of write_Gd2()... #line 1008 "GD.pm" #line 1748 "GD.pd" =head2 write_Gif $image->write_Gif( $filename ) =cut sub write_Gif { my $self = shift; return _gdImageGif ( $self->{IMG_PTR}, @_ ); } # End of write_Gif()... #line 1025 "GD.pm" #line 1860 "GD.pd" =head2 get_Png_data $image->get_Png_data( ) =cut sub get_Png_data { my $self = shift; return _gdImagePngPtr ( $self->{IMG_PTR}, @_ ); } # End of get_Png_data()... #line 1042 "GD.pm" #line 1860 "GD.pd" =head2 get_PngEx_data $image->get_PngEx_data( $level ) =cut sub get_PngEx_data { my $self = shift; return _gdImagePngPtrEx ( $self->{IMG_PTR}, @_ ); } # End of get_PngEx_data()... #line 1059 "GD.pm" #line 1860 "GD.pd" =head2 get_WBMP_data $image->get_WBMP_data( $fg ) =cut sub get_WBMP_data { my $self = shift; return _gdImageWBMPPtr ( $self->{IMG_PTR}, @_ ); } # End of get_WBMP_data()... #line 1076 "GD.pm" #line 1860 "GD.pd" =head2 get_Jpeg_data $image->get_Jpeg_data( $quality ) =cut sub get_Jpeg_data { my $self = shift; return _gdImageJpegPtr ( $self->{IMG_PTR}, @_ ); } # End of get_Jpeg_data()... #line 1093 "GD.pm" #line 1860 "GD.pd" =head2 get_Gd_data $image->get_Gd_data( ) =cut sub get_Gd_data { my $self = shift; return _gdImageGdPtr ( $self->{IMG_PTR}, @_ ); } # End of get_Gd_data()... #line 1110 "GD.pm" #line 1860 "GD.pd" =head2 get_Gd2_data $image->get_Gd2_data( $cs, $fmt ) =cut sub get_Gd2_data { my $self = shift; return _gdImageGd2Ptr ( $self->{IMG_PTR}, @_ ); } # End of get_Gd2_data()... #line 1127 "GD.pm" #line 1960 "GD.pd" =head2 SetPixel $image->SetPixel( $x, $y, $color ) Alias for gdImageSetPixel. =cut sub SetPixel { return gdImageSetPixel ( @_ ); } # End of SetPixel()... =head2 gdImageSetPixel $image->gdImageSetPixel( $x, $y, $color ) =cut sub gdImageSetPixel { my $self = shift; return _gdImageSetPixel ( $self->{IMG_PTR}, @_ ); } # End of gdImageSetPixel()... #line 1159 "GD.pm" #line 1960 "GD.pd" =head2 GetPixel $image->GetPixel( $x, $y ) Alias for gdImageGetPixel. =cut sub GetPixel { return gdImageGetPixel ( @_ ); } # End of GetPixel()... =head2 gdImageGetPixel $image->gdImageGetPixel( $x, $y ) =cut sub gdImageGetPixel { my $self = shift; return _gdImageGetPixel ( $self->{IMG_PTR}, @_ ); } # End of gdImageGetPixel()... #line 1191 "GD.pm" #line 1960 "GD.pd" =head2 AABlend $image->AABlend( ) Alias for gdImageAABlend. =cut sub AABlend { return gdImageAABlend ( @_ ); } # End of AABlend()... =head2 gdImageAABlend $image->gdImageAABlend( ) =cut sub gdImageAABlend { my $self = shift; return _gdImageAABlend ( $self->{IMG_PTR}, @_ ); } # End of gdImageAABlend()... #line 1223 "GD.pm" #line 1960 "GD.pd" =head2 Line $image->Line( $x1, $y1, $x2, $y2, $color ) Alias for gdImageLine. =cut sub Line { return gdImageLine ( @_ ); } # End of Line()... =head2 gdImageLine $image->gdImageLine( $x1, $y1, $x2, $y2, $color ) =cut sub gdImageLine { my $self = shift; return _gdImageLine ( $self->{IMG_PTR}, @_ ); } # End of gdImageLine()... #line 1255 "GD.pm" #line 1960 "GD.pd" =head2 DashedLine $image->DashedLine( $x1, $y1, $x2, $y2, $color ) Alias for gdImageDashedLine. =cut sub DashedLine { return gdImageDashedLine ( @_ ); } # End of DashedLine()... =head2 gdImageDashedLine $image->gdImageDashedLine( $x1, $y1, $x2, $y2, $color ) =cut sub gdImageDashedLine { my $self = shift; return _gdImageDashedLine ( $self->{IMG_PTR}, @_ ); } # End of gdImageDashedLine()... #line 1287 "GD.pm" #line 1960 "GD.pd" =head2 Rectangle $image->Rectangle( $x1, $y1, $x2, $y2, $color ) Alias for gdImageRectangle. =cut sub Rectangle { return gdImageRectangle ( @_ ); } # End of Rectangle()... =head2 gdImageRectangle $image->gdImageRectangle( $x1, $y1, $x2, $y2, $color ) =cut sub gdImageRectangle { my $self = shift; return _gdImageRectangle ( $self->{IMG_PTR}, @_ ); } # End of gdImageRectangle()... #line 1319 "GD.pm" #line 1960 "GD.pd" =head2 FilledRectangle $image->FilledRectangle( $x1, $y1, $x2, $y2, $color ) Alias for gdImageFilledRectangle. =cut sub FilledRectangle { return gdImageFilledRectangle ( @_ ); } # End of FilledRectangle()... =head2 gdImageFilledRectangle $image->gdImageFilledRectangle( $x1, $y1, $x2, $y2, $color ) =cut sub gdImageFilledRectangle { my $self = shift; return _gdImageFilledRectangle ( $self->{IMG_PTR}, @_ ); } # End of gdImageFilledRectangle()... #line 1351 "GD.pm" #line 1960 "GD.pd" =head2 SetClip $image->SetClip( $x1, $y1, $x2, $y2 ) Alias for gdImageSetClip. =cut sub SetClip { return gdImageSetClip ( @_ ); } # End of SetClip()... =head2 gdImageSetClip $image->gdImageSetClip( $x1, $y1, $x2, $y2 ) =cut sub gdImageSetClip { my $self = shift; return _gdImageSetClip ( $self->{IMG_PTR}, @_ ); } # End of gdImageSetClip()... #line 1383 "GD.pm" #line 1960 "GD.pd" =head2 GetClip $image->GetClip( $x1P, $y1P, $x2P, $y2P ) Alias for gdImageGetClip. =cut sub GetClip { return gdImageGetClip ( @_ ); } # End of GetClip()... =head2 gdImageGetClip $image->gdImageGetClip( $x1P, $y1P, $x2P, $y2P ) =cut sub gdImageGetClip { my $self = shift; return _gdImageGetClip ( $self->{IMG_PTR}, @_ ); } # End of gdImageGetClip()... #line 1415 "GD.pm" #line 1960 "GD.pd" =head2 BoundsSafe $image->BoundsSafe( $x, $y ) Alias for gdImageBoundsSafe. =cut sub BoundsSafe { return gdImageBoundsSafe ( @_ ); } # End of BoundsSafe()... =head2 gdImageBoundsSafe $image->gdImageBoundsSafe( $x, $y ) =cut sub gdImageBoundsSafe { my $self = shift; return _gdImageBoundsSafe ( $self->{IMG_PTR}, @_ ); } # End of gdImageBoundsSafe()... #line 1447 "GD.pm" #line 1960 "GD.pd" =head2 Char $image->Char( $f, $x, $y, $c, $color ) Alias for gdImageChar. =cut sub Char { return gdImageChar ( @_ ); } # End of Char()... =head2 gdImageChar $image->gdImageChar( $f, $x, $y, $c, $color ) =cut sub gdImageChar { my $self = shift; return _gdImageChar ( $self->{IMG_PTR}, @_ ); } # End of gdImageChar()... #line 1479 "GD.pm" #line 1960 "GD.pd" =head2 CharUp $image->CharUp( $f, $x, $y, $c, $color ) Alias for gdImageCharUp. =cut sub CharUp { return gdImageCharUp ( @_ ); } # End of CharUp()... =head2 gdImageCharUp $image->gdImageCharUp( $f, $x, $y, $c, $color ) =cut sub gdImageCharUp { my $self = shift; return _gdImageCharUp ( $self->{IMG_PTR}, @_ ); } # End of gdImageCharUp()... #line 1511 "GD.pm" #line 1960 "GD.pd" =head2 String $image->String( $f, $x, $y, $s, $color ) Alias for gdImageString. =cut sub String { return gdImageString ( @_ ); } # End of String()... =head2 gdImageString $image->gdImageString( $f, $x, $y, $s, $color ) =cut sub gdImageString { my $self = shift; return _gdImageString ( $self->{IMG_PTR}, @_ ); } # End of gdImageString()... #line 1543 "GD.pm" #line 1960 "GD.pd" =head2 StringUp $image->StringUp( $f, $x, $y, $s, $color ) Alias for gdImageStringUp. =cut sub StringUp { return gdImageStringUp ( @_ ); } # End of StringUp()... =head2 gdImageStringUp $image->gdImageStringUp( $f, $x, $y, $s, $color ) =cut sub gdImageStringUp { my $self = shift; return _gdImageStringUp ( $self->{IMG_PTR}, @_ ); } # End of gdImageStringUp()... #line 1575 "GD.pm" #line 1960 "GD.pd" =head2 String16 $image->String16( $f, $x, $y, $s, $color ) Alias for gdImageString16. =cut sub String16 { return gdImageString16 ( @_ ); } # End of String16()... =head2 gdImageString16 $image->gdImageString16( $f, $x, $y, $s, $color ) =cut sub gdImageString16 { my $self = shift; return _gdImageString16 ( $self->{IMG_PTR}, @_ ); } # End of gdImageString16()... #line 1607 "GD.pm" #line 1960 "GD.pd" =head2 StringUp16 $image->StringUp16( $f, $x, $y, $s, $color ) Alias for gdImageStringUp16. =cut sub StringUp16 { return gdImageStringUp16 ( @_ ); } # End of StringUp16()... =head2 gdImageStringUp16 $image->gdImageStringUp16( $f, $x, $y, $s, $color ) =cut sub gdImageStringUp16 { my $self = shift; return _gdImageStringUp16 ( $self->{IMG_PTR}, @_ ); } # End of gdImageStringUp16()... #line 1639 "GD.pm" #line 1960 "GD.pd" =head2 Polygon $image->Polygon( $p, $n, $c ) Alias for gdImagePolygon. =cut sub Polygon { return gdImagePolygon ( @_ ); } # End of Polygon()... =head2 gdImagePolygon $image->gdImagePolygon( $p, $n, $c ) =cut sub gdImagePolygon { my $self = shift; return _gdImagePolygon ( $self->{IMG_PTR}, @_ ); } # End of gdImagePolygon()... #line 1671 "GD.pm" #line 1960 "GD.pd" =head2 FilledPolygon $image->FilledPolygon( $p, $n, $c ) Alias for gdImageFilledPolygon. =cut sub FilledPolygon { return gdImageFilledPolygon ( @_ ); } # End of FilledPolygon()... =head2 gdImageFilledPolygon $image->gdImageFilledPolygon( $p, $n, $c ) =cut sub gdImageFilledPolygon { my $self = shift; return _gdImageFilledPolygon ( $self->{IMG_PTR}, @_ ); } # End of gdImageFilledPolygon()... #line 1703 "GD.pm" #line 1960 "GD.pd" =head2 ColorAllocate $image->ColorAllocate( $r, $g, $b ) Alias for gdImageColorAllocate. =cut sub ColorAllocate { return gdImageColorAllocate ( @_ ); } # End of ColorAllocate()... =head2 gdImageColorAllocate $image->gdImageColorAllocate( $r, $g, $b ) =cut sub gdImageColorAllocate { my $self = shift; return _gdImageColorAllocate ( $self->{IMG_PTR}, @_ ); } # End of gdImageColorAllocate()... #line 1735 "GD.pm" #line 1960 "GD.pd" =head2 ColorAllocateAlpha $image->ColorAllocateAlpha( $r, $g, $b, $a ) Alias for gdImageColorAllocateAlpha. =cut sub ColorAllocateAlpha { return gdImageColorAllocateAlpha ( @_ ); } # End of ColorAllocateAlpha()... =head2 gdImageColorAllocateAlpha $image->gdImageColorAllocateAlpha( $r, $g, $b, $a ) =cut sub gdImageColorAllocateAlpha { my $self = shift; return _gdImageColorAllocateAlpha ( $self->{IMG_PTR}, @_ ); } # End of gdImageColorAllocateAlpha()... #line 1767 "GD.pm" #line 1960 "GD.pd" =head2 ColorClosest $image->ColorClosest( $r, $g, $b ) Alias for gdImageColorClosest. =cut sub ColorClosest { return gdImageColorClosest ( @_ ); } # End of ColorClosest()... =head2 gdImageColorClosest $image->gdImageColorClosest( $r, $g, $b ) =cut sub gdImageColorClosest { my $self = shift; return _gdImageColorClosest ( $self->{IMG_PTR}, @_ ); } # End of gdImageColorClosest()... #line 1799 "GD.pm" #line 1960 "GD.pd" =head2 ColorClosestAlpha $image->ColorClosestAlpha( $r, $g, $b, $a ) Alias for gdImageColorClosestAlpha. =cut sub ColorClosestAlpha { return gdImageColorClosestAlpha ( @_ ); } # End of ColorClosestAlpha()... =head2 gdImageColorClosestAlpha $image->gdImageColorClosestAlpha( $r, $g, $b, $a ) =cut sub gdImageColorClosestAlpha { my $self = shift; return _gdImageColorClosestAlpha ( $self->{IMG_PTR}, @_ ); } # End of gdImageColorClosestAlpha()... #line 1831 "GD.pm" #line 1960 "GD.pd" =head2 ColorClosestHWB $image->ColorClosestHWB( $r, $g, $b ) Alias for gdImageColorClosestHWB. =cut sub ColorClosestHWB { return gdImageColorClosestHWB ( @_ ); } # End of ColorClosestHWB()... =head2 gdImageColorClosestHWB $image->gdImageColorClosestHWB( $r, $g, $b ) =cut sub gdImageColorClosestHWB { my $self = shift; return _gdImageColorClosestHWB ( $self->{IMG_PTR}, @_ ); } # End of gdImageColorClosestHWB()... #line 1863 "GD.pm" #line 1960 "GD.pd" =head2 ColorExact $image->ColorExact( $r, $g, $b ) Alias for gdImageColorExact. =cut sub ColorExact { return gdImageColorExact ( @_ ); } # End of ColorExact()... =head2 gdImageColorExact $image->gdImageColorExact( $r, $g, $b ) =cut sub gdImageColorExact { my $self = shift; return _gdImageColorExact ( $self->{IMG_PTR}, @_ ); } # End of gdImageColorExact()... #line 1895 "GD.pm" #line 1960 "GD.pd" =head2 ColorExactAlpha $image->ColorExactAlpha( $r, $g, $b, $a ) Alias for gdImageColorExactAlpha. =cut sub ColorExactAlpha { return gdImageColorExactAlpha ( @_ ); } # End of ColorExactAlpha()... =head2 gdImageColorExactAlpha $image->gdImageColorExactAlpha( $r, $g, $b, $a ) =cut sub gdImageColorExactAlpha { my $self = shift; return _gdImageColorExactAlpha ( $self->{IMG_PTR}, @_ ); } # End of gdImageColorExactAlpha()... #line 1927 "GD.pm" #line 1960 "GD.pd" =head2 ColorResolve $image->ColorResolve( $r, $g, $b ) Alias for gdImageColorResolve. =cut sub ColorResolve { return gdImageColorResolve ( @_ ); } # End of ColorResolve()... =head2 gdImageColorResolve $image->gdImageColorResolve( $r, $g, $b ) =cut sub gdImageColorResolve { my $self = shift; return _gdImageColorResolve ( $self->{IMG_PTR}, @_ ); } # End of gdImageColorResolve()... #line 1959 "GD.pm" #line 1960 "GD.pd" =head2 ColorResolveAlpha $image->ColorResolveAlpha( $r, $g, $b, $a ) Alias for gdImageColorResolveAlpha. =cut sub ColorResolveAlpha { return gdImageColorResolveAlpha ( @_ ); } # End of ColorResolveAlpha()... =head2 gdImageColorResolveAlpha $image->gdImageColorResolveAlpha( $r, $g, $b, $a ) =cut sub gdImageColorResolveAlpha { my $self = shift; return _gdImageColorResolveAlpha ( $self->{IMG_PTR}, @_ ); } # End of gdImageColorResolveAlpha()... #line 1991 "GD.pm" #line 1960 "GD.pd" =head2 ColorDeallocate $image->ColorDeallocate( $color ) Alias for gdImageColorDeallocate. =cut sub ColorDeallocate { return gdImageColorDeallocate ( @_ ); } # End of ColorDeallocate()... =head2 gdImageColorDeallocate $image->gdImageColorDeallocate( $color ) =cut sub gdImageColorDeallocate { my $self = shift; return _gdImageColorDeallocate ( $self->{IMG_PTR}, @_ ); } # End of gdImageColorDeallocate()... #line 2023 "GD.pm" #line 1960 "GD.pd" =head2 TrueColorToPalette $image->TrueColorToPalette( $ditherFlag, $colorsWanted ) Alias for gdImageTrueColorToPalette. =cut sub TrueColorToPalette { return gdImageTrueColorToPalette ( @_ ); } # End of TrueColorToPalette()... =head2 gdImageTrueColorToPalette $image->gdImageTrueColorToPalette( $ditherFlag, $colorsWanted ) =cut sub gdImageTrueColorToPalette { my $self = shift; return _gdImageTrueColorToPalette ( $self->{IMG_PTR}, @_ ); } # End of gdImageTrueColorToPalette()... #line 2055 "GD.pm" #line 1960 "GD.pd" =head2 ColorTransparent $image->ColorTransparent( $color ) Alias for gdImageColorTransparent. =cut sub ColorTransparent { return gdImageColorTransparent ( @_ ); } # End of ColorTransparent()... =head2 gdImageColorTransparent $image->gdImageColorTransparent( $color ) =cut sub gdImageColorTransparent { my $self = shift; return _gdImageColorTransparent ( $self->{IMG_PTR}, @_ ); } # End of gdImageColorTransparent()... #line 2087 "GD.pm" #line 1960 "GD.pd" =head2 FilledArc $image->FilledArc( $cx, $cy, $w, $h, $s, $e, $color, $style ) Alias for gdImageFilledArc. =cut sub FilledArc { return gdImageFilledArc ( @_ ); } # End of FilledArc()... =head2 gdImageFilledArc $image->gdImageFilledArc( $cx, $cy, $w, $h, $s, $e, $color, $style ) =cut sub gdImageFilledArc { my $self = shift; return _gdImageFilledArc ( $self->{IMG_PTR}, @_ ); } # End of gdImageFilledArc()... #line 2119 "GD.pm" #line 1960 "GD.pd" =head2 Arc $image->Arc( $cx, $cy, $w, $h, $s, $e, $color ) Alias for gdImageArc. =cut sub Arc { return gdImageArc ( @_ ); } # End of Arc()... =head2 gdImageArc $image->gdImageArc( $cx, $cy, $w, $h, $s, $e, $color ) =cut sub gdImageArc { my $self = shift; return _gdImageArc ( $self->{IMG_PTR}, @_ ); } # End of gdImageArc()... #line 2151 "GD.pm" #line 1960 "GD.pd" =head2 FilledEllipse $image->FilledEllipse( $cx, $cy, $w, $h, $color ) Alias for gdImageFilledEllipse. =cut sub FilledEllipse { return gdImageFilledEllipse ( @_ ); } # End of FilledEllipse()... =head2 gdImageFilledEllipse $image->gdImageFilledEllipse( $cx, $cy, $w, $h, $color ) =cut sub gdImageFilledEllipse { my $self = shift; return _gdImageFilledEllipse ( $self->{IMG_PTR}, @_ ); } # End of gdImageFilledEllipse()... #line 2183 "GD.pm" #line 1960 "GD.pd" =head2 FillToBorder $image->FillToBorder( $x, $y, $border, $color ) Alias for gdImageFillToBorder. =cut sub FillToBorder { return gdImageFillToBorder ( @_ ); } # End of FillToBorder()... =head2 gdImageFillToBorder $image->gdImageFillToBorder( $x, $y, $border, $color ) =cut sub gdImageFillToBorder { my $self = shift; return _gdImageFillToBorder ( $self->{IMG_PTR}, @_ ); } # End of gdImageFillToBorder()... #line 2215 "GD.pm" #line 1960 "GD.pd" =head2 Fill $image->Fill( $x, $y, $color ) Alias for gdImageFill. =cut sub Fill { return gdImageFill ( @_ ); } # End of Fill()... =head2 gdImageFill $image->gdImageFill( $x, $y, $color ) =cut sub gdImageFill { my $self = shift; return _gdImageFill ( $self->{IMG_PTR}, @_ ); } # End of gdImageFill()... #line 2247 "GD.pm" #line 1960 "GD.pd" =head2 CopyRotated $image->CopyRotated( $dstX, $dstY, $srcX, $srcY, $srcWidth, $srcHeight, $angle ) Alias for gdImageCopyRotated. =cut sub CopyRotated { return gdImageCopyRotated ( @_ ); } # End of CopyRotated()... =head2 gdImageCopyRotated $image->gdImageCopyRotated( $dstX, $dstY, $srcX, $srcY, $srcWidth, $srcHeight, $angle ) =cut sub gdImageCopyRotated { my $self = shift; return _gdImageCopyRotated ( $self->{IMG_PTR}, @_ ); } # End of gdImageCopyRotated()... #line 2279 "GD.pm" #line 1960 "GD.pd" =head2 SetBrush $image->SetBrush( ) Alias for gdImageSetBrush. =cut sub SetBrush { return gdImageSetBrush ( @_ ); } # End of SetBrush()... =head2 gdImageSetBrush $image->gdImageSetBrush( ) =cut sub gdImageSetBrush { my $self = shift; return _gdImageSetBrush ( $self->{IMG_PTR}, @_ ); } # End of gdImageSetBrush()... #line 2311 "GD.pm" #line 1960 "GD.pd" =head2 SetTile $image->SetTile( ) Alias for gdImageSetTile. =cut sub SetTile { return gdImageSetTile ( @_ ); } # End of SetTile()... =head2 gdImageSetTile $image->gdImageSetTile( ) =cut sub gdImageSetTile { my $self = shift; return _gdImageSetTile ( $self->{IMG_PTR}, @_ ); } # End of gdImageSetTile()... #line 2343 "GD.pm" #line 1960 "GD.pd" =head2 SetAntiAliased $image->SetAntiAliased( $c ) Alias for gdImageSetAntiAliased. =cut sub SetAntiAliased { return gdImageSetAntiAliased ( @_ ); } # End of SetAntiAliased()... =head2 gdImageSetAntiAliased $image->gdImageSetAntiAliased( $c ) =cut sub gdImageSetAntiAliased { my $self = shift; return _gdImageSetAntiAliased ( $self->{IMG_PTR}, @_ ); } # End of gdImageSetAntiAliased()... #line 2375 "GD.pm" #line 1960 "GD.pd" =head2 SetAntiAliasedDontBlend $image->SetAntiAliasedDontBlend( $c, $dont_blend ) Alias for gdImageSetAntiAliasedDontBlend. =cut sub SetAntiAliasedDontBlend { return gdImageSetAntiAliasedDontBlend ( @_ ); } # End of SetAntiAliasedDontBlend()... =head2 gdImageSetAntiAliasedDontBlend $image->gdImageSetAntiAliasedDontBlend( $c, $dont_blend ) =cut sub gdImageSetAntiAliasedDontBlend { my $self = shift; return _gdImageSetAntiAliasedDontBlend ( $self->{IMG_PTR}, @_ ); } # End of gdImageSetAntiAliasedDontBlend()... #line 2407 "GD.pm" #line 1960 "GD.pd" =head2 SetStyle $image->SetStyle( $style, $noOfPixels ) Alias for gdImageSetStyle. =cut sub SetStyle { return gdImageSetStyle ( @_ ); } # End of SetStyle()... =head2 gdImageSetStyle $image->gdImageSetStyle( $style, $noOfPixels ) =cut sub gdImageSetStyle { my $self = shift; return _gdImageSetStyle ( $self->{IMG_PTR}, @_ ); } # End of gdImageSetStyle()... #line 2439 "GD.pm" #line 1960 "GD.pd" =head2 SetThickness $image->SetThickness( $thickness ) Alias for gdImageSetThickness. =cut sub SetThickness { return gdImageSetThickness ( @_ ); } # End of SetThickness()... =head2 gdImageSetThickness $image->gdImageSetThickness( $thickness ) =cut sub gdImageSetThickness { my $self = shift; return _gdImageSetThickness ( $self->{IMG_PTR}, @_ ); } # End of gdImageSetThickness()... #line 2471 "GD.pm" #line 1960 "GD.pd" =head2 Interlace $image->Interlace( $interlaceArg ) Alias for gdImageInterlace. =cut sub Interlace { return gdImageInterlace ( @_ ); } # End of Interlace()... =head2 gdImageInterlace $image->gdImageInterlace( $interlaceArg ) =cut sub gdImageInterlace { my $self = shift; return _gdImageInterlace ( $self->{IMG_PTR}, @_ ); } # End of gdImageInterlace()... #line 2503 "GD.pm" #line 1960 "GD.pd" =head2 AlphaBlending $image->AlphaBlending( $alphaBlendingArg ) Alias for gdImageAlphaBlending. =cut sub AlphaBlending { return gdImageAlphaBlending ( @_ ); } # End of AlphaBlending()... =head2 gdImageAlphaBlending $image->gdImageAlphaBlending( $alphaBlendingArg ) =cut sub gdImageAlphaBlending { my $self = shift; return _gdImageAlphaBlending ( $self->{IMG_PTR}, @_ ); } # End of gdImageAlphaBlending()... #line 2535 "GD.pm" #line 1960 "GD.pd" =head2 SaveAlpha $image->SaveAlpha( $saveAlphaArg ) Alias for gdImageSaveAlpha. =cut sub SaveAlpha { return gdImageSaveAlpha ( @_ ); } # End of SaveAlpha()... =head2 gdImageSaveAlpha $image->gdImageSaveAlpha( $saveAlphaArg ) =cut sub gdImageSaveAlpha { my $self = shift; return _gdImageSaveAlpha ( $self->{IMG_PTR}, @_ ); } # End of gdImageSaveAlpha()... #line 2567 "GD.pm" #line 1960 "GD.pd" =head2 TrueColor $image->TrueColor( ) Alias for gdImageTrueColor. =cut sub TrueColor { return gdImageTrueColor ( @_ ); } # End of TrueColor()... =head2 gdImageTrueColor $image->gdImageTrueColor( ) =cut sub gdImageTrueColor { my $self = shift; return _gdImageTrueColor ( $self->{IMG_PTR}, @_ ); } # End of gdImageTrueColor()... #line 2599 "GD.pm" #line 1960 "GD.pd" =head2 ColorsTotal $image->ColorsTotal( ) Alias for gdImageColorsTotal. =cut sub ColorsTotal { return gdImageColorsTotal ( @_ ); } # End of ColorsTotal()... =head2 gdImageColorsTotal $image->gdImageColorsTotal( ) =cut sub gdImageColorsTotal { my $self = shift; return _gdImageColorsTotal ( $self->{IMG_PTR}, @_ ); } # End of gdImageColorsTotal()... #line 2631 "GD.pm" #line 1960 "GD.pd" =head2 Red $image->Red( $c ) Alias for gdImageRed. =cut sub Red { return gdImageRed ( @_ ); } # End of Red()... =head2 gdImageRed $image->gdImageRed( $c ) =cut sub gdImageRed { my $self = shift; return _gdImageRed ( $self->{IMG_PTR}, @_ ); } # End of gdImageRed()... #line 2663 "GD.pm" #line 1960 "GD.pd" =head2 Green $image->Green( $c ) Alias for gdImageGreen. =cut sub Green { return gdImageGreen ( @_ ); } # End of Green()... =head2 gdImageGreen $image->gdImageGreen( $c ) =cut sub gdImageGreen { my $self = shift; return _gdImageGreen ( $self->{IMG_PTR}, @_ ); } # End of gdImageGreen()... #line 2695 "GD.pm" #line 1960 "GD.pd" =head2 Blue $image->Blue( $c ) Alias for gdImageBlue. =cut sub Blue { return gdImageBlue ( @_ ); } # End of Blue()... =head2 gdImageBlue $image->gdImageBlue( $c ) =cut sub gdImageBlue { my $self = shift; return _gdImageBlue ( $self->{IMG_PTR}, @_ ); } # End of gdImageBlue()... #line 2727 "GD.pm" #line 1960 "GD.pd" =head2 Alpha $image->Alpha( $c ) Alias for gdImageAlpha. =cut sub Alpha { return gdImageAlpha ( @_ ); } # End of Alpha()... =head2 gdImageAlpha $image->gdImageAlpha( $c ) =cut sub gdImageAlpha { my $self = shift; return _gdImageAlpha ( $self->{IMG_PTR}, @_ ); } # End of gdImageAlpha()... #line 2759 "GD.pm" #line 1960 "GD.pd" =head2 GetTransparent $image->GetTransparent( ) Alias for gdImageGetTransparent. =cut sub GetTransparent { return gdImageGetTransparent ( @_ ); } # End of GetTransparent()... =head2 gdImageGetTransparent $image->gdImageGetTransparent( ) =cut sub gdImageGetTransparent { my $self = shift; return _gdImageGetTransparent ( $self->{IMG_PTR}, @_ ); } # End of gdImageGetTransparent()... #line 2791 "GD.pm" #line 1960 "GD.pd" =head2 GetInterlaced $image->GetInterlaced( ) Alias for gdImageGetInterlaced. =cut sub GetInterlaced { return gdImageGetInterlaced ( @_ ); } # End of GetInterlaced()... =head2 gdImageGetInterlaced $image->gdImageGetInterlaced( ) =cut sub gdImageGetInterlaced { my $self = shift; return _gdImageGetInterlaced ( $self->{IMG_PTR}, @_ ); } # End of gdImageGetInterlaced()... #line 2823 "GD.pm" #line 1960 "GD.pd" =head2 SX $image->SX( ) Alias for gdImageSX. =cut sub SX { return gdImageSX ( @_ ); } # End of SX()... =head2 gdImageSX $image->gdImageSX( ) =cut sub gdImageSX { my $self = shift; return _gdImageSX ( $self->{IMG_PTR}, @_ ); } # End of gdImageSX()... #line 2855 "GD.pm" #line 1960 "GD.pd" =head2 SY $image->SY( ) Alias for gdImageSY. =cut sub SY { return gdImageSY ( @_ ); } # End of SY()... =head2 gdImageSY $image->gdImageSY( ) =cut sub gdImageSY { my $self = shift; return _gdImageSY ( $self->{IMG_PTR}, @_ ); } # End of gdImageSY()... #line 2887 "GD.pm" #line 2061 "GD.pd" =head2 ColorAllocates $image->ColorAllocates( $r(pdl), $g(pdl), $b(pdl) ) Alias for gdImageColorAllocates. =cut sub ColorAllocates { return gdImageColorAllocates ( @_ ); } # End of ColorAllocates()... =head2 gdImageColorAllocates $image->gdImageColorAllocates( $r(pdl), $g(pdl), $b(pdl) ) =cut sub gdImageColorAllocates { my $self = shift; return _gdImageColorAllocates ( @_, $self->{IMG_PTR} ); } # End of gdImageColorAllocates()... #line 2919 "GD.pm" #line 2061 "GD.pd" =head2 ColorAllocateAlphas $image->ColorAllocateAlphas( $r(pdl), $g(pdl), $b(pdl), $a(pdl) ) Alias for gdImageColorAllocateAlphas. =cut sub ColorAllocateAlphas { return gdImageColorAllocateAlphas ( @_ ); } # End of ColorAllocateAlphas()... =head2 gdImageColorAllocateAlphas $image->gdImageColorAllocateAlphas( $r(pdl), $g(pdl), $b(pdl), $a(pdl) ) =cut sub gdImageColorAllocateAlphas { my $self = shift; return _gdImageColorAllocateAlphas ( @_, $self->{IMG_PTR} ); } # End of gdImageColorAllocateAlphas()... #line 2951 "GD.pm" #line 2061 "GD.pd" =head2 SetPixels $image->SetPixels( $x(pdl), $y(pdl), $color(pdl) ) Alias for gdImageSetPixels. =cut sub SetPixels { return gdImageSetPixels ( @_ ); } # End of SetPixels()... =head2 gdImageSetPixels $image->gdImageSetPixels( $x(pdl), $y(pdl), $color(pdl) ) =cut sub gdImageSetPixels { my $self = shift; return _gdImageSetPixels ( @_, $self->{IMG_PTR} ); } # End of gdImageSetPixels()... #line 2983 "GD.pm" #line 2061 "GD.pd" =head2 Lines $image->Lines( $x1(pdl), $y1(pdl), $x2(pdl), $y2(pdl), $color(pdl) ) Alias for gdImageLines. =cut sub Lines { return gdImageLines ( @_ ); } # End of Lines()... =head2 gdImageLines $image->gdImageLines( $x1(pdl), $y1(pdl), $x2(pdl), $y2(pdl), $color(pdl) ) =cut sub gdImageLines { my $self = shift; return _gdImageLines ( @_, $self->{IMG_PTR} ); } # End of gdImageLines()... #line 3015 "GD.pm" #line 2061 "GD.pd" =head2 DashedLines $image->DashedLines( $x1(pdl), $y1(pdl), $x2(pdl), $y2(pdl), $color(pdl) ) Alias for gdImageDashedLines. =cut sub DashedLines { return gdImageDashedLines ( @_ ); } # End of DashedLines()... =head2 gdImageDashedLines $image->gdImageDashedLines( $x1(pdl), $y1(pdl), $x2(pdl), $y2(pdl), $color(pdl) ) =cut sub gdImageDashedLines { my $self = shift; return _gdImageDashedLines ( @_, $self->{IMG_PTR} ); } # End of gdImageDashedLines()... #line 3047 "GD.pm" #line 2061 "GD.pd" =head2 Rectangles $image->Rectangles( $x1(pdl), $y1(pdl), $x2(pdl), $y2(pdl), $color(pdl) ) Alias for gdImageRectangles. =cut sub Rectangles { return gdImageRectangles ( @_ ); } # End of Rectangles()... =head2 gdImageRectangles $image->gdImageRectangles( $x1(pdl), $y1(pdl), $x2(pdl), $y2(pdl), $color(pdl) ) =cut sub gdImageRectangles { my $self = shift; return _gdImageRectangles ( @_, $self->{IMG_PTR} ); } # End of gdImageRectangles()... #line 3079 "GD.pm" #line 2061 "GD.pd" =head2 FilledRectangles $image->FilledRectangles( $x1(pdl), $y1(pdl), $x2(pdl), $y2(pdl), $color(pdl) ) Alias for gdImageFilledRectangles. =cut sub FilledRectangles { return gdImageFilledRectangles ( @_ ); } # End of FilledRectangles()... =head2 gdImageFilledRectangles $image->gdImageFilledRectangles( $x1(pdl), $y1(pdl), $x2(pdl), $y2(pdl), $color(pdl) ) =cut sub gdImageFilledRectangles { my $self = shift; return _gdImageFilledRectangles ( @_, $self->{IMG_PTR} ); } # End of gdImageFilledRectangles()... #line 3111 "GD.pm" #line 2061 "GD.pd" =head2 FilledArcs $image->FilledArcs( $cx(pdl), $cy(pdl), $w(pdl), $h(pdl), $s(pdl), $e(pdl), $color(pdl), $style(pdl) ) Alias for gdImageFilledArcs. =cut sub FilledArcs { return gdImageFilledArcs ( @_ ); } # End of FilledArcs()... =head2 gdImageFilledArcs $image->gdImageFilledArcs( $cx(pdl), $cy(pdl), $w(pdl), $h(pdl), $s(pdl), $e(pdl), $color(pdl), $style(pdl) ) =cut sub gdImageFilledArcs { my $self = shift; return _gdImageFilledArcs ( @_, $self->{IMG_PTR} ); } # End of gdImageFilledArcs()... #line 3143 "GD.pm" #line 2061 "GD.pd" =head2 Arcs $image->Arcs( $cx(pdl), $cy(pdl), $w(pdl), $h(pdl), $s(pdl), $e(pdl), $color(pdl) ) Alias for gdImageArcs. =cut sub Arcs { return gdImageArcs ( @_ ); } # End of Arcs()... =head2 gdImageArcs $image->gdImageArcs( $cx(pdl), $cy(pdl), $w(pdl), $h(pdl), $s(pdl), $e(pdl), $color(pdl) ) =cut sub gdImageArcs { my $self = shift; return _gdImageArcs ( @_, $self->{IMG_PTR} ); } # End of gdImageArcs()... #line 3175 "GD.pm" #line 2061 "GD.pd" =head2 FilledEllipses $image->FilledEllipses( $cx(pdl), $cy(pdl), $w(pdl), $h(pdl), $color(pdl) ) Alias for gdImageFilledEllipses. =cut sub FilledEllipses { return gdImageFilledEllipses ( @_ ); } # End of FilledEllipses()... =head2 gdImageFilledEllipses $image->gdImageFilledEllipses( $cx(pdl), $cy(pdl), $w(pdl), $h(pdl), $color(pdl) ) =cut sub gdImageFilledEllipses { my $self = shift; return _gdImageFilledEllipses ( @_, $self->{IMG_PTR} ); } # End of gdImageFilledEllipses()... #line 3207 "GD.pm" #line 2073 "GD.pd" =head1 CLASS FUNCTIONS =cut #line 3215 "GD.pm" #line 2143 "GD.pd" =head2 gdImageCopy gdImageCopy ( $dst(PDL::IO::GD), $src(PDL::IO::GD), $dstX, $dstY, $srcX, $srcY, $w, $h ) =cut sub gdImageCopy { my $dst = shift; my $src = shift; my $dstX = shift; my $dstY = shift; my $srcX = shift; my $srcY = shift; my $w = shift; my $h = shift; return _gdImageCopy ( $dst->{IMG_PTR}, $src->{IMG_PTR}, $dstX, $dstY, $srcX, $srcY, $w, $h ); } # End of gdImageCopy()... #line 3240 "GD.pm" #line 2143 "GD.pd" =head2 gdImageCopyMerge gdImageCopyMerge ( $dst(PDL::IO::GD), $src(PDL::IO::GD), $dstX, $dstY, $srcX, $srcY, $w, $h, $pct ) =cut sub gdImageCopyMerge { my $dst = shift; my $src = shift; my $dstX = shift; my $dstY = shift; my $srcX = shift; my $srcY = shift; my $w = shift; my $h = shift; my $pct = shift; return _gdImageCopyMerge ( $dst->{IMG_PTR}, $src->{IMG_PTR}, $dstX, $dstY, $srcX, $srcY, $w, $h, $pct ); } # End of gdImageCopyMerge()... #line 3266 "GD.pm" #line 2143 "GD.pd" =head2 gdImageCopyMergeGray gdImageCopyMergeGray ( $dst(PDL::IO::GD), $src(PDL::IO::GD), $dstX, $dstY, $srcX, $srcY, $w, $h, $pct ) =cut sub gdImageCopyMergeGray { my $dst = shift; my $src = shift; my $dstX = shift; my $dstY = shift; my $srcX = shift; my $srcY = shift; my $w = shift; my $h = shift; my $pct = shift; return _gdImageCopyMergeGray ( $dst->{IMG_PTR}, $src->{IMG_PTR}, $dstX, $dstY, $srcX, $srcY, $w, $h, $pct ); } # End of gdImageCopyMergeGray()... #line 3292 "GD.pm" #line 2143 "GD.pd" =head2 gdImageCopyResized gdImageCopyResized ( $dst(PDL::IO::GD), $src(PDL::IO::GD), $dstX, $dstY, $srcX, $srcY, $dstW, $dstH, $srcW, $srcH ) =cut sub gdImageCopyResized { my $dst = shift; my $src = shift; my $dstX = shift; my $dstY = shift; my $srcX = shift; my $srcY = shift; my $dstW = shift; my $dstH = shift; my $srcW = shift; my $srcH = shift; return _gdImageCopyResized ( $dst->{IMG_PTR}, $src->{IMG_PTR}, $dstX, $dstY, $srcX, $srcY, $dstW, $dstH, $srcW, $srcH ); } # End of gdImageCopyResized()... #line 3319 "GD.pm" #line 2143 "GD.pd" =head2 gdImageCopyResampled gdImageCopyResampled ( $dst(PDL::IO::GD), $src(PDL::IO::GD), $dstX, $dstY, $srcX, $srcY, $dstW, $dstH, $srcW, $srcH ) =cut sub gdImageCopyResampled { my $dst = shift; my $src = shift; my $dstX = shift; my $dstY = shift; my $srcX = shift; my $srcY = shift; my $dstW = shift; my $dstH = shift; my $srcW = shift; my $srcH = shift; return _gdImageCopyResampled ( $dst->{IMG_PTR}, $src->{IMG_PTR}, $dstX, $dstY, $srcX, $srcY, $dstW, $dstH, $srcW, $srcH ); } # End of gdImageCopyResampled()... #line 3346 "GD.pm" #line 2143 "GD.pd" =head2 gdImageCompare gdImageCompare ( $im1(PDL::IO::GD), $im2(PDL::IO::GD) ) =cut sub gdImageCompare { my $im1 = shift; my $im2 = shift; return _gdImageCompare ( $im1->{IMG_PTR}, $im2->{IMG_PTR} ); } # End of gdImageCompare()... #line 3365 "GD.pm" #line 2143 "GD.pd" =head2 gdImagePaletteCopy gdImagePaletteCopy ( $dst(PDL::IO::GD), $src(PDL::IO::GD) ) =cut sub gdImagePaletteCopy { my $dst = shift; my $src = shift; return _gdImagePaletteCopy ( $dst->{IMG_PTR}, $src->{IMG_PTR} ); } # End of gdImagePaletteCopy()... #line 3384 "GD.pm" #line 1469 "GD.pd" =head2 StringTTF $image->StringTTF( $brect, $fg, $fontlist, $ptsize, $angle, $x, $y, $string ) Alias for gdImageStringTTF. =cut sub StringTTF { return gdImageStringTTF ( @_ ); } # End of StringTTF()... =head2 gdImageStringTTF $image->gdImageStringTTF( $brect, $fg, $fontlist, $ptsize, $angle, $x, $y, $string ) =cut sub gdImageStringTTF { my $self = shift; return _gdImageStringTTF ( $self->{IMG_PTR}, @_ ); } # End of gdImageStringTTF()... #line 3416 "GD.pm" #line 1522 "GD.pd" =head2 StringFT $image->StringFT( $brect, $fg, $fontlist, $ptsize, $angle, $x, $y, $string ) Alias for gdImageStringFT. =cut sub StringFT { return gdImageStringFT ( @_ ); } # End of StringFT()... =head2 gdImageStringFT $image->gdImageStringFT( $brect, $fg, $fontlist, $ptsize, $angle, $x, $y, $string ) =cut sub gdImageStringFT { my $self = shift; return _gdImageStringFT ( $self->{IMG_PTR}, @_ ); } # End of gdImageStringFT()... #line 3448 "GD.pm" #line 1554 "GD.pd" =head1 AUTHOR Judd Taylor, Orbital Systems, Ltd. judd dot t at orbitalsystems dot com =cut #line 3460 "GD.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/IO/Pnm.pm0000644000175000017500000002445114200406311015404 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::IO::Pnm; our @EXPORT_OK = qw(rpnm wpnm pnminraw pnminascii pnmout ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::IO::Pnm ; #line 10 "pnm.pd" use strict; use warnings; =head1 NAME PDL::IO::Pnm -- pnm format I/O for PDL =head1 SYNOPSIS use PDL::IO::Pnm; $im = wpnm $pdl, $file, $format[, $raw]; rpnm $stack->slice(':,:,:,(0)'),"PDL.ppm"; =head1 DESCRIPTION pnm I/O for PDL. =cut use PDL::Core qw/howbig convert/; use PDL::Types; use PDL::Basic; # for max/min use PDL::IO::Misc; use Carp; use File::Temp qw( tempfile ); # return the upper limit of data values an integer PDL data type # can hold sub dmax { my $type = shift; my $sz = 8*howbig($type); $sz-- if !PDL::Type->new($type)->unsigned; return ((1 << $sz)-1); } #line 61 "Pnm.pm" =head1 FUNCTIONS =cut #line 1059 "../../blib/lib/PDL/PP.pm" =head2 pnminraw =for sig Signature: (type(); byte+ [o] im(m,n); int ms => m; int ns => n; int isbin; PerlIO *fp) =for ref Read in a raw pnm file. read a raw pnm file. The C argument is only there to determine the type of the operation when creating C or trigger the appropriate type conversion (maybe we want a byte+ here so that C follows I the type of C). =for bad pnminraw does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 103 "Pnm.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *pnminraw = \&PDL::pnminraw; #line 109 "Pnm.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 pnminascii =for sig Signature: (type(); byte+ [o] im(m,n); int ms => m; int ns => n; int format; PerlIO *fp) =for ref Read in an ascii pnm file. =for bad pnminascii does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 136 "Pnm.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *pnminascii = \&PDL::pnminascii; #line 142 "Pnm.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 pnmout =for sig Signature: (a(m); int israw; int isbin; PerlIO *fp) =for ref Write a line of pnm data. This function is implemented this way so that threading works naturally. =for bad pnmout does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 171 "Pnm.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *pnmout = \&PDL::pnmout; #line 177 "Pnm.pm" #line 48 "pnm.pd" =head2 rpnm =for ref Read a pnm (portable bitmap/pixmap, pbm/ppm) file into an ndarray. =for usage Usage: $im = rpnm $file; Reads a file (or open file-handle) in pnm format (ascii or raw) into a pdl (magic numbers P1-P6). Based on the input format it returns pdls with arrays of size (width,height) if binary or grey value data (pbm and pgm) or (3,width,height) if rgb data (ppm). This also means for a palette image that the distinction between an image and its lookup table is lost which can be a problem in cases (but can hardly be avoided when using netpbm/pbmplus). Datatype is dependent on the maximum grey/color-component value (for raw and binary formats always PDL_B). rpnm tries to read chopped files by zero padding the missing data (well it currently doesn't, it barfs; I'll probably fix it when it becomes a problem for me ;). You can also read directly into an existing pdl that has to have the right size(!). This can come in handy when you want to read a sequence of images into a datacube. For details about the formats see appropriate manpages that come with the netpbm/pbmplus packages. =for example $stack = zeroes(byte,3,500,300,4); rpnm $stack->slice(':,:,:,(0)'),"PDL.ppm"; reads an rgb image (that had better be of size (500,300)) into the first plane of a 3D RGB datacube (=4D pdl datacube). You can also do inplace transpose/inversion that way. =cut sub rpnm {PDL->rpnm(@_)} sub PDL::rpnm { barf 'Usage: $im = rpnm($file) or $im = $pdl->rpnm($file)' if !@_ || @_>3; my $pdl = ref($_[1]) && UNIVERSAL::isa($_[1], 'PDL') ? (splice @_, 0, 2)[1] : shift->initialize; my $file = shift; my $fh; if (ref $file) { $fh = $file; } else { open $fh, $file or barf "Can't open pnm file '$file': $!"; } binmode $fh; read($fh,(my $magic),2); barf "Oops, this is not a PNM file" unless $magic =~ /P([1-6])/; my $magicno = $1; print "reading pnm file with magic $magic\n" if $PDL::debug>1; my $israw = $magicno > 3 ? 1 : 0; my $isrgb = ($magicno % 3) == 0; my $ispbm = ($magicno % 3) == 1; my ($params, @dims) = ($ispbm ? 2 : 3, 0, 0, $ispbm ? 1 : 0); # get the header information my $pgot = 0; while (($pgot<$params) && defined(my $line=<$fh>)) { $line =~ s/#.*$//; next if $line =~ /^\s*$/; # just white space while ($line !~ /^\s*$/ && $pgot < $params) { if ($line =~ /\s*(\S+)(.*)$/) { $dims[$pgot++] = $1; $line = $2; } else { barf "no valid header info in pnm";} } } # the file ended prematurely barf "no valid header info in pnm" if $pgot < $params; barf "Dimensions must be > 0" if ($dims[0] <= 0) || ($dims[1] <= 0); my ($type) = grep $dims[2] <= dmax($_), $PDL_B,$PDL_US,$PDL_L; barf "rraw: data from ascii pnm file out of range" if !defined $type; my @Dims = @dims[0,1]; $Dims[0] *= 3 if $isrgb; $pdl = $pdl->zeroes(PDL::Type->new($type),3,@dims[0,1]) if $pdl->isnull and $isrgb; my $npdl = $isrgb ? $pdl->clump(2) : $pdl; if ($israw) { pnminraw (convert(pdl(0),$type), $npdl, $Dims[0], $Dims[1], $ispbm, $fh); } else { pnminascii (convert(pdl(0),$type), $npdl, $Dims[0], $Dims[1], $magicno, $fh); } print("loaded pnm file, $dims[0]x$dims[1], gmax: $dims[2]", $isrgb ? ", RGB data":"", $israw ? ", raw" : " ASCII"," data\n") if $PDL::debug; # need to byte swap for little endian platforms $pdl->type->bswap->($pdl) if !isbigendian() and $israw; return $pdl; } =head2 wpnm =for ref Write a pnm (portable bitmap/pixmap, pbm/ppm) file into a file or open file-handle. =for usage Usage: $im = wpnm $pdl, $file, $format[, $raw]; Writes data in a pdl into pnm format (ascii or raw) (magic numbers P1-P6). The $format is required (normally produced by B) and routine just checks if data is compatible with that format. All conversions should already have been done. If possible, usage of B is preferred. Currently RAW format is chosen if compliant with range of input data. Explicit control of ASCII/RAW is possible through the optional $raw argument. If RAW is set to zero it will enforce ASCII mode. Enforcing RAW is somewhat meaningless as the routine will always try to write RAW format if the data range allows (but maybe it should reduce to a RAW supported type when RAW == 'RAW'?). For details about the formats consult appropriate manpages that come with the netpbm/pbmplus packages. =cut my %type2base = (PBM => 1, PGM => 2, PPM => 3); *wpnm = \&PDL::wpnm; sub PDL::wpnm { barf ('Usage: wpnm($pdl,$filename,$format[,$raw]) ' . 'or $pdl->wpnm($filename,$format[,$raw])') if $#_ < 2; my ($pdl,$file,$type,$raw) = @_; barf "wpnm: unknown format '$type'" if !exists $type2base{$type}; # need to copy input arg since bswap[24] work inplace # might be better if the bswap calls detected if run in # void context my $swap_inplace = $pdl->is_inplace; # check the data my @Dims = $pdl->dims; barf "wpnm: expecting 3D (3,w,h) input" if ($type =~ /PPM/) && (($#Dims != 2) || ($Dims[0] != 3)); barf "wpnm: expecting 2D (w,h) input" if ($type =~ /P[GB]M/) && ($#Dims != 1); barf "wpnm: user should convert float etc data to appropriate type" if !$pdl->type->integer; my $max = $pdl->max; barf "wpnm: expecting prescaled data (0-65535)" if $pdl->min < 0 or $max > 65535; # check for raw format my $israw = (defined($raw) && !$raw) ? 0 : (($pdl->get_datatype == $PDL_B) || ($pdl->get_datatype == $PDL_US) || ($type eq 'PBM')) ? 3 : 0; my $magic = 'P' . ($type2base{$type} + $israw); my $isrgb = $type eq 'PPM'; my $pref = ($file !~ /^\s*[|>]/) ? ">" : ""; # test for plain file name my ($already_open, $fh) = 0; if (ref $file) { $fh = $file, $already_open = 1; } else { open $fh, $pref . $file or barf "Can't open pnm file: $!"; } binmode $fh; print "writing ". ($israw ? "raw" : "ascii") . "format with magic $magic, max=$max\n" if $PDL::debug; # write header print $fh "$magic\n"; print $fh "$Dims[-2] $Dims[-1]\n"; if ($type ne 'PBM') { # fix maxval for raw output formats my $outmax = 0; if ($max < 256) { $outmax = "255"; } elsif ($max < 65536) { $outmax = "65535"; } else { $outmax = $max; }; print $fh "$outmax\n"; }; # if rgb clump first two dims together my $out = ($isrgb ? $pdl->slice(':,:,-1:0')->clump(2) : $pdl->slice(':,-1:0')); # handle byte swap issues for little endian platforms if (!isbigendian() and $israw) { $out = $out->copy unless $swap_inplace; $out->type->bswap->($out); } pnmout($out,$israw,$type eq "PBM",$fh); # check if our child returned an error (in case of a pipe) barf "wpnm: pbmconverter error: $!" if !$already_open and !close $fh; } ;# Exit with OK status 1; =head1 BUGS C currently relies on the fact that the header is separated from the image data by a newline. This is not required by the p[bgp]m formats (in fact any whitespace is allowed) but most of the pnm writers seem to comply with that. Truncated files are currently treated ungracefully (C just barfs). =head1 AUTHOR Copyright (C) 1996,1997 Christian Soeller 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 ############################## END PM CODE ################################ #line 412 "Pnm.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/IO/Browser.pm0000644000175000017500000000307514200406310016273 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::IO::Browser; our @EXPORT_OK = qw(browse ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::IO::Browser ; #line 2 "browser.pd" =head1 NAME PDL::IO::Browser -- 2D data browser for PDL =head1 DESCRIPTION cursor terminal browser for ndarrays. =head1 SYNOPSIS use PDL::IO::Browser; =cut use strict; use warnings; #line 43 "Browser.pm" =head1 FUNCTIONS =cut #line 1059 "../../blib/lib/PDL/PP.pm" =head2 browse =for sig Signature: (a(n,m)) =head2 browse =for ref browse a 2D array using terminal cursor keys =for usage browse $data This uses the CURSES library to allow one to scroll around a PDL array using the cursor keys. =for bad browse does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 90 "Browser.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *browse = \&PDL::browse; #line 96 "Browser.pm" #line 57 "browser.pd" =head1 AUTHOR Copyright (C) Robin Williams 1997 (rjrw@ast.leeds.ac.uk). 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 #line 115 "Browser.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/IO/HDF/0000755000175000017500000000000014200406310014706 5ustar osboxesosboxesPDL-2.074/GENERATED/PDL/IO/HDF/VS.pm0000644000175000017500000003403214200406310015576 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::IO::HDF::VS; our @EXPORT_OK = qw(); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::IO::HDF::VS ; #line 5 "VS.pd" use strict; use warnings; =head1 NAME PDL::IO::HDF::VS - An interface library for HDF4 files. =head1 SYNOPSIS use PDL; use PDL::IO::HDF::VS; #### no doc for now #### =head1 DESCRIPTION This library provides functions to manipulate HDF4 files with VS and V interface (reading, writing, ...) For more information on HDF4, see http://www.hdfgroup.org/products/hdf4/ =head1 FUNCTIONS =cut #line 50 "VS.pm" #line 326 "VS.pd" use PDL::Primitive; use PDL::Basic; use PDL::IO::HDF; my $TMAP = { PDL::byte->[0] => 1, PDL::short->[0] => 2, PDL::ushort->[0] => 2, PDL::long->[0] => 4, PDL::float->[0] => 4, PDL::double->[0] => 8 }; sub _pkg_name { return "PDL::IO::HDF::VS::" . shift() . "()"; } =head2 new =for ref Open or create a new HDF object with VS and V interface. =for usage Arguments: 1 : The name of the HDF file. If you want to write to it, prepend the name with the '+' character : "+name.hdf" If you want to create it, prepend the name with the '-' character : "-name.hdf" Otherwise the file will be opened in read only mode. Returns the hdf object (die on error) =for example my $hdf = PDL::IO::HDF::VS->new("file.hdf"); =cut sub new { # general my $type = shift; my $filename = shift; my $self = {}; if (substr($filename, 0, 1) eq '+') { # open for writing $filename = substr ($filename, 1); # chop off + $self->{ACCESS_MODE} = PDL::IO::HDF->DFACC_WRITE + PDL::IO::HDF->DFACC_READ; } if (substr($filename, 0, 1) eq '-') { # Creating $filename = substr ($filename, 1); # chop off - $self->{ACCESS_MODE} = PDL::IO::HDF->DFACC_CREATE; } unless( defined($self->{ACCESS_MODE}) ) { $self->{ACCESS_MODE} = PDL::IO::HDF->DFACC_READ; } $self->{FILE_NAME} = $filename; $self->{HID} = PDL::IO::HDF::VS::_Hopen( $self->{FILE_NAME}, $self->{ACCESS_MODE}, 20 ); if ($self->{HID}) { PDL::IO::HDF::VS::_Vstart( $self->{HID} ); my $SDID = PDL::IO::HDF::VS::_SDstart( $self->{FILE_NAME}, $self->{ACCESS_MODE} ); #### search for vgroup my $vgroup = {}; my $vg_ref = -1; while( ($vg_ref = PDL::IO::HDF::VS::_Vgetid( $self->{HID}, $vg_ref )) != PDL::IO::HDF->FAIL) { my $vg_id = PDL::IO::HDF::VS::_Vattach( $self->{HID}, $vg_ref, 'r' ); my $n_entries = 0; my $vg_name = " "x(PDL::IO::HDF->VNAMELENMAX+1); my $res = PDL::IO::HDF::VS::_Vinquire( $vg_id, $n_entries, $vg_name ); my $vg_class = ""; PDL::IO::HDF::VS::_Vgetclass( $vg_id, $vg_class ); $vgroup->{$vg_name}->{ref} = $vg_ref; $vgroup->{$vg_name}->{class} = $vg_class; my $n_pairs = PDL::IO::HDF::VS::_Vntagrefs( $vg_id ); for ( 0 .. $n_pairs-1 ) { my ($tag, $ref); $res = PDL::IO::HDF::VS::_Vgettagref( $vg_id, $_, $tag = 0, $ref = 0 ); if($tag == 1965) { # Vgroup my $id = PDL::IO::HDF::VS::_Vattach( $self->{HID}, $ref, 'r' ); my $name = " "x(PDL::IO::HDF->VNAMELENMAX+1); my $res = PDL::IO::HDF::VS::_Vgetname( $id, $name ); PDL::IO::HDF::VS::_Vdetach( $id ); $vgroup->{$vg_name}->{children}->{$name} = $ref; $vgroup->{$name}->{parents}->{$vg_name} = $vg_ref; } elsif($tag == 1962) { # Vdata my $id = PDL::IO::HDF::VS::_VSattach( $self->{HID}, $ref, 'r' ); my $name = " "x(PDL::IO::HDF->VNAMELENMAX+1); my $res = PDL::IO::HDF::VS::_VSgetname( $id, $name ); my $class = ""; PDL::IO::HDF::VS::_VSgetclass( $id, $class ); PDL::IO::HDF::VS::_VSdetach( $id ); $vgroup->{$vg_name}->{attach}->{$name}->{type} = 'VData'; $vgroup->{$vg_name}->{attach}->{$name}->{ref} = $ref; $vgroup->{$vg_name}->{attach}->{$name}->{class} = $class if( $class ne '' ); } if( ($SDID != PDL::IO::HDF->FAIL) && ($tag == 720)) #tag for SDS tag/ref (see 702) { my $i = _SDreftoindex( $SDID, $ref ); my $sds_ID = _SDselect( $SDID, $i ); my $name = " "x(PDL::IO::HDF->MAX_NC_NAME+1); my $rank = 0; my $dimsize = " "x( (4 * PDL::IO::HDF->MAX_VAR_DIMS) + 1 ); my $numtype = 0; my $nattrs = 0; $res = _SDgetinfo( $sds_ID, $name, $rank, $dimsize , $numtype, $nattrs ); $vgroup->{$vg_name}->{attach}->{$name}->{type} = 'SDS_Data'; $vgroup->{$vg_name}->{attach}->{$name}->{ref} = $ref; } } # for each pair... PDL::IO::HDF::VS::_Vdetach( $vg_id ); } # while vg_ref... PDL::IO::HDF::VS::_SDend( $SDID ); $self->{VGROUP} = $vgroup; #### search for vdata my $vdata_ref=-1; my $vdata_id=-1; my $vdata = {}; # get lone vdata (not member of a vgroup) my $lone=PDL::IO::HDF::VS::_VSlone($self->{HID}); my $MAX_REF = 0; while ( $vdata_ref = shift @$lone ) { my $mode="r"; if ( $self->{ACCESS_MODE} != PDL::IO::HDF->DFACC_READ ) { $mode="w"; } $vdata_id = PDL::IO::HDF::VS::_VSattach( $self->{HID}, $vdata_ref, $mode ); my $vdata_size = 0; my $n_records = 0; my $interlace = 0; my $fields = ""; my $vdata_name = ""; my $status = PDL::IO::HDF::VS::_VSinquire( $vdata_id, $n_records, $interlace, $fields, $vdata_size, $vdata_name ); die "PDL::IO::HDF::VS::_VSinquire (vdata_id=$vdata_id)" unless $status; $vdata->{$vdata_name}->{REF} = $vdata_ref; $vdata->{$vdata_name}->{NREC} = $n_records; $vdata->{$vdata_name}->{INTERLACE} = $interlace; $vdata->{$vdata_name}->{ISATTR} = PDL::IO::HDF::VS::_VSisattr( $vdata_id ); my $field_index = 0; foreach my $onefield ( split( ",", $fields ) ) { $vdata->{$vdata_name}->{FIELDS}->{$onefield}->{TYPE} = PDL::IO::HDF::VS::_VFfieldtype( $vdata_id, $field_index ); $vdata->{$vdata_name}->{FIELDS}->{$onefield}->{INDEX} = $field_index; $field_index++; } PDL::IO::HDF::VS::_VSdetach( $vdata_id ); } # while vdata_ref... $self->{VDATA} = $vdata; } # if $self->{HDID}... bless($self, $type); } # End of new()... sub Vgetchildren { my ($self, $name) = @_; return( undef ) unless defined( $self->{VGROUP}->{$name}->{children} ); return sort keys %{$self->{VGROUP}->{$name}->{children}}; #line 261 "VS.pm" #line 528 "VS.pd" } # End of Vgetchildren()... # Now defunct: sub Vgetchilds { my $self = shift; return $self->Vgetchildren( @_ ); } # End of Vgetchilds()... sub Vgetattach { my ($self, $name) = @_; return( undef ) unless defined( $self->{VGROUP}->{$name}->{attach} ); return sort keys %{$self->{VGROUP}->{$name}->{children}}; #line 278 "VS.pm" #line 543 "VS.pd" } # End of Vgetattach()... sub Vgetparents { my ($self, $name) = @_; return( undef ) unless defined( $self->{VGROUP}->{$name}->{parents} ); return sort keys %{$self->{VGROUP}->{$name}->{parents}}; #line 289 "VS.pm" #line 552 "VS.pd" } # End of Vgetparents()... sub Vgetmains { my ($self) = @_; my @rlist; foreach( sort keys %{$self->{VGROUP}} ) #line 298 "VS.pm" #line 559 "VS.pd" { push(@rlist, $_) unless defined( $self->{VGROUP}->{$_}->{parents} ); } return @rlist; } # End of Vgetmains()... sub Vcreate { my($self, $name, $class, $where) = @_; my $id = PDL::IO::HDF::VS::_Vattach( $self->{HID}, -1, 'w' ); return( undef ) if( $id == PDL::IO::HDF->FAIL ); my $res = _Vsetname($id, $name); $res = _Vsetclass($id, $class) if defined( $class ); $self->{VGROUP}->{$name}->{ref} = '???'; $self->{VGROUP}->{$name}->{class} = $class if defined( $class ); if( defined( $where ) ) { return( undef ) unless defined( $self->{VGROUP}->{$where} ); my $ref = $self->{VGROUP}->{$where}->{ref}; my $Pid = PDL::IO::HDF::VS::_Vattach( $self->{HID}, $ref, 'w' ); my $index = PDL::IO::HDF::VS::_Vinsert( $Pid, $id ); my ($t, $r) = (0, 0); $res = PDL::IO::HDF::VS::_Vgettagref( $Pid, $index, $t, $r ); PDL::IO::HDF::VS::_Vdetach( $Pid ); $self->{VGROUP}->{$name}->{parents}->{$where} = $ref; $self->{VGROUP}->{$where}->{children}->{$name} = $r; $self->{VGROUP}->{$name}->{ref} = $r; } return( _Vdetach( $id ) + 1 ); } # End of Vcreate()... =head2 close =for ref Close the VS interface. =for usage no arguments =for example my $result = $hdf->close(); =cut sub close { my $self = shift; _Vend( $self->{HID} ); my $Hid = $self->{HID}; $self = undef; return( _Hclose($Hid) + 1 ); } # End of close()... sub VSisattr { my($self, $name) = @_; return undef unless defined( $self->{VDATA}->{$name} ); return $self->{VDATA}->{$name}->{ISATTR}; } # End of VSisattr()... sub VSgetnames { my $self = shift; return sort keys %{$self->{VDATA}}; #line 382 "VS.pm" #line 641 "VS.pd" } # End of VSgetnames()... sub VSgetfieldnames { my ( $self, $name ) = @_; my $sub = _pkg_name( 'VSgetfieldnames' ); die "$sub: vdata name $name doesn't exist!\n" unless defined( $self->{VDATA}->{$name} ); return sort keys %{$self->{VDATA}->{$name}->{FIELDS}}; #line 396 "VS.pm" #line 653 "VS.pd" } # End of VSgetfieldnames()... # Now defunct: sub VSgetfieldsnames { my $self = shift; return $self->VSgetfieldnames( @_ ); } # End of VSgetfieldsnames()... sub VSread { my ( $self, $name, $field ) = @_; my $sub = _pkg_name( 'VSread' ); my $data = null; my $vdata_ref = PDL::IO::HDF::VS::_VSfind( $self->{HID}, $name ); die "$sub: vdata name $name doesn't exist!\n" unless $vdata_ref; my $vdata_id = PDL::IO::HDF::VS::_VSattach( $self->{HID}, $vdata_ref, 'r' ); my $vdata_size = 0; my $n_records = 0; my $interlace = 0; my $fields = ""; my $vdata_name = ""; my $status = PDL::IO::HDF::VS::_VSinquire( $vdata_id, $n_records, $interlace, $fields, $vdata_size, $vdata_name ); my $data_type = PDL::IO::HDF::VS::_VFfieldtype( $vdata_id, $self->{VDATA}->{$name}->{FIELDS}->{$field}->{INDEX} ); die "$sub: data_type $data_type not implemented!\n" unless defined( $PDL::IO::HDF::SDinvtypeTMAP->{$data_type} ); my $order = PDL::IO::HDF::VS::_VFfieldorder( $vdata_id, $self->{VDATA}->{$name}->{FIELDS}->{$field}->{INDEX} ); if($order == 1) { $data = ones( $PDL::IO::HDF::SDinvtypeTMAP2->{$data_type}, $n_records ); } else { $data = ones( $PDL::IO::HDF::SDinvtypeTMAP2->{$data_type}, $n_records, $order ); } $status = PDL::IO::HDF::VS::_VSsetfields( $vdata_id, $field ); die "$sub: _VSsetfields\n" unless $status; $status = PDL::IO::HDF::VS::_VSread( $vdata_id, $data, $n_records, $interlace); PDL::IO::HDF::VS::_VSdetach( $vdata_id ); return $data; } # End of VSread()... sub VSwrite { my($self, $name, $mode, $field, $value) = @_; return( undef ) if( $$value[0]->getndims > 2); #too many dims my $VD_id; my $res; my @foo = split( /:/, $name ); return( undef ) if defined( $self->{VDATA}->{$foo[0]} ); $VD_id = _VSattach( $self->{HID}, -1, 'w' ); return( undef ) if( $VD_id == PDL::IO::HDF->FAIL ); $res = _VSsetname( $VD_id, $foo[0] ); return( undef ) if( $res == PDL::IO::HDF->FAIL ); $res = _VSsetclass( $VD_id, $foo[1] ) if defined( $foo[1] ); return( undef ) if( $res == PDL::IO::HDF->FAIL ); my @listfield = split( /,/, $field ); for( my $i = 0; $i <= $#$value; $i++ ) { my $HDFtype = $PDL::IO::HDF::SDtypeTMAP->{$$value[$i]->get_datatype()}; $res = _VSfdefine( $VD_id, $listfield[$i], $HDFtype, $$value[$i]->getdim(1) ); return( undef ) unless $res; } $res = _VSsetfields( $VD_id, $field ); return( undef ) unless $res; my @sizeofPDL; my @sdimofPDL; foreach ( @$value ) { push(@sdimofPDL, $_->getdim(1)); push(@sizeofPDL, $TMAP->{$_->get_datatype()}); } $res = _WriteMultPDL( $VD_id, $$value[0]->getdim(0), $#$value+1, $mode, \@sizeofPDL, \@sdimofPDL, $value); return( undef ) if( _VSdetach($VD_id) == PDL::IO::HDF->FAIL ); return $res; } # End of VSwrite()... sub DESTROY { my $self = shift; $self->close; } # End of DESTROY()... #line 515 "VS.pm" #line 777 "VS.pd" =head1 CURRENT AUTHOR & MAINTAINER Judd Taylor, Orbital Systems, Ltd. judd dot t at orbitalsystems dot com =head1 PREVIOUS AUTHORS Olivier Archer olivier.archer@ifremer.fr contribs of Patrick Leilde patrick.leilde@ifremer.fr =head1 SEE ALSO perl(1), PDL(1), PDL::IO::HDF(1). =cut #line 536 "VS.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/IO/HDF/SD.pm0000644000175000017500000010715714200406310015565 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::IO::HDF::SD; our @EXPORT_OK = qw(); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::IO::HDF::SD ; #line 4 "SD.pd" =head1 NAME PDL::IO::HDF::SD - PDL interface to the HDF4 SD library. =head1 SYNOPSIS use PDL; use PDL::IO::HDF::SD; # # Creating and writing an HDF file # # Create an HDF file: my $hdf = PDL::IO::HDF::SD->new("-test.hdf"); # Define some data my $data = sequence(short, 500, 5); # Put data in file as 'myData' dataset with the names # of dimensions ('dim1' and 'dim2') $hdf->SDput("myData", $data , ['dim1','dim2']); # Put some local attributes in 'myData' # # Set the fill value to 0 my $res = $hdf->SDsetfillvalue("myData", 0); # Set the valid range from 0 to 2000 $res = $hdf->SDsetrange("myData", [0, 2000]); # Set the default calibration for 'myData' (scale factor = 1, other = 0) $res = $hdf->SDsetcal("myData"); # Set a global text attribute $res = $hdf->SDsettextattr('This is a global text test!!', "myGText" ); # Set a local text attribute for 'myData' $res = $hdf->SDsettextattr('This is a local text testl!!', "myLText", "myData" ); # Set a global value attribute (you can put all values you want) $res = $hdf->SDsetvalueattr( PDL::short( 20 ), "myGValue"); # Set a local value attribute (you can put all values you want) $res = $hdf->SDsetvalueattr( PDL::long( [20, 15, 36] ), "myLValues", "myData" ); # Close the file $hdf->close(); # # Reading from an HDF file: # # Open an HDF file in read only mode: my $hdf = PDL::IO::HDF::SD->new("test.hdf"); # Get a list of all datasets: my @dataset_list = $hdf->SDgetvariablename(); # Get a list of the names of all global attributes: my @globattr_list = $hdf->SDgetattributenames(); # Get a list of the names of all local attributes for a dataset: my @locattr_list = $hdf->SDgetattributenames("myData"); # Get the value of local attribute for a dataset: my $value = $hdf->SDgetattribut("myLText","myData"); # Get a PDL var of the entire dataset 'myData': my $data = $hdf->SDget("myData"); # Apply the scale factor of 'myData' $data *= $hdf->SDgetscalefactor("myData"); # Get the fill value and fill the PDL var in with BAD: $data->inplace->setvaltobad( $hdf->SDgetfillvalue("myData") ); # Get the valid range of a dataset: my @range = $hdf->SDgetrange("myData"); #Now you can do what you want with your data $hdf->close(); =head1 DESCRIPTION This library provides functions to read, write, and manipulate HDF4 files with HDF's SD interface. For more information on HDF4, see http://hdf.ncsa.uiuc.edu/ There have been a lot of changes starting with version 2.0, and these may affect your code. PLEASE see the 'Changes' file for a detailed description of what has been changed. If your code used to work with the circa 2002 version of this module, and does not work anymore, reading the 'Changes' is your best bet. In the documentation, the terms dataset and SDS (Scientific Data Set) are used interchangeably. =cut use strict; use warnings; #line 127 "SD.pm" #line 362 "SD.pd" use PDL::Primitive; use PDL::Basic; use PDL::IO::HDF; require POSIX; sub _pkg_name { return "PDL::IO::HDF::SD::" . shift() . "()"; } # Convert a byte to a char: sub Byte2Char { my ($strB) = @_; my $strC; for(my $i=0; $i<$strB->nelem; $i++) { $strC .= chr( $strB->at($i) ); } return($strC); } # End of Byte2Char()... =head1 CLASS METHODS =head2 new =for ref Open or create a new HDF object. =for usage Arguments: 1 : The name of the file. if you want to write to it, prepend the name with the '+' character : "+name.hdf" if you want to create it, prepend the name with the '-' character : "-name.hdf" otherwise the file will be open in read only mode Returns the hdf object (die on error) =for example my $hdf = PDL::IO::HDF::SD->new("file.hdf"); =cut sub new { # General: my $type = shift; my $filename = shift; my $sub = _pkg_name( 'new' ); my $debug = 0; my $self = {}; if (substr($filename, 0, 1) eq '+') { # open for writing $filename = substr ($filename, 1); # chop off + $self->{ACCESS_MODE} = PDL::IO::HDF->DFACC_WRITE + PDL::IO::HDF->DFACC_READ; } if (substr($filename, 0, 1) eq '-') { # Create new file $filename = substr ($filename, 1); # chop off - print "$sub: Creating HDF File $filename\n" if $debug; $self->{ACCESS_MODE} = PDL::IO::HDF->DFACC_CREATE; $self->{SDID} = PDL::IO::HDF::SD::_SDstart( $filename, $self->{ACCESS_MODE} ); my $res = PDL::IO::HDF::SD::_SDend( $self->{SDID} ); die "$sub: _ERR::Create\n" if( ($self->{SDID} == PDL::IO::HDF->FAIL ) || ( $res == PDL::IO::HDF->FAIL )); $self->{ACCESS_MODE} = PDL::IO::HDF->DFACC_WRITE + PDL::IO::HDF->DFACC_READ; } unless( defined( $self->{ACCESS_MODE} ) ) { # Default to Read-only access: $self->{ACCESS_MODE} = PDL::IO::HDF->DFACC_READ; } $self->{FILE_NAME} = $filename; # SD interface: print "$sub: Loading HDF File $self->{FILE_NAME}\n" if $debug; $self->{SDID} = PDL::IO::HDF::SD::_SDstart( $self->{FILE_NAME}, $self->{ACCESS_MODE} ); die "$sub: _ERR::SDstart\n" if( $self->{SDID} == PDL::IO::HDF->FAIL ); my $num_datasets = -999; my $num_global_attrs = -999; my $res = _SDfileinfo( $self->{SDID}, $num_datasets, $num_global_attrs ); die "$sub: ** sdFileInfo **\n" if($res == PDL::IO::HDF->FAIL); foreach my $i ( 0 .. $num_global_attrs-1 ) { print "$sub: Loading Global Attribute #$i\n" if $debug; my $attrname = " "x(PDL::IO::HDF->MAX_NC_NAME+1); my $type = 0; my $count = 0; $res = _SDattrinfo( $self->{SDID}, $i, $attrname, $type, $count ); die "$sub: ** sdAttrInfo **\n" if($res == PDL::IO::HDF->FAIL); print "$sub: \$attrname = \'$attrname\'\n" if $debug; $self->{GLOBATTR}->{$attrname} = zeroes( $PDL::IO::HDF::SDinvtypeTMAP2->{$type}, $count ); $res = _SDreadattr( $self->{SDID}, $i, $self->{GLOBATTR}->{$attrname} ); die "$sub: ** sdReadAttr **\n" if($res == PDL::IO::HDF->FAIL); if( $type == PDL::IO::HDF->DFNT_CHAR ) { $self->{GLOBATTR}->{$attrname} = Byte2Char( $self->{GLOBATTR}->{$attrname} ); } } my @dataname; foreach my $i ( 0 .. $num_datasets-1 ) { print "$sub: Loading SDS #$i\n" if $debug; my $sds_id = _SDselect( $self->{SDID}, $i ); die "$sub: ** sdSelect **\n" if($sds_id == PDL::IO::HDF->FAIL); my $name = " "x(PDL::IO::HDF->MAX_NC_NAME+1); my $rank = 0; my $dimsize = " "x( (4 * PDL::IO::HDF->MAX_VAR_DIMS) + 1 ); my $numtype = 0; my $num_attrs = 0; $res = _SDgetinfo($sds_id, $name, $rank, $dimsize, $numtype, $num_attrs); die "$sub: ** sdGetInfo **\n" if($res == PDL::IO::HDF->FAIL); print "$sub: \$name = \'$name\'\n" if $debug; print "$sub: \$dimsize = \'$dimsize\'\n" if $debug; $self->{DATASET}->{$name}->{TYPE} = $numtype; $self->{DATASET}->{$name}->{RANK} = $rank; $self->{DATASET}->{$name}->{SDSID} = $sds_id; # Load up information on the dimensions (named, unlimited, etc...): # foreach my $j ( 0 .. $self->{DATASET}->{$name}->{RANK}-1 ) { print "$sub: Loading SDS($i) Dimension #$j\n" if $debug; my $dim_id = _SDgetdimid( $sds_id, $j ); die "$sub: ** sdGetDimId **\n" if($dim_id == PDL::IO::HDF->FAIL); my $dimname = " "x(PDL::IO::HDF->MAX_NC_NAME+1); my $size = 0; my $num_type = 0; my $num_dim_attrs = 0; $res = _SDdiminfo( $dim_id, $dimname, $size, $num_type, $num_dim_attrs ); die "$sub: ** sdDimInfo **\n" if($res == PDL::IO::HDF->FAIL); print "$sub: \$dimname = \'$dimname\'\n" if $debug; $self->{DATASET}->{$name}->{DIMS}->{$j}->{DIMID} = $dim_id; $self->{DATASET}->{$name}->{DIMS}->{$j}->{SIZE} = $size; $self->{DATASET}->{$name}->{DIMS}->{$j}->{NAME} = $dimname; # The size comes back as 0 if it has the HDF unlimited dimension thing going on: # So, lets figure out what the size is currently at: unless ( $size ) { $self->{DATASET}->{$name}->{DIMS}->{$j}->{REAL_SIZE} = _SDgetunlimiteddim( $sds_id, $j); } } # Load up info on the SDS's attributes: # foreach my $j ( 0 .. $num_attrs-1 ) { print "$sub: Loading SDS($i) Attribute #$j\n" if $debug; my $attrname = " "x(PDL::IO::HDF->MAX_NC_NAME+1); my $type = 0; my $count = 0; $res = _SDattrinfo( $sds_id, $j, $attrname, $type, $count); die "$sub: ** sdAttrInfo **\n" if($res == PDL::IO::HDF->FAIL); print "$sub: \$attrname = \'$attrname\'\n" if $debug; $self->{DATASET}->{$name}->{ATTRS}->{$attrname} = zeroes( $PDL::IO::HDF::SDinvtypeTMAP2->{$type}, $count ); $res = _SDreadattr( $sds_id, $j, $self->{DATASET}->{$name}->{ATTRS}->{$attrname} ); die "$sub: ** sdReadAttr **\n" if($res == PDL::IO::HDF->FAIL); # FIXME: This should be a constant if( $type == PDL::IO::HDF->DFNT_CHAR ) { $self->{DATASET}->{$name}->{ATTRS}->{$attrname} = Byte2Char( $self->{DATASET}->{$name}->{ATTRS}->{$attrname} ); } } } bless $self, $type; # Now that we're blessed, run our own accessors: # Default to using this (it's a good thing :) $self->Chunking( 1 ); return $self; } # End of new()... =head2 Chunking =for ref Accessor for the chunking mode on this HDF file. 'Chunking' is an internal compression and tiling the HDF library can perform on an SDS. This variable only affects they way SDput() works, and is ON by default. The code modifications enabled by this flag automatically partition the dataset to chunks of at least 100x100 values in size. The logic on this is pretty fancy, and would take a while to doc out here. If you _really_ have to know how it auto-partitions the data, then look at the code. Someday over the rainbow, I'll add some features for better control of the chunking parameters, if the need arises. For now, it's just stupid easy to use. =for usage Arguments: 1 (optional): new value for the chunking flag. =for example # See if chunking is currently on for this file: my $chunkvar = $hdf->Chunking(); # Turn the chunking off: my $newvar = $hdf->Chunking( 0 ); # Turn the chunking back on: my $newvar = $hdf->Chunking( 1 ); =cut # See the changelog for more docs on this feature: sub Chunking { my $self = shift; my $var = shift; if( defined( $var ) ) { $self->{CHUNKING} = $var ? 1 : 0; } return $self->{CHUNKING}; } # End of Chunking()... =head2 SDgetvariablenames =for ref get the list of datasets. =for usage No arguments Returns the list of dataset or undef on error. =for example my @DataList = $hdfobj->SDgetvariablenames(); =cut sub SDgetvariablenames { my($self) = @_; return sort keys %{$self->{DATASET}}; #line 442 "SD.pm" #line 668 "SD.pd" } # End of SDgetvariablenames()... sub SDgetvariablename { my $self = shift; return $self->SDgetvariablenames( @_ ); } # End of SDgetvariablename()... =head2 SDgetattributenames =for ref Get a list of the names of the global or SDS attributes. =for usage Arguments: 1 (optional) : The name of the SD dataset from which you want to get the attributes. This arg is optional, and without it, it will return the list of global attribute names. Returns a list of names or undef on error. =for example # For global attributes : my @attrList = $hdf->SDgetattributenames(); # For SDS attributes : my @attrList = $hdf->SDgetattributenames("dataset_name"); =cut sub SDgetattributenames { my($self, $name) = @_; if( defined( $name ) ) { return( undef ) unless defined( $self->{DATASET}->{$name} ); return sort keys %{ $self->{DATASET}->{$name}->{ATTRS} }; #line 486 "SD.pm" #line 710 "SD.pd" } else { return sort keys %{ $self->{GLOBATTR} }; #line 492 "SD.pm" #line 714 "SD.pd" } } # End of SDgetattributenames()... # Wrapper (this is now defunct): sub SDgetattributname { my $self = shift; return $self->SDgetattributenames( @_ ); } # End of SDgetattributname()... =head2 SDgetattribute =for ref Get a global or SDS attribute value. =for usage Arguments: 1 : The name of the attribute. 2 (optional): The name of the SDS from which you want to get the attribute value. Without this arg, it returns the global attribute value of that name. Returns an attribute value or undef on error. =for example # for global attributs : my $attr = $hdf->SDgetattribute("attr_name"); # for local attributs : my $attr = $hdf->SDgetattribute("attr_name", "dataset_name"); =cut sub SDgetattribute { my($self, $name, $dataset) = @_; if( defined($dataset) ) { # It's an SDS attribute: return( undef ) unless defined( $self->{DATASET}->{$dataset} ); return $self->{DATASET}->{$dataset}->{ATTRS}->{$name}; } else { # Global attribute: return( undef ) unless defined( $self->{GLOBATTR}->{$name} ); return $self->{GLOBATTR}->{$name}; } } # End of SDgetattribute()... # Wrapper (this is now defunct): sub SDgetattribut { my $self = shift; return $self->SDgetattribute( @_ ); } # End of SDgetattribut()... =head2 SDgetfillvalue =for ref Get the fill value of an SDS. =for usage Arguments: 1 : The name of the SDS from which you want to get the fill value. Returns the fill value or undef on error. =for example my $fillvalue = $hdf->SDgetfillvalue("dataset_name"); =cut sub SDgetfillvalue { my($self, $name) = @_; return( undef ) unless defined( $self->{DATASET}->{$name} ); return ($self->{DATASET}->{$name}->{ATTRS}->{_FillValue})->at(0); } # End of SDgetfillvalue()... =head2 SDgetrange =for ref Get the valid range of an SDS. =for usage Arguments: 1 : the name of the SDS from which you want to get the valid range. Returns a list of two elements [min, max] or undef on error. =for example my @range = $hdf->SDgetrange("dataset_name"); =cut sub SDgetrange { my($self, $name) = @_; return( undef ) unless defined( $self->{DATASET}->{$name} ); return $self->{DATASET}->{$name}->{ATTRS}->{valid_range}; } # End of SDgetrange()... =head2 SDgetscalefactor =for ref Get the scale factor of an SDS. =for usage Arguments: 1 : The name of the SDS from which you want to get the scale factor. Returns the scale factor or undef on error. =for example my $scale = $hdf->SDgetscalefactor("dataset_name"); =cut sub SDgetscalefactor { my($self, $name) = @_; return( undef ) unless defined( $self->{DATASET}->{$name} ); return ($self->{DATASET}->{$name}->{ATTRS}->{scale_factor})->at(0); } # End of SDgetscalefactor()... =head2 SDgetdimsize =for ref Get the dimensions of a dataset. =for usage Arguments: 1 : The name of the SDS from which you want to get the dimensions. Returns an array of n dimensions with their sizes or undef on error. =for example my @dim = $hdf->SDgetdimsize("dataset_name"); =cut sub SDgetdimsize { my ($self, $name) = @_; return( undef ) unless defined( $self->{DATASET}->{$name} ); my @dims; foreach( sort keys %{ $self->{DATASET}->{$name}->{DIMS} } ) #line 664 "SD.pm" #line 884 "SD.pd" { push @dims, $self->{DATASET}->{$name}->{DIMS}->{$_}->{SIZE}; } return( @dims ); } # End of SDgetdimsize()... =head2 SDgetunlimiteddimsize =for ref Get the actual dimensions of an SDS with 'unlimited' dimensions. =for usage Arguments: 1 : The name of the SDS from which you want to the dimensions. Returns an array of n dimensions with the dim sizes or undef on error. =for example my @dims = $hdf->SDgetunlimiteddimsize("dataset_name"); =cut sub SDgetunlimiteddimsize { my ($self, $name) = @_; return( undef ) unless defined( $self->{DATASET}->{$name} ); my @dim; foreach( sort keys %{$self->{DATASET}{$name}{DIMS}} ) #line 702 "SD.pm" #line 920 "SD.pd" { if( $self->{DATASET}->{$name}->{DIMS}->{$_}->{SIZE} == 0 ) { $dim[ $_ ] = $self->{DATASET}->{$name}->{DIMS}->{$_}->{REAL_SIZE}; } else { $dim[ $_ ] = $self->{DATASET}->{$name}->{DIMS}->{$_}->{SIZE}; } } return(@dim); } # End of SDgetunlimiteddimsize()... # Wrapper (this is now defunct): sub SDgetdimsizeunlimit { my $self = shift; return $self->SDgetunlimiteddimsize( @_ ); } # End of SDgetdimsizeunlimit()... =head2 SDgetdimnames =for ref Get the names of the dimensions of a dataset. =for usage Arguments: 1 : the name of a dataset you want to get the dimensions'names . Returns an array of n dimensions with their names or an empty list if error. =for example my @dim_names = $hdf->SDgetdimnames("dataset_name"); =cut sub SDgetdimnames { my ($self, $name) = @_; return( undef ) unless defined( $self->{DATASET}->{$name} ); my @dims=(); foreach( sort keys %{ $self->{DATASET}->{$name}->{DIMS} } ) #line 754 "SD.pm" #line 970 "SD.pd" { push @dims,$self->{DATASET}->{$name}->{DIMS}->{$_}->{NAME}; } return(@dims); } # End of SDgetdimnames()... sub SDgetdimname { my $self = shift; return $self->SDgetdimnames( @_ ); } # End of SDgetdimname(); =head2 SDgetcal =for ref Get the calibration factor from an SDS. =for usage Arguments: 1 : The name of the SDS Returns (scale factor, scale factor error, offset, offset error, data type), or undef on error. =for example my ($cal, $cal_err, $off, $off_err, $d_type) = $hdf->SDgetcal("dataset_name"); =cut sub SDgetcal { my ($self, $name ) = @_; my ($cal, $cal_err, $off, $off_err, $type); return( undef ) unless defined( $self->{DATASET}->{$name} ); return( undef ) unless defined( $self->{DATASET}->{$name}->{ATTRS}->{scale_factor} ); $cal = $self->{DATASET}->{$name}->{ATTRS}->{scale_factor}; $cal_err = $self->{DATASET}->{$name}->{ATTRS}->{scale_factor_err}; $off = $self->{DATASET}->{$name}->{ATTRS}->{add_offset}; $off_err = $self->{DATASET}->{$name}->{ATTRS}->{add_offset_err}; $type = $self->{DATASET}->{$name}->{ATTRS}->{calibrated_nt}; return( $cal, $cal_err, $off, $off_err, $type ); } # End of SDgetcal()... =head2 SDget =for ref Get a the data from and SDS, or just a slice of that SDS. =for usage Arguments: 1 : The name of the SDS you want to get. 2 (optional): The start array ref of the slice. 3 (optional): The size array ref of the slice (HDF calls this the 'edge'). 4 (optional): The stride array ref of the slice. Returns a PDL of data if ok, PDL::null on error. If the slice arguments are not given, this function will read the entire SDS from the file. The type of the returned PDL variable is the PDL equivalent of what was stored in the HDF file. =for example # Get the entire SDS: my $pdldata = $hdf->SDget("dataset_name"); # get a slice of the dataset my $start = [10,50,10]; # the start position of the slice is [10, 50, 10] my $edge = [20,20,20]; # read 20 values on each dimension from @start my $stride = [1, 1, 1]; # Don't skip values my $pdldata = $hdf->SDget( "dataset_name", $start, $edge, $stride ); =cut sub SDget { my($self, $name, $start, $end, $stride) = @_; my $sub = _pkg_name( 'SDget' ); return null unless defined( $self->{DATASET}->{$name} ); unless( defined( $end ) ) { # \@end was not passed in, so we need to set everything else to defaults: ($start, $end) = []; my @dimnames=$self->SDgetdimnames($name); for my $dim (0 .. $#dimnames) { my $use_size = $self->{DATASET}->{$name}->{DIMS}->{$dim}->{SIZE} || $self->{DATASET}->{$name}->{DIMS}->{$dim}->{REAL_SIZE}; $$end[ $dim ] = $use_size; $$start[ $dim ] = 0; $$stride[ $dim ] = 1; } } my $c_start = pack ("L*", @$start); my $c_end = pack ("L*", @$end); my $c_stride = pack ("L*", @$stride); #print STDERR "$sub: start:[".join(',',@$start) # ."]=>$c_start end:[".join(',',@$end) # ."]=>$c_end stride:[".join(',',@$stride)."]=>$c_stride\n"; my $buff = zeroes( $PDL::IO::HDF::SDinvtypeTMAP2->{$self->{DATASET}->{$name}->{TYPE}}, reverse @$end ); my $res = _SDreaddata( $self->{DATASET}->{$name}->{SDSID}, $c_start, $c_stride, $c_end, $buff ); if($res == PDL::IO::HDF->FAIL) { $buff = null; print "$sub: Error returned from _SDreaddata()!\n"; } return $buff; } # End of SDget()... =head2 SDsetfillvalue =for ref Set the fill value for an SDS. =for usage Arguments: 1 : The name of the SDS. 2 : The fill value. Returns true on success, undef on error. =for example my $res = $hdf->SDsetfillvalue("dataset_name",$fillvalue); =cut sub SDsetfillvalue { my ($self, $name, $value) = @_; return( undef ) unless defined( $self->{DATASET}->{$name} ); $value = &{$PDL::IO::HDF::SDinvtypeTMAP->{$self->{DATASET}->{$name}->{TYPE}}}($value); $self->{DATASET}->{$name}->{ATTRS}->{_FillValue} = $value; return( _SDsetfillvalue($self->{DATASET}->{$name}->{SDSID}, $value) + 1 ); } # End of SDsetfillvalue()... =head2 SDsetrange =for ref Set the valid range of an SDS. =for usage Arguments: 1 : The name of the SDS 2 : an anonymous array of two elements : [min, max]. Returns true on success, undef on error. =for example my $res = $hdf->SDsetrange("dataset_name", [$min, $max]); =cut sub SDsetrange { my ($self, $name, $range) = @_; return undef unless defined( $self->{DATASET}->{$name} ); my $min = &{$PDL::IO::HDF::SDinvtypeTMAP->{$self->{DATASET}->{$name}->{TYPE}}}($$range[0]); my $max = &{$PDL::IO::HDF::SDinvtypeTMAP->{$self->{DATASET}->{$name}->{TYPE}}}($$range[1]); $range = &{$PDL::IO::HDF::SDinvtypeTMAP->{$self->{DATASET}->{$name}->{TYPE}}}($range); $self->{DATASET}->{$name}->{ATTRS}->{valid_range} = $range; return( _SDsetrange($self->{DATASET}->{$name}->{SDSID}, $max, $min) + 1 ); } # End of SDsetrange()... =head2 SDsetcal =for ref Set the HDF calibration for an SDS. In HDF lingo, this means to define: scale factor scale factor error offset offset error =for usage Arguments: 1 : The name of the SDS. 2 (optional): the scale factor (default is 1) 3 (optional): the scale factor error (default is 0) 4 (optional): the offset (default is 0) 5 (optional): the offset error (default is 0) Returns true on success, undef on error. NOTE: This is not required to make a valid HDF SDS, but is there if you want to use it. =for example # Create the dataset: my $res = $hdf->SDsetcal("dataset_name"); # To just set the scale factor: $res = $hdf->SDsetcal("dataset_name", $scalefactor); # To set all calibration parameters: $res = $hdf->SDsetcal("dataset_name", $scalefactor, $scale_err, $offset, $off_err); =cut sub SDsetcal { my $self = shift; my $name = shift; return( undef ) unless defined( $self->{DATASET}->{$name} ); $self->{DATASET}->{$name}->{ATTRS}->{scale_factor} = shift || 1; $self->{DATASET}->{$name}->{ATTRS}->{scale_factor_err} = shift || 0; $self->{DATASET}->{$name}->{ATTRS}->{add_offset} = shift || 0; $self->{DATASET}->{$name}->{ATTRS}->{add_offset_err} = shift || 0; # PDL_Double is the default type: $self->{DATASET}->{$name}->{ATTRS}->{calibrated_nt} = shift || 6; return( _SDsetcal( $self->{DATASET}->{$name}->{SDSID}, $self->{DATASET}->{$name}->{ATTRS}->{scale_factor}, $self->{DATASET}->{$name}->{ATTRS}->{scale_factor_err}, $self->{DATASET}->{$name}->{ATTRS}->{add_offset}, $self->{DATASET}->{$name}->{ATTRS}->{add_offset_err}, $self->{DATASET}->{$name}->{ATTRS}->{calibrated_nt} ) + 1); } # End of SDsetcal()... =head2 SDsetcompress =for ref Set the internal compression on an SDS. =for usage Arguments: 1 : The name of the SDS. 2 (optional): The gzip compression level ( 1 - 9 ). If not specified, then 6 is used. Returns true on success, undef on failure. WARNING: This is a fairly buggy feature with many version of the HDF library. Please just use the 'Chunking' features instead, as they work far better, and are more reliable. =for example my $res = $hdf->SDsetfillvalue("dataset_name",$deflate_value); =cut sub SDsetcompress { my ($self, $name) = @_; return( undef ) unless defined( $self->{DATASET}->{$name} ); # NOTE: Behavior change from the old version: # it used to set to 6 if the passed value was greater than 8 # it now sets it to 9 if it's greater than 9. my $deflate = shift || 6; $deflate = 9 if( $deflate > 9 ); return( 1 + _SDsetcompress( $self->{DATASET}->{$name}->{SDSID}, $deflate ) ); } # End of SDsetcompress()... =head2 SDsettextattr =for ref Add a text HDF attribute, either globally, or to an SDS. =for usage Arguments: 1 : The text you want to add. 2 : The name of the attribute 3 (optional): The name of the SDS. Returns true on success, undef on failure. =for example # Set a global text attribute: my $res = $hdf->SDsettextattr("my_text", "attribut_name"); # Set a local text attribute for 'dataset_name': $res = $hdf->SDsettextattr("my_text", "attribut_name", "dataset_name"); =cut sub SDsettextattr { my ($self, $text, $name, $dataset) = @_; if( defined($dataset) ) { return( undef ) unless defined( $self->{DATASET}->{$dataset} ); $self->{DATASET}->{$dataset}->{ATTRS}->{$name} = $text; return( _SDsetattr_text( $self->{DATASET}->{$dataset}->{SDSID}, $name, $text, length($text) ) + 1 ); } # Implied else it's a global attribute: $self->{GLOBATTR}->{$name} = $text; return( _SDsetattr_text( $self->{SDID}, $name, $text, length($text) ) + 1); } # End of SDsettextattr()... =head2 SDsetvalueattr =for ref Add a non-text HDF attribute, either globally, or to an SDS. =for usage Arguments: 1 : A pdl of value(s) you want to store. 2 : The name of the attribute. 3 (optional): the name of the SDS. Returns true on success, undef on failure. =for example my $attr = sequence( long, 4 ); # Set a global attribute: my $res = $hdf->SDsetvalueattr($attribute, "attribute_name"); # Set a local attribute for 'dataset_name': $res = $hdf->SDsetvalueattr($attribute, "attribute_name", "dataset_name"); =cut sub SDsetvalueattr { my ($self, $values, $name, $dataset) = @_; if( defined($dataset) ) { return( undef ) unless defined( $self->{DATASET}->{$dataset} ); $self->{DATASET}->{$dataset}->{ATTRS}->{$name} = $values; return( _SDsetattr_values( $self->{DATASET}->{$dataset}->{SDSID}, $name, $values, $values->nelem(), $PDL::IO::HDF::SDtypeTMAP->{$values->get_datatype()} ) + 1); } # Implied else it's a global attribute: $self->{GLOBATTR}->{$name} = $values; return( _SDsetattr_values( $self->{SDID}, $name, $values, $values->nelem(), $PDL::IO::HDF::SDtypeTMAP->{$values->get_datatype()} ) + 1); } # End of SDsetvalueattr()... =head2 SDsetdimname =for ref Set or rename the dimensions of an SDS. =for usage Arguments: 1 : The name of the SDS. 2 : An anonymous array with the dimensions names. For dimensions you want to leave alone, leave 'undef' placeholders. Returns true on success, undef on failure. =for example # Rename all dimensions my $res = $hdf->SDsetdimname("dataset_name", ['dim1','dim2','dim3']); # Rename some dimensions $res = $hdf->SDsetdimname("dataset_name", ['dim1', undef ,'dim3']); =cut # FIXME: There are several problems with this: # - The return code is an aggregate, and not necessarily accurate # - It bails on the first error without trying the rest. If that is still # desired, then it should run the check first, and if it's ok, then actually # make the HDF library call. sub SDsetdimname { my ($self, $name, $dimname) = @_; return undef unless defined( $self->{DATASET}->{$name} ); my $res = 0; foreach( sort keys %{$self->{DATASET}->{$name}->{DIMS}} ) #line 1196 "SD.pm" #line 1410 "SD.pd" { return( undef ) unless defined( $$dimname[ $_ ] ); $res = _SDsetdimname( $self->{DATASET}->{$name}->{DIMS}->{$_}->{DIMID}, $$dimname[ $_ ] ) + 1; } return( $res ); } # End of SDsetdimname()... =head2 SDput =for ref Write to a SDS in an HDF file or create and write to it if it doesn't exist. =for usage Arguments: 1 : The name of the SDS. 2 : A pdl of data. 3 (optional): An anonymous array of the dim names (only for creation) 4 (optional): An anonymous array of the start of the slice to store (only for putting a slice) Returns true on success, undef on failure. The datatype of the SDS in the HDF file will match the PDL equivalent as much as possible. =for example my $data = sequence( float, 10, 20, 30 ); #any value you want # Simple case: create a new dataset with a $data pdl my $result = $hdf->SDput("dataset_name", $data); # Above, but also naming the dims: $res = $hdf->SDput("dataset_name", $data, ['dim1','dim2','dim3']); # Just putting a slice in there: my $start = [x,y,z]; $res = $hdf->SDput("dataset_name", $data->slice("..."), undef, $start); =cut sub SDput { my($self, $name, $data, $dimname_p, $from) = @_; my $sub = _pkg_name( 'SDput' ); my $rank = $data->getndims(); my $dimsize = pack ("L*", reverse $data->dims); # If this dataset doesn't already exist, then create it: # unless ( defined( $self->{DATASET}->{$name} ) ) { my $hdf_type = $PDL::IO::HDF::SDtypeTMAP->{$data->get_datatype()}; my $res = _SDcreate( $self->{SDID}, $name, $hdf_type, $rank, $dimsize ); return( undef ) if ($res == PDL::IO::HDF->FAIL); $self->{DATASET}->{$name}->{SDSID} = $res; $self->{DATASET}->{$name}->{TYPE} = $hdf_type; $self->{DATASET}->{$name}->{RANK} = $rank; if( $self->Chunking() ) { # Setup chunking on this dataset: my @chunk_lens; my $min_chunk_size = 100; my $num_chunks = 10; my $total_chunks = 1; foreach my $dimsize ( $data->dims() ) { my $chunk_size = ($dimsize + 9) / $num_chunks; my $num_chunks_this_dim = $num_chunks; if( $chunk_size < $min_chunk_size ) { $chunk_size = $min_chunk_size; # Re-calc the num_chunks_per_dim: $num_chunks_this_dim = POSIX::ceil( $dimsize / $chunk_size ); } push(@chunk_lens, $chunk_size); $total_chunks *= $num_chunks_this_dim; } my $chunk_lengths = pack("L*", reverse @chunk_lens); $res = _SDsetchunk( $self->{DATASET}->{$name}->{SDSID}, $rank, $chunk_lengths ); return( undef ) if ($res == PDL::IO::HDF->FAIL); $res = _SDsetchunkcache( $self->{DATASET}->{$name}->{SDSID}, $total_chunks, 0); return( undef ) if ($res == PDL::IO::HDF->FAIL); } # End of chunking section... } # End of dataset creation... my $start = []; my $stride = []; if( defined( $from ) ) { $start = $from; foreach($data->dims) { push(@$stride, 1); } } else { # $from was not defined, so assume we're doing all of it: foreach($data->dims) { push(@$start, 0); push(@$stride, 1); } } $start = pack ("L*", @$start); $stride = pack ("L*", @$stride); $data->make_physical(); my $res = _SDwritedata( $self->{DATASET}->{$name}->{SDSID}, $start, $stride, $dimsize, $data ); return( undef ) if ($res == PDL::IO::HDF->FAIL); foreach my $j ( 0 .. $rank-1 ) { # Probably not a good way to bail: my $dim_id = _SDgetdimid( $self->{DATASET}->{$name}->{SDSID}, $j ); return( undef ) if( $dim_id == PDL::IO::HDF->FAIL); if( defined( @$dimname_p[$j] ) ) { $res = _SDsetdimname( $dim_id, @$dimname_p[$j] ); return( undef ) if( $res == PDL::IO::HDF->FAIL ); } my $dimname = " "x(PDL::IO::HDF->MAX_NC_NAME); my $size = 0; my $num_dim_attrs = 0; $res = _SDdiminfo( $dim_id, $dimname, $size, my $numtype=0, $num_dim_attrs); return( undef ) if ($res == PDL::IO::HDF->FAIL); $self->{DATASET}->{$name}->{DIMS}->{$j}->{NAME} = $dimname; $self->{DATASET}->{$name}->{DIMS}->{$j}->{SIZE} = $size; $self->{DATASET}->{$name}->{DIMS}->{$j}->{DIMID} = $dim_id; } return( 1 ); } # End of SDput()... =head2 close =for ref Close an HDF file. =for usage No arguments. =for example my $result = $hdf->close(); =cut # NOTE: This may not be enough, since there may be opened datasets as well! SDendaccess()! sub close { my $self = shift; my $sdid = $self->{SDID}; $self = undef; return( _SDend( $sdid ) + 1); } # End of close()... sub DESTROY { my $self = shift; $self->close; } # End of DESTROY()... #line 1384 "SD.pm" #line 1603 "SD.pd" =head1 CURRENT AUTHOR & MAINTAINER Judd Taylor, Orbital Systems, Ltd. judd dot t at orbitalsystems dot com =head1 PREVIOUS AUTHORS Patrick Leilde patrick.leilde@ifremer.fr contribs of Olivier Archer olivier.archer@ifremer.fr =head1 SEE ALSO perl(1), PDL(1), PDL::IO::HDF(1). =cut #line 1405 "SD.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/IO/Misc.pm0000644000175000017500000011710714200406310015545 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::IO::Misc; our @EXPORT_OK = qw(rcols wcols swcols rgrep bswap2 bswap4 bswap8 isbigendian rasc rcube _rasc ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::IO::Misc ; #line 8 "misc.pd" use strict; use warnings; =head1 NAME PDL::IO::Misc - misc IO routines for PDL =head1 DESCRIPTION Some basic I/O functionality: FITS, tables, byte-swapping =head1 SYNOPSIS use PDL::IO::Misc; =cut #line 42 "Misc.pm" =head1 FUNCTIONS =cut #line 48 "misc.pd" use PDL::Primitive; use PDL::Types; use PDL::Options; use PDL::Bad; use Carp; use Symbol qw/ gensym /; use List::Util; use strict; #line 66 "Misc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 bswap2 =for sig Signature: (x(); ) =for ref Swaps pairs of bytes in argument x() =for bad bswap2 does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 90 "Misc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *bswap2 = \&PDL::bswap2; #line 96 "Misc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 bswap4 =for sig Signature: (x(); ) =for ref Swaps quads of bytes in argument x() =for bad bswap4 does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 120 "Misc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *bswap4 = \&PDL::bswap4; #line 126 "Misc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 bswap8 =for sig Signature: (x(); ) =for ref Swaps octets of bytes in argument x() =for bad bswap8 does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 150 "Misc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *bswap8 = \&PDL::bswap8; #line 156 "Misc.pm" #line 125 "misc.pd" # Internal routine to extend PDL array by size $n along last dimension # - Would be nice to have a proper extend function rather than hack # - Is a NO-OP when handed a perl ARRAY ref rather than an ndarray arg sub _ext_lastD { # Called by rcols and rgrep my ($x,$n) = @_; if (ref($_[0]) ne 'ARRAY') { my @nold = $x->dims; my @nnew = @nold; $nnew[-1] += $n; # add $n to the last dimension my $y = zeroes($x->type,@nnew); # New pdl my $yy = $y->mv(-1,0)->slice("0:".($nold[-1]-1))->mv(0,-1); $yy .= $x; $_[0] = $y; } 1; } # Implements PDL->at() for either 1D PDL or ARRAY arguments # TODO: Need to add support for multidim ndarrays parallel to rcols sub _at_1D ($$) { # Called by wcols and swcols my $data = $_[0]; my $index = $_[1]; if (ref $data eq 'ARRAY') { return $data->[$index]; } else { return $data->at($index); } } # squeezes "fluffy" perl list values into column data type sub _burp_1D { my $data = $_[0]->[0]; my $databox = $_[0]->[1]; my $index = $_[1]; my $start = $index - @{$databox} + 1; my $tmp; # work around for perl -d "feature" if (ref $data eq 'ARRAY') { push @{$data}, @{$databox}; } elsif ( ref($databox->[0]) eq "ARRAY" ) { # could add POSIX::strtol for hex and octal support but # can't break float conversions (how?) ($tmp = $data->slice(":,$start:$index")) .= pdl($databox); } else { # could add POSIX::strtol for hex and octal support but # can't break float conversions (how?) ($tmp = $data->slice("$start:$index")) .= pdl($databox); } $_[0] = [ $data, [] ]; } # taken outside of rcols() to avoid clutter sub _handle_types ($$$) { my $ncols = shift; my $deftype = shift; my $types = shift; barf "Unknown PDL type given for DEFTYPE.\n" unless ref($deftype) eq "PDL::Type"; my @cols = ref($types) eq "ARRAY" ? @$types : (); if ( $#cols > -1 ) { # truncate if required $#cols = $ncols if $#cols > $ncols; # check input values are sensible for ( 0 .. $#cols ) { barf "Unknown value '$cols[$_]' in TYPES array.\n" unless ref($cols[$_]) eq "PDL::Type"; } } # fill in any missing columns for ( ($#cols+1) .. $ncols ) { push @cols, $deftype; } return @cols; } # sub: _handle_types # Whether an object is an IO handle use Scalar::Util; sub _is_io_handle { my $h = shift; # reftype catches almost every handle, except: *MYHANDLE # fileno catches *MYHANDLE, but doesn't catch handles that aren't files my $reftype = Scalar::Util::reftype($h); return defined(fileno($h)) || (defined($reftype) && $reftype eq 'GLOB'); } =head2 rcols =for ref Read specified ASCII cols from a file into ndarrays and perl arrays (also see L). =for usage Usage: ($x,$y,...) = rcols( *HANDLE|"filename", { EXCLUDE => '/^!/' }, $col1, $col2, ... ) $x = rcols( *HANDLE|"filename", { EXCLUDE => '/^!/' }, [] ) ($x,$y,...) = rcols( *HANDLE|"filename", $col1, $col2, ..., { EXCLUDE => '/^!/' } ) ($x,$y,...) = rcols( *HANDLE|"filename", "/foo/", $col1, $col2, ... ) For each column number specified, a 1D output PDL will be generated. Anonymous arrays of column numbers generate 2D output ndarrays with dim0 for the column data and dim1 equal to the number of columns in the anonymous array(s). An empty anonymous array as column specification will produce a single output data ndarray with dim(1) equal to the number of columns available. There are two calling conventions - the old version, where a pattern can be specified after the filename/handle, and the new version where options are given as as hash reference. This reference can be given as either the second or last argument. The default behaviour is to ignore lines beginning with a # character and lines that only consist of whitespace. Options exist to only read from lines that match, or do not match, supplied patterns, and to set the types of the created ndarrays. Can take file name or *HANDLE, and if no explicit column numbers are specified, all are assumed. For the allowed types, see L. Options (case insensitive): EXCLUDE or IGNORE - ignore lines matching this pattern (default B<'/^#/'>). INCLUDE or KEEP - only use lines which match this pattern (default B<''>). LINES - a string pattern specifying which line numbers to use. Line numbers start at 0 and the syntax is 'a:b:c' to use every c'th matching line between a and b (default B<''>). DEFTYPE - default data type for stored data (if not specified, use the type stored in C<$PDL::IO::Misc::deftype>, which starts off as B). TYPES - reference to an array of data types, one element for each column to be read in. Any missing columns use the DEFTYPE value (default B<[]>). COLSEP - splits on this string/pattern/qr{} between columns of data. Defaults to $PDL::IO::Misc::defcolsep. PERLCOLS - an array of column numbers which are to be read into perl arrays rather than ndarrays. Any columns not specified in the explicit list of columns to read will be returned after the explicit columns. (default B). COLIDS - if defined to an array reference, it will be assigned the column ID values obtained by splitting the first line of the file in the identical fashion to the column data. CHUNKSIZE - the number of input data elements to batch together before appending to each output data ndarray (Default value is 100). If CHUNKSIZE is greater than the number of lines of data to read, the entire file is slurped in, lines split, and perl lists of column data are generated. At the end, effectively pdl(@column_data) produces any result ndarrays. VERBOSE - be verbose about IO processing (default C<$PDL::vebose>) =for example For example: $x = PDL->rcols 'file1'; # file1 has only one column of data $x = PDL->rcols 'file2', []; # file2 can have multiple columns, still 1 ndarray output # (empty array ref spec means all possible data fields) ($x,$y) = rcols 'table.csv', { COLSEP => ',' }; # read CSV data file ($x,$y) = rcols *STDOUT; # default separator for lines like '32 24' # read in lines containing the string foo, where the first # example also ignores lines that begin with a # character. ($x,$y,$z) = rcols 'file2', 0,4,5, { INCLUDE => '/foo/' }; ($x,$y,$z) = rcols 'file2', 0,4,5, { INCLUDE => '/foo/', EXCLUDE => '' }; # ignore the first 27 lines of the file, reading in as ushort's ($x,$y) = rcols 'file3', { LINES => '27:-1', DEFTYPE => ushort }; ($x,$y) = rcols 'file3', { LINES => '27:', TYPES => [ ushort, ushort ] }; # read in the first column as a perl array and the next two as ndarrays # with the perl column returned after the ndarray outputs ($x,$y,$name) = rcols 'file4', 1, 2 , { PERLCOLS => [ 0 ] }; printf "Number of names read in = %d\n", 1 + $#$name; # read in the first column as a perl array and the next two as ndarrays # with PERLCOLS changing the type of the first returned value to perl list ref ($name,$x,$y) = rcols 'file4', 0, 1, 2, { PERLCOLS => [ 0 ] }; # read in the first column as a perl array returned first followed by the # the next two data columns in the file as a single Nx2 ndarray ($name,$xy) = rcols 'file4', 0, [1, 2], { PERLCOLS => [ 0 ] }; NOTES: 1. Quotes are required on patterns or use the qr{} quote regexp syntax. 2. Columns are separated by whitespace by default, use the COLSEP option separator to specify an alternate split pattern or string or specify an alternate default separator by setting C<$PDL::IO::Misc::defcolsep> . 3. Legacy support is present to use C<$PDL::IO::Misc::colsep> to set the column separator but C<$PDL::IO::Misc::colsep> is not defined by default. If you set the variable to a defined value it will get picked up. 4. LINES => '-1:0:3' may not work as you expect, since lines are skipped when read in, then the whole array reversed. 5. For consistency with wcols and rcols 1D usage, column data is loaded into the rows of the pdls (i.e., dim(0) is the elements read per column in the file and dim(1) is the number of columns of data read. =cut use vars qw/ $colsep $defcolsep $deftype /; $defcolsep = ' '; # Default column separator $deftype = double; # Default type for ndarrays my $defchunksize = 100; # Number of perl list items to append to ndarray my $usecolsep; # This is the colsep value that is actually used # NOTE: XXX # need to look at the line-selection code. For instance, if want # lines => '-1:0:3', # read in all lines, reverse, then apply the step # -> fix point 4 above # # perhaps should just simplify the LINES option - ie remove # support for reversed arrays? sub rcols{ PDL->rcols(@_) } sub PDL::rcols { my $class = shift; barf 'Usage ($x,$y,...) = rcols( *HANDLE|"filename", ["/pattern/" or \%options], $col1, $col2, ..., [ \%options] )' if $#_<0; my $is_handle = _is_io_handle $_[0]; my $fh = $is_handle ? $_[0] : gensym; open $fh, $_[0] or die "File $_[0] not found\n" unless $is_handle; shift; # set up default options my $opt = new PDL::Options( { CHUNKSIZE => undef, COLIDS => undef, COLSEP => undef, DEFTYPE => $deftype, EXCLUDE => '/^#/', INCLUDE => undef, LINES => '', PERLCOLS => undef, TYPES => [], VERBOSE=> $PDL::verbose, } ); $opt->synonyms( { IGNORE => 'EXCLUDE', KEEP => 'INCLUDE' } ); # has the user supplied any options if ( defined($_[0]) ) { # ensure the old-style behaviour by setting the exclude pattern to undef if ( $_[0] =~ m|^/.*/$| ) { $opt->options( { EXCLUDE => undef, INCLUDE => shift } ); } elsif ( ref($_[0]) eq "Regexp" ) { $opt->options( { EXCLUDE => undef, INCLUDE => shift } ); } elsif ( ref($_[0]) eq "HASH" ) { $opt->options( shift ); } } # maybe the last element is a hash array as well $opt->options( pop ) if defined($_[-1]) and ref($_[-1]) eq "HASH"; # a reference to a hash array my $options = $opt->current(); # handle legacy colsep variable $usecolsep = (defined $colsep) ? qr{$colsep} : undef; $usecolsep = qr{$options->{COLSEP}} if $options->{COLSEP}; # what are the patterns? foreach my $pattern ( qw( INCLUDE EXCLUDE ) ) { if ( $options->{$pattern} and ref($options->{$pattern}) ne "Regexp" ) { if ( $options->{$pattern} =~ m|^/.*/$| ) { $options->{$pattern} =~ s|^/(.*)/$|$1|; $options->{$pattern} = qr($options->{$pattern}); } else { barf "rcols() - unable to process $pattern value.\n"; } } } # CHUNKSIZE controls memory/time tradeoff of ndarray IO my $chunksize = $options->{CHUNKSIZE} || $defchunksize; my $nextburpindex = -1; # which columns are to be read into ndarrays and which into perl arrays? my @end_perl_cols = (); # unique perl cols to return at end my @perl_cols = (); # perl cols index list from PERLCOLS option @perl_cols = @{ $$options{PERLCOLS} } if $$options{PERLCOLS}; my @is_perl_col; # true if index corresponds to a perl column for (@perl_cols) { $is_perl_col[$_] = 1; }; # print STDERR "rcols: \@is_perl_col is @is_perl_col\n"; my ( @explicit_cols ) = @_; # call specified columns to read # print STDERR "rcols: \@explicit_cols is @explicit_cols\n"; # work out which line numbers are required # - the regexp's are a bit over the top my ( $x, $y, $c ); if ( $$options{LINES} ne '' ) { if ( $$options{LINES} =~ /^\s*([+-]?\d*)\s*:\s*([+-]?\d*)\s*$/ ) { $x = $1; $y = $2; } elsif ( $$options{LINES} =~ /^\s*([+-]?\d*)\s*:\s*([+-]?\d*)\s*:\s*([+]?\d*)\s*$/ ) { $x = $1; $y = $2; $c = $3; } else { barf "rcols() - unable to parse LINES option.\n"; } } # Since we do not know how many lines there are in advance, things get a bit messy my ( $index_start, $index_end ) = ( 0, -1 ); $index_start = $x if defined($x) and $x ne ''; $index_end = $y if defined($y) and $y ne ''; my $line_step = $c || 1; # $line_rev = 0/1 for normal order/reversed # $line_start/_end refer to the first and last line numbers that we want # (the values of which we may not know until we've read in all the file) my ( $line_start, $line_end, $line_rev ); if ( ($index_start >= 0 and $index_end < 0) ) { # eg 0:-1 $line_rev = 0; $line_start = $index_start; } elsif ( $index_end >= 0 and $index_start < 0 ) { # eg -1:0 $line_rev = 1; $line_start = $index_end; } elsif ( $index_end >= $index_start and $index_start >= 0 ) { # eg 0:10 $line_rev = 0; $line_start = $index_start; $line_end = $index_end; } elsif ( $index_start > $index_end and $index_end >= 0 ) { # eg 10:0 $line_rev = 1; $line_start = $index_end; $line_end = $index_start; } elsif ( $index_start <= $index_end ) { # eg -5:-1 $line_rev = 0; } else { # eg -1:-5 $line_rev = 1; } my @ret; my ($k,$fhline); my $line_num = -1; my $line_ctr = $line_step - 1; # ensure first line is always included my $index = -1; my $pdlsize = 0; my $extend = 10000; my $line_store; # line numbers of saved data RCOLS_IO: { if ($options->{COLIDS}) { print STDERR "rcols: processing COLIDS option\n" if $options->{VERBOSE}; undef $!; if (defined($fhline = <$fh>) ) { # grab first line's fields for column IDs $fhline =~ s/\r?\n$//; # handle DOS on unix files better my @v = defined($usecolsep) ? split($usecolsep,$fhline) : split(' ',$fhline); @{$options->{COLIDS}} = @v; } else { die "rcols: reading COLIDS info, $!" if $!; last RCOLS_IO; } } while( defined($fhline = <$fh>) ) { # chomp $fhline; $fhline =~ s/\r?\n$//; # handle DOS on unix files better $line_num++; # the order of these checks is important, particularly whether we # check for line_ctr before or after the pattern matching # Prior to PDL 2.003 the line checks were done BEFORE the # pattern matching # # need this first check, even with it almost repeated at end of loop, # incase the pattern matching excludes $line_num == $line_end, say last if defined($line_end) and $line_num > $line_end; next if defined($line_start) and $line_num < $line_start; next if $options->{EXCLUDE} and $fhline =~ /$options->{EXCLUDE}/; next if $options->{INCLUDE} and not $fhline =~ /$options->{INCLUDE}/; next unless ++$line_ctr == $line_step; $line_ctr = 0; $index++; my @v = defined($usecolsep) ? split($usecolsep,$fhline) : split(' ',$fhline); # map empty fields '' to undef value @v = map { $_ eq '' ? undef : $_ } @v; # if the first line, set up the output ndarrays using all the columns # if the user doesn't specify anything if ( $index == 0 ) { # Handle implicit multicolumns in command line if ($#explicit_cols < 0) { # implicit single col data @explicit_cols = ( 0 .. $#v ); } if (scalar(@explicit_cols)==1 and ref($explicit_cols[0]) eq "ARRAY") { if ( !scalar(@{$explicit_cols[0]}) ) { # implicit multi-col data @explicit_cols = ( [ 0 .. $#v ] ); } } my $implicit_pdls = 0; my $is_explicit = {}; foreach my $col (@explicit_cols) { if (ref($col) eq "ARRAY") { $implicit_pdls++ if !scalar(@$col); } else { $is_explicit->{$col} = 1; } } if ($implicit_pdls > 1) { die "rcols: only one implicit multicolumn ndarray spec allowed, found $implicit_pdls!\n"; } foreach my $col (@explicit_cols) { if (ref($col) eq "ARRAY" and !scalar(@$col)) { @$col = grep { !$is_explicit->{$_} } ( 0 .. $#v ); } } # remove declared perl columns from pdl data list $k = 0; my @pdl_cols = (); foreach my $col (@explicit_cols) { # strip out declared perl cols so they won't be read into ndarrays if ( ref($col) eq "ARRAY" ) { @$col = grep { !$is_perl_col[$_] } @{$col}; push @pdl_cols, [ @{$col} ]; } elsif (!$is_perl_col[$col]) { push @pdl_cols, $col; } } # strip out perl cols in explicit col list for return at end @end_perl_cols = @perl_cols; foreach my $col (@explicit_cols) { if ( ref($col) ne "ARRAY" and defined($is_perl_col[$col]) ) { @end_perl_cols = grep { $_ != $col } @end_perl_cols; } }; # sort out the types of the ndarrays my @types = _handle_types( $#pdl_cols, $$options{DEFTYPE}, $$options{TYPES} ); if ( $options->{VERBOSE} ) { # dbg aid print "Reading data into ndarrays of type: [ "; foreach my $t ( @types ) { print $t->shortctype() . " "; } print "]\n"; } $k = 0; for (@explicit_cols) { # Using mixed list+ndarray data structure for performance tradeoff # between memory usage (perl list) and speed of IO (PDL operations) if (ref($_) eq "ARRAY") { # use multicolumn ndarray here push @ret, [ $class->zeroes($types[$k++],scalar(@{$_}),1), [] ]; } else { push @ret, ($is_perl_col[$_] ? [ [], [] ] : [ $class->zeroes($types[$k],1), [] ]); $k++ unless $is_perl_col[$_]; } } for (@end_perl_cols) { push @ret, [ [], [] ]; } $line_store = [ $class->zeroes(long,1), [] ]; # only need to store integers } # if necessary, extend PDL in buffered manner $k = 0; if ( $pdlsize < $index ) { for (@ret, $line_store) { _ext_lastD( $_->[0], $extend ); } $pdlsize += $extend; } # - stick perl arrays onto end of $ret $k = 0; for (@explicit_cols, @end_perl_cols) { if (ref($_) eq "ARRAY") { push @{ $ret[$k++]->[1] }, [ @v[ @$_ ] ]; } else { push @{ $ret[$k++]->[1] }, $v[$_]; } } # store the line number push @{$line_store->[1]}, $line_num; # need to burp out list if needed if ( $index >= $nextburpindex ) { for (@ret, $line_store) { _burp_1D($_,$index); } $nextburpindex = $index + $chunksize; } # Thanks to Frank Samuelson for this last if defined($line_end) and $line_num == $line_end; } } close($fh) unless $is_handle; # burp one final time if needed and # clean out additional ARRAY ref level for @ret for (@ret, $line_store) { _burp_1D($_,$index) if defined $_ and scalar @{$_->[1]}; $_ = $_->[0]; } # have we read anything in? if not, return empty ndarrays if ( $index == -1 ) { print "Warning: rcols() did not read in any data.\n" if $options->{VERBOSE}; if ( wantarray ) { foreach ( 0 .. $#explicit_cols ) { if ( $is_perl_col[$_] ) { $ret[$_] = PDL->null; } else { $ret[$_] = []; } } for ( @end_perl_cols ) { push @ret, []; } return ( @ret ); } else { return PDL->null; } } # if the user has asked for lines => 0:-1 or 0:10 or 1:10 or 1:-1, # - ie not reversed and the last line number is known - # then we can skip the following nastiness if ( $line_rev == 0 and $index_start >= 0 and $index_end >= -1 ) { for (@ret) { ## $_ = $_->mv(-1,0)->slice("0:${index}")->mv(0,-1) unless ref($_) eq 'ARRAY'; $_ = $_->mv(-1,0)->slice("0:${index}") unless ref($_) eq 'ARRAY'; # cols are dim(0) }; if ( $options->{VERBOSE} ) { if ( ref($ret[0]) eq 'ARRAY' ) { print "Read in ", scalar( @{ $ret[0] } ), " elements.\n"; } else { print "Read in ", $ret[0]->nelem, " elements.\n"; } } wantarray ? return(@ret) : return $ret[0]; } # Work out which line numbers we want. First we clean up the ndarray # containing the line numbers that have been read in $line_store = $line_store->slice("0:${index}"); # work out the min/max line numbers required if ( $line_rev ) { if ( defined($line_start) and defined($line_end) ) { my $dummy = $line_start; $line_start = $line_end; $line_end = $dummy; } elsif ( defined($line_start) ) { $line_end = $line_start; } else { $line_start = $line_end; } } $line_start = $line_num + 1 + $index_start if $index_start < 0; $line_end = $line_num + 1 + $index_end if $index_end < 0; my $indices; { no warnings 'precedence'; if ( $line_rev ) { $indices = which( $line_store >= $line_end & $line_store <= $line_start )->slice('-1:0'); } else { $indices = which( $line_store >= $line_start & $line_store <= $line_end ); } } # truncate the ndarrays for my $col ( @explicit_cols ) { if ( ref($col) eq "ARRAY" ) { for ( @$col ) { $ret[$_] = $ret[$_]->index($indices); } } else { $ret[$col] = $ret[$col]->index($indices) unless $is_perl_col[$col] }; } # truncate/reverse/etc the perl arrays my @indices_array = list $indices; foreach ( @explicit_cols, @end_perl_cols ) { if ( $is_perl_col[$_] ) { my @temp = @{ $ret[$_] }; $ret[$_] = []; foreach my $i ( @indices_array ) { push @{ $ret[$_] }, $temp[$i] }; } } # print some diagnostics if ( $options->{VERBOSE} ) { my $done = 0; foreach my $col (@explicit_cols) { last if $done; next if $is_perl_col[$col]; print "Read in ", $ret[$col]->nelem, " elements.\n"; $done = 1; } foreach my $col (@explicit_cols, @end_perl_cols) { last if $done; print "Read in ", $ret[$col]->nelem, " elements.\n"; $done = 1; } } # fix 2D pdls to match what wcols generates foreach my $col (@ret) { next if ref($col) eq "ARRAY"; $col = $col->transpose if $col->ndims == 2; } wantarray ? return(@ret) : return $ret[0]; } =head2 wcols =for ref Write ASCII columns into file from 1D or 2D ndarrays and/or 1D listrefs efficiently. Can take file name or *HANDLE, and if no file/filehandle is given defaults to STDOUT. Options (case insensitive): HEADER - prints this string before the data. If the string is not terminated by a newline, one is added. (default B<''>). COLSEP - prints this string between columns of data. Defaults to $PDL::IO::Misc::defcolsep. FORMAT - A printf-style format string that is cycled through column output for user controlled formatting. =for usage Usage: wcols $data1, $data2, $data3,..., *HANDLE|"outfile", [\%options]; # or wcols $format_string, $data1, $data2, $data3,..., *HANDLE|"outfile", [\%options]; where the $dataN args are either 1D ndarrays, 1D perl array refs, or 2D ndarrays (as might be returned from rcols() with the [] column syntax and/or using the PERLCOLS option). dim(0) of all ndarrays written must be the same size. The printf-style $format_string, if given, overrides any FORMAT key settings in the option hash. e.g., =for example $x = random(4); $y = ones(4); wcols $x, $y+2, 'foo.dat'; wcols $x, $y+2, *STDERR; wcols $x, $y+2, '|wc'; $x = sequence(3); $y = zeros(3); $c = random(3); wcols $x,$y,$c; # Orthogonal version of 'print $x,$y,$c' :-) wcols "%10.3f", $x,$y; # Formatted wcols "%10.3f %10.5g", $x,$y; # Individual column formatting $x = sequence(3); $y = zeros(3); $units = [ 'm/sec', 'kg', 'MPH' ]; wcols $x,$y, { HEADER => "# x y" }; wcols $x,$y, { Header => "# x y", Colsep => ', ' }; # case insensitive option names! wcols " %4.1f %4.1f %s",$x,$y,$units, { header => "# Day Time Units" }; $a52 = sequence(5,2); $y = ones(5); $c = [ 1, 2, 4 ]; wcols $a52; # now can write out 2D pdls (2 columns data in output) wcols $y, $a52, $c # ...and mix and match with 1D listrefs as well NOTES: 1. Columns are separated by whitespace by default, use C<$PDL::IO::Misc::defcolsep> to modify the default value or the COLSEP option 2. Support for the C<$PDL::IO::Misc::colsep> global value of PDL-2.4.6 and earlier is maintained but the initial value of the global is undef until you set it. The value will be then be picked up and used as if defcolsep were specified. 3. Dim 0 corresponds to the column data dimension for both rcols and wcols. This makes wcols the reverse operation of rcols. =cut *wcols = \&PDL::wcols; sub PDL::wcols { barf 'Usage: wcols($optional_format_string, 1_or_2D_pdls, *HANDLE|"filename", [\%options])' if @_<1; # handle legacy colsep variable $usecolsep = (defined $colsep) ? $colsep : $defcolsep; # if last argument is a reference to a hash, parse the options my ($format_string, $step, $fh); my $header; if ( ref( $_[-1] ) eq "HASH" ) { my $opt = pop; foreach my $key ( sort keys %$opt ) { if ( $key =~ /^H/i ) { $header = $opt->{$key}; } # option: HEADER elsif ( $key =~ /^COLSEP/i ) { $usecolsep = $opt->{$key}; } # option: COLSEP elsif ( $key =~ /^FORMAT/i ) { $format_string = $opt->{$key}; } # option: FORMAT else { print "Warning: wcols does not understand option <$key>.\n"; } } } if (ref(\$_[0]) eq "SCALAR" || $format_string) { $format_string = shift if (ref(\$_[0]) eq "SCALAR"); # 1st arg not ndarray, explicit format string overrides option hash FORMAT $step = $format_string; $step =~ s/(%%|[^%])//g; # use step to count number of format items $step = length ($step); } my $file = $_[-1]; my $file_opened; my $is_handle = !UNIVERSAL::isa($file,'PDL') && !UNIVERSAL::isa($file,'ARRAY') && _is_io_handle $file; if ($is_handle) { # file handle passed directly $fh = $file; pop; } else{ if (ref(\$file) eq "SCALAR") { # Must be a file name $fh = gensym; if (!$is_handle) { $file = ">$file" unless $file =~ /^\|/ or $file =~ /^\>/; open $fh, $file or barf "File $file can not be opened for writing\n"; } pop; $file_opened = 1; } else{ # Not a filehandle or filename, assume something else # (probably ndarray) and send to STDOUT $fh = *STDOUT; } } my @p = @_; my $n = (ref $p[0] eq 'ARRAY') ? $#{$p[0]}+1 : $p[0]->dim(0); my @dogp = (); # need to break 2D pdls into a their 1D pdl components for (@p) { if ( ref $_ eq 'ARRAY' ) { barf "wcols: 1D args must have same number of elements\n" if scalar(@{$_}) != $n; push @dogp, $_; } else { barf "wcols: 1D args must have same number of elements\n" if $_->dim(0) != $n or $_->getndims > 2; if ( $_->getndims == 2 ) { push @dogp, $_->dog; } else { push @dogp, $_; } } } if ( defined $header ) { $header .= "\n" unless $header =~ m/\n$/; print $fh $header; } my $i; my $pcnt = scalar @dogp; for ($i=0; $i<$n; $i++) { if ($format_string) { my @d; my $pdone = 0; for (@dogp) { push @d,_at_1D($_,$i); $pdone++; if (@d == $step) { printf $fh $format_string,@d; printf $fh $usecolsep unless $pdone==$pcnt; $#d = -1; } } if (@d && !$i) { my $str; if ($#dogp>0) { $str = ($#dogp+1).' columns don\'t'; } else { $str = '1 column doesn\'t'; } $str .= " fit in $step column format ". '(even repeated) -- discarding surplus'; carp $str; # printf $fh $format_string,@d; # printf $fh $usecolsep; } } else { my $pdone = 0; for (@dogp) { $pdone++; print $fh _at_1D($_,$i) . ( ($pdone==$pcnt) ? '' : $usecolsep ); } } print $fh "\n"; } close($fh) if $file_opened; return 1; } =head2 swcols =for ref generate string list from C format specifier and a list of ndarrays C takes an (optional) format specifier of the printf sort and a list of 1D ndarrays as input. It returns a perl array (or array reference if called in scalar context) where each element of the array is the string generated by printing the corresponding element of the ndarray(s) using the format specified. If no format is specified it uses the default print format. =for usage Usage: @str = swcols format, pdl1,pdl2,pdl3,...; or $str = swcols format, pdl1,pdl2,pdl3,...; =cut *swcols = \&PDL::swcols; sub PDL::swcols{ my ($format_string,$step); my @outlist; if (ref(\$_[0]) eq "SCALAR") { $step = $format_string = shift; # 1st arg not ndarray $step =~ s/(%%|[^%])//g; # use step to count number of format items $step = length ($step); } my @p = @_; my $n = (ref $p[0] eq 'ARRAY') ? $#{$p[0]}+1 : $p[0]->nelem; for (@p) { if ( ref $_ eq 'ARRAY' ) { barf "swcols: 1D args must have same number of elements\n" if scalar(@{$_}) != $n; } else { barf "swcols: 1D args must have same number of elements\n" if $_->nelem != $n or $_->getndims!=1; } } my $i; for ($i=0; $i<$n; $i++) { if ($format_string) { my @d; for (@p) { push @d,_at_1D($_,$i); if (@d == $step) { push @outlist,sprintf $format_string,@d; $#d = -1; } } if (@d && !$i) { my $str; if ($#p>0) { $str = ($#p+1).' columns don\'t'; } else { $str = '1 column doesn\'t'; } $str .= " fit in $step column format ". '(even repeated) -- discarding surplus'; carp $str; # printf $fh $format_string,@d; # printf $fh $usecolsep; } } else { for (@p) { push @outlist,sprintf _at_1D($_,$i),$usecolsep; } } } wantarray ? return @outlist: return \@outlist; } =head2 rgrep =for ref Read columns into ndarrays using full regexp pattern matching. Options: UNDEFINED: This option determines what will be done for undefined values. For instance when reading a comma-separated file of the type C<1,2,,4> where the C<,,> indicates a missing value. The default value is to assign C<$PDL::undefval> to undefined values, but if C is set this is used instead. This would normally be set to a number, but if it is set to C and PDL is compiled with Badvalue support (see L) then undefined values are set to the appropriate badvalue and the column is marked as bad. DEFTYPE: Sets the default type of the columns - see the documentation for L TYPES: A reference to a Perl array with types for each column - see the documentation for L BUFFERSIZE: The number of lines to extend the ndarray by. It might speed up the reading a little bit by setting this to the number of lines in the file, but in general L is a better choice Usage =for usage ($x,$y,...) = rgrep(sub, *HANDLE|"filename") e.g. =for example ($x,$y) = rgrep {/Foo (.*) Bar (.*) Mumble/} $file; i.e. the vectors C<$x> and C<$y> get the progressive values of C<$1>, C<$2> etc. =cut sub rgrep (&@) { barf 'Usage ($x,$y,...) = rgrep(sub, *HANDLE|"filename", [{OPTIONS}])' if $#_ > 2; my (@ret,@v,$nret); my ($m,$n)=(-1,0); # Count/PDL size my $pattern = shift; my $is_handle = _is_io_handle $_[0]; my $fh = $is_handle ? $_[0] : gensym; open $fh, $_[0] or die "File $_[0] not found\n" unless $is_handle; if (ref($pattern) ne "CODE") { die "Got a ".ref($pattern)." for rgrep?!"; } # set up default options my $opt = new PDL::Options( { DEFTYPE => $deftype, TYPES => [], UNDEFINED => $PDL::undefval, BUFFERSIZE => 10000 } ); # Check if the user specified options my $u_opt = $_[1] || {}; $opt->options( $u_opt); my $options = $opt->current(); # If UNDEFINED is set to .*bad.* then undefined are set to # bad - unless we have a Perl that is not compiled with Bad support my $undef_is_bad = ($$options{UNDEFINED} =~ /bad/i); barf "Unknown PDL type given for DEFTYPE.\n" unless ref($$options{DEFTYPE}) eq "PDL::Type"; while(<$fh>) { next unless @v = &$pattern; $m++; # Count got if ($m==0) { $nret = $#v; # Last index of values to return # Handle various columns as in rcols - added 18/04/05 my @types = _handle_types( $nret, $$options{DEFTYPE}, $$options{TYPES} ); for (0..$nret) { # Modified 18/04/05 to use specified precision. $ret[$_] = [ PDL->zeroes($types[$_], 1), [] ]; } } else { # perhaps should only carp once... carp "Non-rectangular rgrep" if $nret != $#v; } if ($n<$m) { for (0..$nret) { _ext_lastD( $ret[$_]->[0], $$options{BUFFERSIZE} ); # Extend PDL in buffered manner } $n += $$options{BUFFERSIZE}; } for(0..$nret) { # Set values - '1*' is to ensure numeric # We now (JB - 18/04/05) also check for defined values or not # Ideally this should include Badvalue support.. if ($v[$_] eq '') { # Missing value - let us treat this specially if ($undef_is_bad) { set $ret[$_]->[0], $m, $$options{DEFTYPE}->badvalue(); # And set bad flag on $ref[$_]! $ret[$_]->[0]->badflag(1); } else { set $ret[$_]->[0], $m, $$options{UNDEFINED}; } } else { set $ret[$_]->[0], $m, 1*$v[$_]; } } } close($fh) unless $is_handle; for (@ret) { $_ = $_->[0]->slice("0:$m")->copy; }; # Truncate wantarray ? return(@ret) : return $ret[0]; } =head2 isbigendian =for ref Determine endianness of machine - returns 0 or 1 accordingly =cut #line 1212 "Misc.pm" #line 1181 "misc.pd" sub PDL::isbigendian { return 0; }; *isbigendian = \&PDL::isbigendian; #line 1219 "Misc.pm" #line 1203 "misc.pd" =head2 rasc =for ref Simple function to slurp in ASCII numbers quite quickly, although error handling is marginal (to nonexistent). =for usage $pdl->rasc("filename"|FILEHANDLE [,$noElements]); Where: filename is the name of the ASCII file to read or open file handle $noElements is the optional number of elements in the file to read. (If not present, all of the file will be read to fill up $pdl). $pdl can be of type float or double (for more precision). =for example # (test.num is an ascii file with 20 numbers. One number per line.) $in = PDL->null; $num = 20; $in->rasc('test.num',20); $imm = zeroes(float,20,2); $imm->rasc('test.num'); =cut sub rasc {PDL->rasc(@_)} sub PDL::rasc { my ($pdl, $file, $num) = @_; $num = -1 unless defined $num; my $is_openhandle = defined fileno $file; my $fi; if ($is_openhandle) { $fi = $file; } else { barf 'usage: rasc $pdl, "filename"|FILEHANDLE, [$num_to_read]' if !defined $file || ref $file; open $fi, "<", $file or barf "Can't open $file"; } $pdl->_rasc(my $ierr=null,$num,$fi); close $fi unless $is_openhandle; return all $ierr > 0; } # ---------------------------------------------------------- =head2 rcube =for ref Read list of files directly into a large data cube (for efficiency) =for usage $cube = rcube \&reader_function, @files; =for example $cube = rcube \&rfits, glob("*.fits"); This IO function allows direct reading of files into a large data cube, Obviously one could use cat() but this is more memory efficient. The reading function (e.g. rfits, readfraw) (passed as a reference) and files are the arguments. The cube is created as the same X,Y dims and datatype as the first image specified. The Z dim is simply the number of images. =cut sub rcube { my $reader = shift; barf "Usage: blah" unless ref($reader) eq "CODE"; my $k=0; my ($im,$cube,$tmp,$nx,$ny); my $nz = scalar(@_); for my $file (@_) { print "Slice ($k) - reading file $file...\n" if $PDL::verbose; $im = &$reader($file); ($nx, $ny) = dims $im; if ($k == 0) { print "Creating $nx x $ny x $nz cube...\n" if $PDL::verbose; $cube = $im->zeroes($im->type,$nx,$ny,$nz); } else { barf "Dimensions do not match for file $file!\n" if $im->getdim(0) != $nx or $im->getdim(1) != $ny ; } $tmp = $cube->slice(":,:,($k)"); $tmp .= $im; $k++; } return $cube; } #line 1329 "Misc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *_rasc = \&PDL::_rasc; #line 1335 "Misc.pm" #line 28 "misc.pd" =head1 AUTHOR Copyright (C) Karl Glazebrook 1997, Craig DeForest 2001, 2003, and Chris Marshall 2010. 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 #line 1354 "Misc.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/IO/Storable.pm0000644000175000017500000002250014200406311016416 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::IO::Storable; our @EXPORT_OK = qw(); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::IO::Storable ; #line 2 "storable.pd" =head1 NAME PDL::IO::Storable - helper functions to make PDL usable with Storable =head1 SYNOPSIS use Storable; use PDL::IO::Storable; $hash = { 'foo' => 42, 'bar' => zeroes(23,45), }; store $hash, 'perlhash.dat'; =head1 DESCRIPTION C implements object persistence for Perl data structures that can contain arbitrary Perl objects. This module implements the relevant methods to be able to store and retrieve ndarrays via Storable. =head1 FUNCTIONS =cut use strict; use warnings; #line 57 "Storable.pm" #line 74 "storable.pd" { package # hide from PAUSE PDL; use Carp; # routines to make PDL work with Storable >= 1.03 # pdlpack() serializes an ndarray, while pdlunpack() unserializes it. Earlier # versions of PDL didn't control for endianness, type sizes and enumerated type # values; this made stored data unportable across different architectures and # PDL versions. This is no longer the case, but the reading code is still able # to read the old files. The old files have no meta-information in them so it's # impossible to read them correctly with 100% accuracy, but we try to make an # educated guess # # Old data format: # # int type # int ndims # int dims[ndims] # data # # Note that here all the sizes and endiannesses are the native. This is # un-portable. Furthermore, the "type" is an enum, and its values could change # between PDL versions. Here I assume that the old format input data is indeed # native, so the old data files have the same portability issues, but at least # things will remain working and broken in the same way they were before # # # New format: # # uint64 0xFFFF FFFF FFFF FFFF # meant to be different from the old-style data # char type[16] # ' '-padded, left-aligned type string such as 'PDL_LL' # uint32 sizeof(type) # little-endian # uint32 one # native-endian. Used to determine the endianness # uint64 ndims # little-endian # uint64 dims[ndims] # little-endian # data # # The header data is all little-endian here. The data is stored with native # endianness. On load it is checked, and a swap happens, if it is required sub pdlpack { my ($pdl) = @_; my $hdr = pack( 'c8A16VL', (-1) x 8, $pdl->type->symbol, PDL::Core::howbig( $pdl->get_datatype ), 1 ); # I'd like this to be simply # my $dimhdr = pack( 'Q<*', $pdl->getndims, $pdl->dims ) # but my pack() may not support Q, so I break it up manually # # if sizeof(int) == 4 here, then $_>>32 will not return 0 necessarily (this in # undefined). I thus manually make sure this is the case # my $noMSW = (PDL::Core::howbig($PDL::Types::PDL_IND) < 8) ? 1 : 0; my $dimhdr = pack( 'V*', map( { $_ & 0xFFFFFFFF, $noMSW ? 0 : ($_ >> 32) } ($pdl->getndims, $pdl->dims ) ) ); my $dref = $pdl->get_dataref; return $hdr . $dimhdr . $$dref; } sub pdlunpack { use Config (); my ($pdl,$pack) = @_; my ($type, $ndims); my @dims = (); my $do_swap = 0; # first I try to infer the type of this storable my $offset = 0; my @magicheader = unpack( "ll", substr( $pack, $offset ) ); $offset += 8; if( $magicheader[0] != -1 || $magicheader[1] != -1 ) { print "PDL::IO::Storable detected an old-style pdl\n" if $PDL::verbose; # old-style data. I leave the data sizes, endianness native, since I don't # know any better. This at least won't break anything. # # The "type" however needs attention. Most-recent old-format data had these # values for the type: # # enum { byte, # short, # unsigned short, # long, # long long, # float, # double } # # The $type I read from the file is assumed to be in this enum even though # PDL may have added other types in the middle of this enum. my @reftypes = ($PDL::Types::PDL_B, $PDL::Types::PDL_S, $PDL::Types::PDL_U, $PDL::Types::PDL_L, $PDL::Types::PDL_LL, $PDL::Types::PDL_F, $PDL::Types::PDL_D); my $stride = $Config::Config{intsize}; ($type,$ndims) = unpack 'i2', $pack; @dims = $ndims > 0 ? unpack 'i*', substr $pack, 2*$stride, $ndims*$stride : (); $offset = (2+$ndims)*$stride; if( $type < 0 || $type >= @reftypes ) { croak "Reading in old-style pdl with unknown type: $type. Giving up."; } $type = $reftypes[$type]; } else { print "PDL::IO::Storable detected a new-style pdl\n" if $PDL::verbose; # new-style data. I KNOW the data sizes, endianness and the type enum my ($typestring) = unpack( 'A16', substr( $pack, $offset ) ); $offset += 16; $type = eval( '$PDL::Types::' . $typestring ); if( $@ ) { croak "PDL::IO::Storable couldn't parse type string '$typestring'. Giving up"; } my ($sizeof) = unpack( 'V', substr( $pack, $offset ) ); $offset += 4; if( $sizeof != PDL::Core::howbig( $type ) ) { croak "PDL::IO::Storable sees mismatched data type sizes when reading data of type '$typestring'\n" . "Stored data has sizeof = $sizeof, while here it is " . PDL::Core::howbig( $type ) . ".\n" . "Giving up"; } # check the endianness, if the "1" I read is interpreted as "1" on my # machine then the endiannesses match, and I can just read the data my ($one) = unpack( 'L', substr( $pack, $offset ) ); $offset += 4; if( $one == 1 ) { print "PDL::IO::Storable detected matching endianness\n" if $PDL::verbose; } else { print "PDL::IO::Storable detected non-matching endianness. Correcting data on load\n" if $PDL::verbose; # mismatched endianness. Let's make sure it's a big/little issue, not # something weird. If mismatched, the '00000001' should be seen as # '01000000' if( $one != 0x01000000 ) { croak "PDL::IO::Storable sees confused endianness. A '1' was read as '$one'.\n" . "This is neither matching nor swapped endianness. I don't know what's going on,\n" . "so I'm giving up." } # all righty. Everything's fine, but I need to swap all the data $do_swap = 1; } # mostly this acts like unpack('Q<'...), but works even if my unpack() # doesn't support 'Q'. This also makes sure that my PDL_Indx is large enough # to read this ndarray sub unpack64bit { my ($count, $pack, $offset) = @_; return map { my ($lsw, $msw) = unpack('VV', substr($$pack, $$offset)); $$offset += 8; croak( "PDL::IO::Storable tried reading a file with dimensions that don't fit into 32 bits.\n" . "However here PDL_Indx can't store a number so large. Giving up." ) if( PDL::Core::howbig($PDL::Types::PDL_IND) < 8 && $msw != 0 ); (($msw << 32) | $lsw) } (1..$count); } ($ndims) = unpack64bit( 1, \$pack, \$offset ); @dims = unpack64bit( $ndims, \$pack, \$offset ) if $ndims > 0; } print "thawing PDL, Dims: [",join(',',@dims),"]\n" if $PDL::verbose; $pdl->make_null; # make this a real ndarray -- this is the tricky bit! $pdl->set_datatype($type); $pdl->setdims([@dims]); my $dref = $pdl->get_dataref; $$dref = substr $pack, $offset; if( $do_swap && PDL::Core::howbig( $type ) != 1 ) { swapEndian( $$dref, PDL::Core::howbig( $type ) ); } $pdl->upd_data; return $pdl; } sub STORABLE_freeze { my ($self, $cloning) = @_; # return if $cloning; # Regular default serialization return UNIVERSAL::isa($self, "HASH") ? ("",{%$self}) # hash ref -> Storable : (pdlpack $self); # pack the ndarray into a long string } sub STORABLE_thaw { my ($pdl,$cloning,$serial,$hashref) = @_; # print "in STORABLE_thaw\n"; # return if $cloning; my $class = ref $pdl; if (defined $hashref) { croak "serial data with hashref!" unless !defined $serial || $serial eq ""; @$pdl{keys %$hashref} = values %$hashref; } else { # all the magic is happening in pdlunpack $pdl->pdlunpack($serial); # unpack our serial into this sv } } # have these as PDL methods =head2 store =for ref store an ndarray using L =for example $x = random 12,10; $x->store('myfile'); =cut =head2 freeze =for ref freeze an ndarray using L =for example $x = random 12,10; $frozen = $x->freeze; =cut sub store { require Storable; Storable::store(@_) } sub freeze { require Storable; Storable::freeze(@_) } } =head1 AUTHOR Copyright (C) 2013 Dima Kogan Copyright (C) 2002 Christian Soeller 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 #line 341 "Storable.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/Primitive.pm0000644000175000017500000024111214200406306016312 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::Primitive; our @EXPORT_OK = qw(inner outer matmult matmult innerwt inner2 inner2d inner2t crossp norm indadd conv1d in uniq uniqind uniqvec hclip lclip clip clip wtstat statsover stats histogram whistogram histogram2d whistogram2d fibonacci append axisvalues srand random randsym grandom vsearch vsearch_sample vsearch_insert_leftmost vsearch_insert_rightmost vsearch_match vsearch_bin_inclusive vsearch_bin_exclusive interpolate interpol interpND one2nd which which_both where whereND whichND setops intersect ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Primitive ; #line 7 "primitive.pd" use strict; use warnings; use PDL::Slices; use Carp; { package PDL; use overload ( 'x' => sub { PDL::Primitive::matmult(@_[0,1], my $foo=$_[0]->null()); $foo; }, ); } =head1 NAME PDL::Primitive - primitive operations for pdl =head1 DESCRIPTION This module provides some primitive and useful functions defined using PDL::PP and able to use the new indexing tricks. See L for how to use indices creatively. For explanation of the signature format, see L. =head1 SYNOPSIS # Pulls in PDL::Primitive, among other modules. use PDL; # Only pull in PDL::Primitive: use PDL::Primitive; =cut #line 61 "Primitive.pm" =head1 FUNCTIONS =cut #line 1059 "../../blib/lib/PDL/PP.pm" =head2 inner =for sig Signature: (a(n); b(n); [o]c()) =for ref Inner product over one dimension c = sum_i a_i * b_i =for bad =for bad If C contains only bad data, C is set bad. Otherwise C will have its bad flag cleared, as it will not contain any bad values. =cut #line 105 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *inner = \&PDL::inner; #line 111 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 outer =for sig Signature: (a(n); b(m); [o]c(n,m)) =for ref outer product over one dimension Naturally, it is possible to achieve the effects of outer product simply by threading over the "C<*>" operator but this function is provided for convenience. =for bad outer processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 141 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *outer = \&PDL::outer; #line 147 "Primitive.pm" #line 121 "primitive.pd" =head2 x =for sig Signature: (a(i,z), b(x,i),[o]c(x,z)) =for ref Matrix multiplication PDL overloads the C operator (normally the repeat operator) for matrix multiplication. The number of columns (size of the 0 dimension) in the left-hand argument must normally equal the number of rows (size of the 1 dimension) in the right-hand argument. Row vectors are represented as (N x 1) two-dimensional PDLs, or you may be sloppy and use a one-dimensional PDL. Column vectors are represented as (1 x N) two-dimensional PDLs. Threading occurs in the usual way, but as both the 0 and 1 dimension (if present) are included in the operation, you must be sure that you don't try to thread over either of those dims. Of note, due to how Perl v5.14.0 and above implement operator overloading of the C operator, the use of parentheses for the left operand creates a list context, that is pdl> ( $x * $y ) x $z ERROR: Argument "..." isn't numeric in repeat (x) ... treats C<$z> as a numeric count for the list repeat operation and does not call the scalar form of the overloaded operator. To use the operator in this case, use a scalar context: pdl> scalar( $x * $y ) x $z or by calling L directly: pdl> ( $x * $y )->matmult( $z ) EXAMPLES Here are some simple ways to define vectors and matrices: pdl> $r = pdl(1,2); # A row vector pdl> $c = pdl([[3],[4]]); # A column vector pdl> $c = pdl(3,4)->(*1); # A column vector, using NiceSlice pdl> $m = pdl([[1,2],[3,4]]); # A 2x2 matrix Now that we have a few objects prepared, here is how to matrix-multiply them: pdl> print $r x $m # row x matrix = row [ [ 7 10] ] pdl> print $m x $r # matrix x row = ERROR PDL: Dim mismatch in matmult of [2x2] x [2x1]: 2 != 1 pdl> print $m x $c # matrix x column = column [ [ 5] [11] ] pdl> print $m x 2 # Trivial case: scalar mult. [ [2 4] [6 8] ] pdl> print $r x $c # row x column = scalar [ [11] ] pdl> print $c x $r # column x row = matrix [ [3 6] [4 8] ] INTERNALS The mechanics of the multiplication are carried out by the L method. =cut #line 242 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 matmult =for sig Signature: (a(t,h); b(w,t); [o]c(w,h)) =for ref Matrix multiplication Notionally, matrix multiplication $x x $y is equivalent to the threading expression $x->dummy(1)->inner($y->xchg(0,1)->dummy(2),$c); but for large matrices that breaks CPU cache and is slow. Instead, matmult calculates its result in 32x32x32 tiles, to keep the memory footprint within cache as long as possible on most modern CPUs. For usage, see L, a description of the overloaded 'x' operator =for bad matmult ignores the bad-value flag of the input ndarrays. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 279 "Primitive.pm" #line 1060 "../../blib/lib/PDL/PP.pm" sub PDL::matmult { my ($x,$y,$c) = @_; $y = pdl($y) unless eval { $y->isa('PDL') }; $c = PDL->null unless eval { $c->isa('PDL') }; while($x->getndims < 2) {$x = $x->dummy(-1)} while($y->getndims < 2) {$y = $y->dummy(-1)} return ($c .= $x * $y) if( ($x->dim(0)==1 && $x->dim(1)==1) || ($y->dim(0)==1 && $y->dim(1)==1) ); if($y->dim(1) != $x->dim(0)) { barf(sprintf("Dim mismatch in matmult of [%dx%d] x [%dx%d]: %d != %d",$x->dim(0),$x->dim(1),$y->dim(0),$y->dim(1),$x->dim(0),$y->dim(1))); } PDL::_matmult_int($x,$y,$c); $c; } #line 301 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *matmult = \&PDL::matmult; #line 307 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 innerwt =for sig Signature: (a(n); b(n); c(n); [o]d()) =for ref Weighted (i.e. triple) inner product d = sum_i a(i) b(i) c(i) =for bad innerwt processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 337 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *innerwt = \&PDL::innerwt; #line 343 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 inner2 =for sig Signature: (a(n); b(n,m); c(m); [o]d()) =for ref Inner product of two vectors and a matrix d = sum_ij a(i) b(i,j) c(j) Note that you should probably not thread over C and C since that would be very wasteful. Instead, you should use a temporary for C. =for bad inner2 processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 374 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *inner2 = \&PDL::inner2; #line 380 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 inner2d =for sig Signature: (a(n,m); b(n,m); [o]c()) =for ref Inner product over 2 dimensions. Equivalent to $c = inner($x->clump(2), $y->clump(2)) =for bad inner2d processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 412 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *inner2d = \&PDL::inner2d; #line 418 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 inner2t =for sig Signature: (a(j,n); b(n,m); c(m,k); [t]tmp(n,k); [o]d(j,k))) =for ref Efficient Triple matrix product C Efficiency comes from by using the temporary C. This operation only scales as C whereas threading using L would scale as C. The reason for having this routine is that you do not need to have the same thread-dimensions for C as for the other arguments, which in case of large numbers of matrices makes this much more memory-efficient. It is hoped that things like this could be taken care of as a kind of closures at some point. =for bad inner2t processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 458 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *inner2t = \&PDL::inner2t; #line 464 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 crossp =for sig Signature: (a(tri=3); b(tri); [o] c(tri)) =for ref Cross product of two 3D vectors After =for example $c = crossp $x, $y the inner product C<$c*$x> and C<$c*$y> will be zero, i.e. C<$c> is orthogonal to C<$x> and C<$y> =for bad crossp does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 500 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *crossp = \&PDL::crossp; #line 506 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 norm =for sig Signature: (vec(n); [o] norm(n)) =for ref Normalises a vector to unit Euclidean length =for bad norm processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 530 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *norm = \&PDL::norm; #line 536 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 indadd =for sig Signature: (a(n); indx ind(n); [o] sum(m)) =for ref Threaded Index Add: Add C to the C element of C, i.e: sum(ind) += a =for example Simple Example: $x = 2; $ind = 3; $sum = zeroes(10); indadd($x,$ind, $sum); print $sum #Result: ( 2 added to element 3 of $sum) # [0 0 0 2 0 0 0 0 0 0] Threaded Example: $x = pdl( 1,2,3); $ind = pdl( 1,4,6); $sum = zeroes(10); indadd($x,$ind, $sum); print $sum."\n"; #Result: ( 1, 2, and 3 added to elements 1,4,6 $sum) # [0 1 0 0 2 0 3 0 0 0] =for bad =for bad The routine barfs if any of the indices are bad. =cut #line 590 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *indadd = \&PDL::indadd; #line 596 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 conv1d =for sig Signature: (a(m); kern(p); [o]b(m); int reflect) =for ref 1D convolution along first dimension The m-th element of the discrete convolution of an input ndarray C<$a> of size C<$M>, and a kernel ndarray C<$kern> of size C<$P>, is calculated as n = ($P-1)/2 ==== \ ($a conv1d $kern)[m] = > $a_ext[m - n] * $kern[n] / ==== n = -($P-1)/2 where C<$a_ext> is either the periodic (or reflected) extension of C<$a> so it is equal to C<$a> on C< 0..$M-1 > and equal to the corresponding periodic/reflected image of C<$a> outside that range. =for example $con = conv1d sequence(10), pdl(-1,0,1); $con = conv1d sequence(10), pdl(-1,0,1), {Boundary => 'reflect'}; By default, periodic boundary conditions are assumed (i.e. wrap around). Alternatively, you can request reflective boundary conditions using the C option: {Boundary => 'reflect'} # case in 'reflect' doesn't matter The convolution is performed along the first dimension. To apply it across another dimension use the slicing routines, e.g. $y = $x->mv(2,0)->conv1d($kernel)->mv(0,2); # along third dim This function is useful for threaded filtering of 1D signals. Compare also L, L, L, L, L =for bad WARNING: C processes bad values in its inputs as the numeric value of C<< $pdl->badvalue >> so it is not recommended for processing pdls with bad values in them unless special care is taken. =for bad conv1d ignores the bad-value flag of the input ndarrays. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 670 "Primitive.pm" #line 1060 "../../blib/lib/PDL/PP.pm" sub PDL::conv1d { my $opt = pop @_ if ref($_[$#_]) eq 'HASH'; die 'Usage: conv1d( a(m), kern(p), [o]b(m), {Options} )' if $#_<1 || $#_>2; my($x,$kern) = @_; my $c = $#_ == 2 ? $_[2] : PDL->null; PDL::_conv1d_int($x,$kern,$c, !(defined $opt && exists $$opt{Boundary}) ? 0 : lc $$opt{Boundary} eq "reflect"); return $c; } #line 688 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *conv1d = \&PDL::conv1d; #line 694 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 in =for sig Signature: (a(); b(n); [o] c()) =for ref test if a is in the set of values b =for example $goodmsk = $labels->in($goodlabels); print pdl(3,1,4,6,2)->in(pdl(2,3,3)); [1 0 0 0 1] C is akin to the I of set theory. In principle, PDL threading could be used to achieve its functionality by using a construct like $msk = ($labels->dummy(0) == $goodlabels)->orover; However, C doesn't create a (potentially large) intermediate and is generally faster. =for bad in does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 736 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *in = \&PDL::in; #line 742 "Primitive.pm" #line 788 "primitive.pd" =head2 uniq =for ref return all unique elements of an ndarray The unique elements are returned in ascending order. =for example PDL> p pdl(2,2,2,4,0,-1,6,6)->uniq [-1 0 2 4 6] # 0 is returned 2nd (sorted order) PDL> p pdl(2,2,2,4,nan,-1,6,6)->uniq [-1 2 4 6 nan] # NaN value is returned at end Note: The returned pdl is 1D; any structure of the input ndarray is lost. C values are never compare equal to any other values, even themselves. As a result, they are always unique. C returns the NaN values at the end of the result ndarray. This follows the Matlab usage. See L if you need the indices of the unique elements rather than the values. =for bad Bad values are not considered unique by uniq and are ignored. $x=sequence(10); $x=$x->setbadif($x%3); print $x->uniq; [0 3 6 9] =cut *uniq = \&PDL::uniq; # return unique elements of array # find as jumps in the sorted array # flattens in the process sub PDL::uniq { use PDL::Core 'barf'; my ($arr) = @_; return $arr if($arr->nelem == 0); # The null list is unique (CED) my $srt = $arr->clump(-1)->where($arr==$arr)->qsort; # no NaNs or BADs for qsort my $nans = $arr->clump(-1)->where($arr!=$arr); my $uniq = ($srt->nelem > 0) ? $srt->where($srt != $srt->rotate(-1)) : $srt; # make sure we return something if there is only one value my $answ = $nans; # NaN values always uniq if ( $uniq->nelem > 0 ) { $answ = $uniq->append($answ); } else { $answ = ( ($srt->nelem == 0) ? $srt : PDL::pdl( ref($srt), [$srt->index(0)] ) )->append($answ); } return $answ; } #line 803 "Primitive.pm" #line 848 "primitive.pd" =head2 uniqind =for ref Return the indices of all unique elements of an ndarray The order is in the order of the values to be consistent with uniq. C values never compare equal with any other value and so are always unique. This follows the Matlab usage. =for example PDL> p pdl(2,2,2,4,0,-1,6,6)->uniqind [5 4 1 3 6] # the 0 at index 4 is returned 2nd, but... PDL> p pdl(2,2,2,4,nan,-1,6,6)->uniqind [5 1 3 6 4] # ...the NaN at index 4 is returned at end Note: The returned pdl is 1D; any structure of the input ndarray is lost. See L if you want the unique values instead of the indices. =for bad Bad values are not considered unique by uniqind and are ignored. =cut *uniqind = \&PDL::uniqind; # return unique elements of array # find as jumps in the sorted array # flattens in the process sub PDL::uniqind { use PDL::Core 'barf'; my ($arr) = @_; return $arr if($arr->nelem == 0); # The null list is unique (CED) # Different from uniq we sort and store the result in an intermediary my $aflat = $arr->flat; my $nanind = which($aflat!=$aflat); # NaN indexes my $good = PDL->sequence(indx, $aflat->dims)->where($aflat==$aflat); # good indexes my $i_srt = $aflat->where($aflat==$aflat)->qsorti; # no BAD or NaN values for qsorti my $srt = $aflat->where($aflat==$aflat)->index($i_srt); my $uniqind; if ($srt->nelem > 0) { $uniqind = which($srt != $srt->rotate(-1)); $uniqind = $i_srt->slice('0') if $uniqind->isempty; } else { $uniqind = which($srt); } # Now map back to the original space my $ansind = $nanind; if ( $uniqind->nelem > 0 ) { $ansind = ($good->index($i_srt->index($uniqind)))->append($ansind); } else { $ansind = $uniqind->append($ansind); } return $ansind; } #line 869 "Primitive.pm" #line 914 "primitive.pd" =head2 uniqvec =for ref Return all unique vectors out of a collection NOTE: If any vectors in the input ndarray have NaN values they are returned at the end of the non-NaN ones. This is because, by definition, NaN values never compare equal with any other value. NOTE: The current implementation does not sort the vectors containing NaN values. The unique vectors are returned in lexicographically sorted ascending order. The 0th dimension of the input PDL is treated as a dimensional index within each vector, and the 1st and any higher dimensions are taken to run across vectors. The return value is always 2D; any structure of the input PDL (beyond using the 0th dimension for vector index) is lost. See also L for a unique list of scalars; and L for sorting a list of vectors lexicographcally. =for bad If a vector contains all bad values, it is ignored as in L. If some of the values are good, it is treated as a normal vector. For example, [1 2 BAD] and [BAD 2 3] could be returned, but [BAD BAD BAD] could not. Vectors containing BAD values will be returned after any non-NaN and non-BAD containing vectors, followed by the NaN vectors. =cut sub PDL::uniqvec { my($pdl) = shift; return $pdl if ( $pdl->nelem == 0 || $pdl->ndims < 2 ); return $pdl if ( $pdl->slice("(0)")->nelem < 2 ); # slice isn't cheap but uniqvec isn't either my $pdl2d = $pdl->clump(1..$pdl->ndims-1); my $ngood = $pdl2d->ngoodover; $pdl2d = $pdl2d->mv(0,-1)->dice($ngood->which)->mv(-1,0); # remove all-BAD vectors my $numnan = ($pdl2d!=$pdl2d)->sumover; # works since no all-BADs to confuse my $presrt = $pdl2d->mv(0,-1)->dice($numnan->not->which)->mv(0,-1); # remove vectors with any NaN values my $nanvec = $pdl2d->mv(0,-1)->dice($numnan->which)->mv(0,-1); # the vectors with any NaN values # use dice instead of slice since qsortvec might be packing # the badvals to the front of the array instead of the end like # the docs say. If that is the case and it gets fixed, it won't # bust uniqvec. DAL 14-March 2006 my $srt = $presrt->qsortvec->mv(0,-1); # BADs are sorted by qsortvec my $srtdice = $srt; my $somebad = null; if ($srt->badflag) { $srtdice = $srt->dice($srt->mv(0,-1)->nbadover->not->which); $somebad = $srt->dice($srt->mv(0,-1)->nbadover->which); } my $uniq = $srtdice->nelem > 0 ? ($srtdice != $srtdice->rotate(-1))->mv(0,-1)->orover->which : $srtdice->orover->which; my $ans = $uniq->nelem > 0 ? $srtdice->dice($uniq) : ($srtdice->nelem > 0) ? $srtdice->slice("0,:") : $srtdice; return $ans->append($somebad)->append($nanvec->mv(0,-1))->mv(0,-1); } #line 946 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 hclip =for sig Signature: (a(); b(); [o] c()) =for ref clip (threshold) C<$a> by C<$b> (C<$b> is upper bound) =for bad hclip processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 970 "Primitive.pm" #line 1060 "../../blib/lib/PDL/PP.pm" sub PDL::hclip { my ($x,$y) = @_; my $c; if ($x->is_inplace) { $x->set_inplace(0); $c = $x; } elsif ($#_ > 1) {$c=$_[2]} else {$c=PDL->nullcreate($x)} PDL::_hclip_int($x,$y,$c); return $c; } #line 984 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *hclip = \&PDL::hclip; #line 990 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 lclip =for sig Signature: (a(); b(); [o] c()) =for ref clip (threshold) C<$a> by C<$b> (C<$b> is lower bound) =for bad lclip processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1014 "Primitive.pm" #line 1060 "../../blib/lib/PDL/PP.pm" sub PDL::lclip { my ($x,$y) = @_; my $c; if ($x->is_inplace) { $x->set_inplace(0); $c = $x; } elsif ($#_ > 1) {$c=$_[2]} else {$c=PDL->nullcreate($x)} PDL::_lclip_int($x,$y,$c); return $c; } #line 1028 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *lclip = \&PDL::lclip; #line 1034 "Primitive.pm" #line 1031 "primitive.pd" =head2 clip =for ref Clip (threshold) an ndarray by (optional) upper or lower bounds. =for usage $y = $x->clip(0,3); $c = $x->clip(undef, $x); =for bad clip handles bad values since it is just a wrapper around L and L. =cut #line 1057 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 clip =for sig Signature: (a(); l(); h(); [o] c()) =for ref info not available =for bad clip processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1083 "Primitive.pm" #line 1060 "../../blib/lib/PDL/PP.pm" *clip = \&PDL::clip; sub PDL::clip { my($x, $l, $h) = @_; my $d; unless(defined($l) || defined($h)) { # Deal with pathological case if($x->is_inplace) { $x->set_inplace(0); return $x; } else { return $x->copy; } } if($x->is_inplace) { $x->set_inplace(0); $d = $x } elsif ($#_ > 2) { $d=$_[3] } else { $d = PDL->nullcreate($x); } if(defined($l) && defined($h)) { PDL::_clip_int($x,$l,$h,$d); } elsif( defined($l) ) { PDL::_lclip_int($x,$l,$d); } elsif( defined($h) ) { PDL::_hclip_int($x,$h,$d); } else { die "This can't happen (clip contingency) - file a bug"; } return $d; } #line 1121 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *clip = \&PDL::clip; #line 1127 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 wtstat =for sig Signature: (a(n); wt(n); avg(); [o]b(); int deg) =for ref Weighted statistical moment of given degree This calculates a weighted statistic over the vector C. The formula is b() = (sum_i wt_i * (a_i ** degree - avg)) / (sum_i wt_i) =for bad =for bad Bad values are ignored in any calculation; C<$b> will only have its bad flag set if the output contains any bad data. =cut #line 1160 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *wtstat = \&PDL::wtstat; #line 1166 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 statsover =for sig Signature: (a(n); w(n); float+ [o]avg(); float+ [o]prms(); int+ [o]median(); int+ [o]min(); int+ [o]max(); float+ [o]adev(); float+ [o]rms()) =for ref Calculate useful statistics over a dimension of an ndarray =for usage ($mean,$prms,$median,$min,$max,$adev,$rms) = statsover($ndarray, $weights); This utility function calculates various useful quantities of an ndarray. These are: =over 3 =item * the mean: MEAN = sum (x)/ N with C being the number of elements in x =item * the population RMS deviation from the mean: PRMS = sqrt( sum( (x-mean(x))^2 )/(N-1) The population deviation is the best-estimate of the deviation of the population from which a sample is drawn. =item * the median The median is the 50th percentile data value. Median is found by L, so WEIGHTING IS IGNORED FOR THE MEDIAN CALCULATION. =item * the minimum =item * the maximum =item * the average absolute deviation: AADEV = sum( abs(x-mean(x)) )/N =item * RMS deviation from the mean: RMS = sqrt(sum( (x-mean(x))^2 )/N) (also known as the root-mean-square deviation, or the square root of the variance) =back This operator is a projection operator so the calculation will take place over the final dimension. Thus if the input is N-dimensional each returned value will be N-1 dimensional, to calculate the statistics for the entire ndarray either use C directly on the ndarray or call C. =for bad =for bad Bad values are simply ignored in the calculation, effectively reducing the sample size. If all data are bad then the output data are marked bad. =cut #line 1247 "Primitive.pm" #line 1060 "../../blib/lib/PDL/PP.pm" sub PDL::statsover { barf('Usage: ($mean,[$prms, $median, $min, $max, $adev, $rms]) = statsover($data,[$weights])') if $#_>1; my ($data, $weights) = @_; $weights = $data->ones() if !defined($weights); my $median = $data->medover(); my $mean = PDL->nullcreate($data); my $rms = PDL->nullcreate($data); my $min = PDL->nullcreate($data); my $max = PDL->nullcreate($data); my $adev = PDL->nullcreate($data); my $prms = PDL->nullcreate($data); PDL::_statsover_int($data, $weights, $mean, $prms, $median, $min, $max, $adev, $rms); return $mean unless wantarray; return ($mean, $prms, $median, $min, $max, $adev, $rms); } #line 1271 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *statsover = \&PDL::statsover; #line 1277 "Primitive.pm" #line 1339 "primitive.pd" =head2 stats =for ref Calculates useful statistics on an ndarray =for usage ($mean,$prms,$median,$min,$max,$adev,$rms) = stats($ndarray,[$weights]); This utility calculates all the most useful quantities in one call. It works the same way as L, except that the quantities are calculated considering the entire input PDL as a single sample, rather than as a collection of rows. See L for definitions of the returned quantities. =for bad Bad values are handled; if all input values are bad, then all of the output values are flagged bad. =cut *stats = \&PDL::stats; sub PDL::stats { barf('Usage: ($mean,[$rms]) = stats($data,[$weights])') if $#_>1; my ($data,$weights) = @_; # Ensure that $weights is properly threaded over; this could be # done rather more efficiently... if(defined $weights) { $weights = pdl($weights) unless UNIVERSAL::isa($weights,'PDL'); if( ($weights->ndims != $data->ndims) or (pdl($weights->dims) != pdl($data->dims))->or ) { $weights = $weights + zeroes($data) } $weights = $weights->flat; } return PDL::statsover($data->flat,$weights); } #line 1324 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 histogram =for sig Signature: (in(n); int+[o] hist(m); double step; double min; int msize => m) =for ref Calculates a histogram for given stepsize and minimum. =for usage $h = histogram($data, $step, $min, $numbins); $hist = zeroes $numbins; # Put histogram in existing ndarray. histogram($data, $hist, $step, $min, $numbins); The histogram will contain C<$numbins> bins starting from C<$min>, each C<$step> wide. The value in each bin is the number of values in C<$data> that lie within the bin limits. Data below the lower limit is put in the first bin, and data above the upper limit is put in the last bin. The output is reset in a different threadloop so that you can take a histogram of C<$a(10,12)> into C<$b(15)> and get the result you want. For a higher-level interface, see L. =for example pdl> p histogram(pdl(1,1,2),1,0,3) [0 2 1] =for bad histogram processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1375 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *histogram = \&PDL::histogram; #line 1381 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 whistogram =for sig Signature: (in(n); float+ wt(n);float+[o] hist(m); double step; double min; int msize => m) =for ref Calculates a histogram from weighted data for given stepsize and minimum. =for usage $h = whistogram($data, $weights, $step, $min, $numbins); $hist = zeroes $numbins; # Put histogram in existing ndarray. whistogram($data, $weights, $hist, $step, $min, $numbins); The histogram will contain C<$numbins> bins starting from C<$min>, each C<$step> wide. The value in each bin is the sum of the values in C<$weights> that correspond to values in C<$data> that lie within the bin limits. Data below the lower limit is put in the first bin, and data above the upper limit is put in the last bin. The output is reset in a different threadloop so that you can take a histogram of C<$a(10,12)> into C<$b(15)> and get the result you want. =for example pdl> p whistogram(pdl(1,1,2), pdl(0.1,0.1,0.5), 1, 0, 4) [0 0.2 0.5 0] =for bad whistogram processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1429 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *whistogram = \&PDL::whistogram; #line 1435 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 histogram2d =for sig Signature: (ina(n); inb(n); int+[o] hist(ma,mb); double stepa; double mina; int masize => ma; double stepb; double minb; int mbsize => mb;) =for ref Calculates a 2d histogram. =for usage $h = histogram2d($datax, $datay, $stepx, $minx, $nbinx, $stepy, $miny, $nbiny); $hist = zeroes $nbinx, $nbiny; # Put histogram in existing ndarray. histogram2d($datax, $datay, $hist, $stepx, $minx, $nbinx, $stepy, $miny, $nbiny); The histogram will contain C<$nbinx> x C<$nbiny> bins, with the lower limits of the first one at C<($minx, $miny)>, and with bin size C<($stepx, $stepy)>. The value in each bin is the number of values in C<$datax> and C<$datay> that lie within the bin limits. Data below the lower limit is put in the first bin, and data above the upper limit is put in the last bin. =for example pdl> p histogram2d(pdl(1,1,1,2,2),pdl(2,1,1,1,1),1,0,3,1,0,3) [ [0 0 0] [0 2 2] [0 1 0] ] =for bad histogram2d processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1488 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *histogram2d = \&PDL::histogram2d; #line 1494 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 whistogram2d =for sig Signature: (ina(n); inb(n); float+ wt(n);float+[o] hist(ma,mb); double stepa; double mina; int masize => ma; double stepb; double minb; int mbsize => mb;) =for ref Calculates a 2d histogram from weighted data. =for usage $h = whistogram2d($datax, $datay, $weights, $stepx, $minx, $nbinx, $stepy, $miny, $nbiny); $hist = zeroes $nbinx, $nbiny; # Put histogram in existing ndarray. whistogram2d($datax, $datay, $weights, $hist, $stepx, $minx, $nbinx, $stepy, $miny, $nbiny); The histogram will contain C<$nbinx> x C<$nbiny> bins, with the lower limits of the first one at C<($minx, $miny)>, and with bin size C<($stepx, $stepy)>. The value in each bin is the sum of the values in C<$weights> that correspond to values in C<$datax> and C<$datay> that lie within the bin limits. Data below the lower limit is put in the first bin, and data above the upper limit is put in the last bin. =for example pdl> p whistogram2d(pdl(1,1,1,2,2),pdl(2,1,1,1,1),pdl(0.1,0.2,0.3,0.4,0.5),1,0,3,1,0,3) [ [ 0 0 0] [ 0 0.5 0.9] [ 0 0.1 0] ] =for bad whistogram2d processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1547 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *whistogram2d = \&PDL::whistogram2d; #line 1553 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 fibonacci =for sig Signature: (i(n); indx [o]x(n)) =for ref Constructor - a vector with Fibonacci's sequence =for bad fibonacci does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1577 "Primitive.pm" #line 1060 "../../blib/lib/PDL/PP.pm" sub fibonacci { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->fibonacci : PDL->fibonacci(@_) } sub PDL::fibonacci{ my $x = &PDL::Core::_construct; my $is_inplace = $x->is_inplace; my ($in, $out) = $x->clump(-1); $out = $is_inplace ? $in->inplace : PDL->null; PDL::_fibonacci_int($in, $out); $out; } #line 1591 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" #line 1596 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 append =for sig Signature: (a(n); b(m); [o] c(mn)) =for ref append two ndarrays by concatenating along their first dimensions =for example $x = ones(2,4,7); $y = sequence 5; $c = $x->append($y); # size of $c is now (7,4,7) (a jumbo-ndarray ;) C appends two ndarrays along their first dimensions. The rest of the dimensions must be compatible in the threading sense. The resulting size of the first dimension is the sum of the sizes of the first dimensions of the two argument ndarrays - i.e. C. Similar functions include L (below), which can append more than two ndarrays along an arbitrary dimension, and L, which can append more than two ndarrays that all have the same sized dimensions. =for bad append does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1638 "Primitive.pm" #line 1060 "../../blib/lib/PDL/PP.pm" #line 1652 "primitive.pd" sub PDL::append { my ($i1, $i2, $o) = map PDL->topdl($_), @_; if (grep $_->isempty, $i1, $i2) { if (!defined $o) { return $i2->copy if $i1->isempty; return $i1->isnull ? PDL->zeroes(0) : $i1->copy; } else { $o .= $i2->isnull ? PDL->zeroes(0) : $i2, return $o if $i1->isempty; $o .= $i1->isnull ? PDL->zeroes(0) : $i1, return $o; } } $o //= PDL->null; PDL::_append_int($i1, $i2, $o); $o; } #line 1079 "../../blib/lib/PDL/PP.pm" #line 1663 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *append = \&PDL::append; #line 1669 "Primitive.pm" #line 1705 "primitive.pd" =head2 glue =for usage $c = $x->glue(,$y,...) =for ref Glue two or more PDLs together along an arbitrary dimension (N-D L). Sticks $x, $y, and all following arguments together along the specified dimension. All other dimensions must be compatible in the threading sense. Glue is permissive, in the sense that every PDL is treated as having an infinite number of trivial dimensions of order 1 -- so C<< $x->glue(3,$y) >> works, even if $x and $y are only one dimensional. If one of the PDLs has no elements, it is ignored. Likewise, if one of them is actually the undefined value, it is treated as if it had no elements. If the first parameter is a defined perl scalar rather than a pdl, then it is taken as a dimension along which to glue everything else, so you can say C<$cube = PDL::glue(3,@image_list);> if you like. C is implemented in pdl, using a combination of L and L. It should probably be updated (one day) to a pure PP function. Similar functions include L (above), which appends only two ndarrays along their first dimension, and L, which can append more than two ndarrays that all have the same sized dimensions. =cut sub PDL::glue{ my($x) = shift; my($dim) = shift; if(defined $x && !(ref $x)) { my $y = $dim; $dim = $x; $x = $y; } if(!defined $x || $x->nelem==0) { return $x unless(@_); return shift() if(@_<=1); $x=shift; return PDL::glue($x,$dim,@_); } if($dim - $x->dim(0) > 100) { print STDERR "warning:: PDL::glue allocating >100 dimensions!\n"; } while($dim >= $x->ndims) { $x = $x->dummy(-1,1); } $x = $x->xchg(0,$dim); while(scalar(@_)){ my $y = shift; next unless(defined $y && $y->nelem); while($dim >= $y->ndims) { $y = $y->dummy(-1,1); } $y = $y->xchg(0,$dim); $x = $x->append($y); } $x->xchg(0,$dim); } #line 1749 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *axisvalues = \&PDL::axisvalues; #line 1755 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 srand =for sig Signature: (a()) =for ref Seed random-number generator with a 64-bit int. Will generate seed data for a number of threads equal to the return-value of L. =for usage srand(); # uses current time srand(5); # fixed number e.g. for testing =for bad srand does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1788 "Primitive.pm" #line 1060 "../../blib/lib/PDL/PP.pm" *srand = \&PDL::srand; sub PDL::srand { PDL::_srand_int($_[0] // PDL::Core::seed()) } #line 1795 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *srand = \&PDL::srand; #line 1801 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 random =for sig Signature: (a()) =for ref Constructor which returns ndarray of random numbers =for usage $x = random([type], $nx, $ny, $nz,...); $x = random $y; etc (see L). This is the uniform distribution between 0 and 1 (assumedly excluding 1 itself). The arguments are the same as C (q.v.) - i.e. one can specify dimensions, types or give a template. You can use the PDL function L to seed the random generator. If it has not been called yet, it will be with the current time. =for bad random does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1841 "Primitive.pm" #line 1060 "../../blib/lib/PDL/PP.pm" sub random { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->random : PDL->random(@_) } sub PDL::random { my $class = shift; my $x = scalar(@_)? $class->new_from_specification(@_) : $class->new_or_inplace; PDL::_random_int($x); return $x; } #line 1853 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" #line 1858 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 randsym =for sig Signature: (a()) =for ref Constructor which returns ndarray of random numbers =for usage $x = randsym([type], $nx, $ny, $nz,...); $x = randsym $y; etc (see L). This is the uniform distribution between 0 and 1 (excluding both 0 and 1, cf L). The arguments are the same as C (q.v.) - i.e. one can specify dimensions, types or give a template. You can use the PDL function L to seed the random generator. If it has not been called yet, it will be with the current time. =for bad randsym does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1897 "Primitive.pm" #line 1060 "../../blib/lib/PDL/PP.pm" sub randsym { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->randsym : PDL->randsym(@_) } sub PDL::randsym { my $class = shift; my $x = scalar(@_)? $class->new_from_specification(@_) : $class->new_or_inplace; PDL::_randsym_int($x); return $x; } #line 1909 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" #line 1914 "Primitive.pm" #line 1929 "primitive.pd" =head2 grandom =for ref Constructor which returns ndarray of Gaussian random numbers =for usage $x = grandom([type], $nx, $ny, $nz,...); $x = grandom $y; etc (see L). This is generated using the math library routine C. Mean = 0, Stddev = 1 You can use the PDL function L to seed the random generator. If it has not been called yet, it will be with the current time. =cut sub grandom { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->grandom : PDL->grandom(@_) } sub PDL::grandom { my $class = shift; my $x = scalar(@_)? $class->new_from_specification(@_) : $class->new_or_inplace; use PDL::Math 'ndtri'; $x .= ndtri(randsym($x)); return $x; } #line 1949 "Primitive.pm" #line 1973 "primitive.pd" =head2 vsearch =for sig Signature: ( vals(); xs(n); [o] indx(); [\%options] ) =for ref Efficiently search for values in a sorted ndarray, returning indices. =for usage $idx = vsearch( $vals, $x, [\%options] ); vsearch( $vals, $x, $idx, [\%options ] ); B performs a binary search in the ordered ndarray C<$x>, for the values from C<$vals> ndarray, returning indices into C<$x>. What is a "match", and the meaning of the returned indices, are determined by the options. The C option indicates which method of searching to use, and may be one of: =over =item C invoke L|/vsearch_sample>, returning indices appropriate for sampling within a distribution. =item C invoke L|/vsearch_insert_leftmost>, returning the left-most possible insertion point which still leaves the ndarray sorted. =item C invoke L|/vsearch_insert_rightmost>, returning the right-most possible insertion point which still leaves the ndarray sorted. =item C invoke L|/vsearch_match>, returning the index of a matching element, else -(insertion point + 1) =item C invoke L|/vsearch_bin_inclusive>, returning an index appropriate for binning on a grid where the left bin edges are I of the bin. See below for further explanation of the bin. =item C invoke L|/vsearch_bin_exclusive>, returning an index appropriate for binning on a grid where the left bin edges are I of the bin. See below for further explanation of the bin. =back The default value of C is C. =for example use PDL; my @modes = qw( sample insert_leftmost insert_rightmost match bin_inclusive bin_exclusive ); # Generate a sequence of 3 zeros, 3 ones, ..., 3 fours. my $x = zeroes(3,5)->yvals->flat; for my $mode ( @modes ) { # if the value is in $x my $contained = 2; my $idx_contained = vsearch( $contained, $x, { mode => $mode } ); my $x_contained = $x->copy; $x_contained->slice( $idx_contained ) .= 9; # if the value is not in $x my $not_contained = 1.5; my $idx_not_contained = vsearch( $not_contained, $x, { mode => $mode } ); my $x_not_contained = $x->copy; $x_not_contained->slice( $idx_not_contained ) .= 9; print sprintf("%-23s%30s\n", '$x', $x); print sprintf("%-23s%30s\n", "$mode ($contained)", $x_contained); print sprintf("%-23s%30s\n\n", "$mode ($not_contained)", $x_not_contained); } # $x [0 0 0 1 1 1 2 2 2 3 3 3 4 4 4] # sample (2) [0 0 0 1 1 1 9 2 2 3 3 3 4 4 4] # sample (1.5) [0 0 0 1 1 1 9 2 2 3 3 3 4 4 4] # # $x [0 0 0 1 1 1 2 2 2 3 3 3 4 4 4] # insert_leftmost (2) [0 0 0 1 1 1 9 2 2 3 3 3 4 4 4] # insert_leftmost (1.5) [0 0 0 1 1 1 9 2 2 3 3 3 4 4 4] # # $x [0 0 0 1 1 1 2 2 2 3 3 3 4 4 4] # insert_rightmost (2) [0 0 0 1 1 1 2 2 2 9 3 3 4 4 4] # insert_rightmost (1.5) [0 0 0 1 1 1 9 2 2 3 3 3 4 4 4] # # $x [0 0 0 1 1 1 2 2 2 3 3 3 4 4 4] # match (2) [0 0 0 1 1 1 2 9 2 3 3 3 4 4 4] # match (1.5) [0 0 0 1 1 1 2 2 9 3 3 3 4 4 4] # # $x [0 0 0 1 1 1 2 2 2 3 3 3 4 4 4] # bin_inclusive (2) [0 0 0 1 1 1 2 2 9 3 3 3 4 4 4] # bin_inclusive (1.5) [0 0 0 1 1 9 2 2 2 3 3 3 4 4 4] # # $x [0 0 0 1 1 1 2 2 2 3 3 3 4 4 4] # bin_exclusive (2) [0 0 0 1 1 9 2 2 2 3 3 3 4 4 4] # bin_exclusive (1.5) [0 0 0 1 1 9 2 2 2 3 3 3 4 4 4] Also see L|/vsearch_sample>, L|/vsearch_insert_leftmost>, L|/vsearch_insert_rightmost>, L|/vsearch_match>, L|/vsearch_bin_inclusive>, and L|/vsearch_bin_exclusive> =cut sub vsearch { my $opt = 'HASH' eq ref $_[-1] ? pop : { mode => 'sample' }; croak( "unknown options to vsearch\n" ) if ( ! defined $opt->{mode} && keys %$opt ) || keys %$opt > 1; my $mode = $opt->{mode}; goto $mode eq 'sample' ? \&vsearch_sample : $mode eq 'insert_leftmost' ? \&vsearch_insert_leftmost : $mode eq 'insert_rightmost' ? \&vsearch_insert_rightmost : $mode eq 'match' ? \&vsearch_match : $mode eq 'bin_inclusive' ? \&vsearch_bin_inclusive : $mode eq 'bin_exclusive' ? \&vsearch_bin_exclusive : croak( "unknown vsearch mode: $mode\n" ); } *PDL::vsearch = \&vsearch; #line 2099 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 vsearch_sample =for sig Signature: (vals(); x(n); indx [o]idx()) =for ref Search for values in a sorted array, return index appropriate for sampling from a distribution =for usage $idx = vsearch_sample($vals, $x); C<$x> must be sorted, but may be in decreasing or increasing order. B returns an index I for each value I of C<$vals> appropriate for sampling C<$vals> I has the following properties: =over =item * if C<$x> is sorted in increasing order V <= x[0] : I = 0 x[0] < V <= x[-1] : I s.t. x[I-1] < V <= x[I] x[-1] < V : I = $x->nelem -1 =item * if C<$x> is sorted in decreasing order V > x[0] : I = 0 x[0] >= V > x[-1] : I s.t. x[I] >= V > x[I+1] x[-1] >= V : I = $x->nelem - 1 =back If all elements of C<$x> are equal, I<< I = $x->nelem - 1 >>. If C<$x> contains duplicated elements, I is the index of the leftmost (by position in array) duplicate if I matches. =for example This function is useful e.g. when you have a list of probabilities for events and want to generate indices to events: $x = pdl(.01,.86,.93,1); # Barnsley IFS probabilities cumulatively $y = random 20; $c = vsearch_sample($y, $x); # Now, $c will have the appropriate distr. It is possible to use the L function to obtain cumulative probabilities from absolute probabilities. =for bad needs major (?) work to handles bad values =cut #line 2192 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *vsearch_sample = \&PDL::vsearch_sample; #line 2198 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 vsearch_insert_leftmost =for sig Signature: (vals(); x(n); indx [o]idx()) =for ref Determine the insertion point for values in a sorted array, inserting before duplicates. =for usage $idx = vsearch_insert_leftmost($vals, $x); C<$x> must be sorted, but may be in decreasing or increasing order. B returns an index I for each value I of C<$vals> equal to the leftmost position (by index in array) within C<$x> that I may be inserted and still maintain the order in C<$x>. Insertion at index I involves shifting elements I and higher of C<$x> to the right by one and setting the now empty element at index I to I. I has the following properties: =over =item * if C<$x> is sorted in increasing order V <= x[0] : I = 0 x[0] < V <= x[-1] : I s.t. x[I-1] < V <= x[I] x[-1] < V : I = $x->nelem =item * if C<$x> is sorted in decreasing order V > x[0] : I = -1 x[0] >= V >= x[-1] : I s.t. x[I] >= V > x[I+1] x[-1] >= V : I = $x->nelem -1 =back If all elements of C<$x> are equal, i = 0 If C<$x> contains duplicated elements, I is the index of the leftmost (by index in array) duplicate if I matches. =for bad needs major (?) work to handles bad values =cut #line 2287 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *vsearch_insert_leftmost = \&PDL::vsearch_insert_leftmost; #line 2293 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 vsearch_insert_rightmost =for sig Signature: (vals(); x(n); indx [o]idx()) =for ref Determine the insertion point for values in a sorted array, inserting after duplicates. =for usage $idx = vsearch_insert_rightmost($vals, $x); C<$x> must be sorted, but may be in decreasing or increasing order. B returns an index I for each value I of C<$vals> equal to the rightmost position (by index in array) within C<$x> that I may be inserted and still maintain the order in C<$x>. Insertion at index I involves shifting elements I and higher of C<$x> to the right by one and setting the now empty element at index I to I. I has the following properties: =over =item * if C<$x> is sorted in increasing order V < x[0] : I = 0 x[0] <= V < x[-1] : I s.t. x[I-1] <= V < x[I] x[-1] <= V : I = $x->nelem =item * if C<$x> is sorted in decreasing order V >= x[0] : I = -1 x[0] > V >= x[-1] : I s.t. x[I] >= V > x[I+1] x[-1] > V : I = $x->nelem -1 =back If all elements of C<$x> are equal, i = $x->nelem - 1 If C<$x> contains duplicated elements, I is the index of the leftmost (by index in array) duplicate if I matches. =for bad needs major (?) work to handles bad values =cut #line 2382 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *vsearch_insert_rightmost = \&PDL::vsearch_insert_rightmost; #line 2388 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 vsearch_match =for sig Signature: (vals(); x(n); indx [o]idx()) =for ref Match values against a sorted array. =for usage $idx = vsearch_match($vals, $x); C<$x> must be sorted, but may be in decreasing or increasing order. B returns an index I for each value I of C<$vals>. If I matches an element in C<$x>, I is the index of that element, otherwise it is I<-( insertion_point + 1 )>, where I is an index in C<$x> where I may be inserted while maintaining the order in C<$x>. If C<$x> has duplicated values, I may refer to any of them. =for bad needs major (?) work to handles bad values =cut #line 2435 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *vsearch_match = \&PDL::vsearch_match; #line 2441 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 vsearch_bin_inclusive =for sig Signature: (vals(); x(n); indx [o]idx()) =for ref Determine the index for values in a sorted array of bins, lower bound inclusive. =for usage $idx = vsearch_bin_inclusive($vals, $x); C<$x> must be sorted, but may be in decreasing or increasing order. C<$x> represents the edges of contiguous bins, with the first and last elements representing the outer edges of the outer bins, and the inner elements the shared bin edges. The lower bound of a bin is inclusive to the bin, its outer bound is exclusive to it. B returns an index I for each value I of C<$vals> I has the following properties: =over =item * if C<$x> is sorted in increasing order V < x[0] : I = -1 x[0] <= V < x[-1] : I s.t. x[I] <= V < x[I+1] x[-1] <= V : I = $x->nelem - 1 =item * if C<$x> is sorted in decreasing order V >= x[0] : I = 0 x[0] > V >= x[-1] : I s.t. x[I+1] > V >= x[I] x[-1] > V : I = $x->nelem =back If all elements of C<$x> are equal, i = $x->nelem - 1 If C<$x> contains duplicated elements, I is the index of the righmost (by index in array) duplicate if I matches. =for bad needs major (?) work to handles bad values =cut #line 2528 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *vsearch_bin_inclusive = \&PDL::vsearch_bin_inclusive; #line 2534 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 vsearch_bin_exclusive =for sig Signature: (vals(); x(n); indx [o]idx()) =for ref Determine the index for values in a sorted array of bins, lower bound exclusive. =for usage $idx = vsearch_bin_exclusive($vals, $x); C<$x> must be sorted, but may be in decreasing or increasing order. C<$x> represents the edges of contiguous bins, with the first and last elements representing the outer edges of the outer bins, and the inner elements the shared bin edges. The lower bound of a bin is exclusive to the bin, its upper bound is inclusive to it. B returns an index I for each value I of C<$vals>. I has the following properties: =over =item * if C<$x> is sorted in increasing order V <= x[0] : I = -1 x[0] < V <= x[-1] : I s.t. x[I] < V <= x[I+1] x[-1] < V : I = $x->nelem - 1 =item * if C<$x> is sorted in decreasing order V > x[0] : I = 0 x[0] >= V > x[-1] : I s.t. x[I-1] >= V > x[I] x[-1] >= V : I = $x->nelem =back If all elements of C<$x> are equal, i = $x->nelem - 1 If C<$x> contains duplicated elements, I is the index of the righmost (by index in array) duplicate if I matches. =for bad needs major (?) work to handles bad values =cut #line 2621 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *vsearch_bin_exclusive = \&PDL::vsearch_bin_exclusive; #line 2627 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 interpolate =for sig Signature: (xi(); x(n); y(n); [o] yi(); int [o] err()) =for ref routine for 1D linear interpolation =for usage ( $yi, $err ) = interpolate($xi, $x, $y) Given a set of points C<($x,$y)>, use linear interpolation to find the values C<$yi> at a set of points C<$xi>. C uses a binary search to find the suspects, er..., interpolation indices and therefore abscissas (ie C<$x>) have to be I ordered (increasing or decreasing). For interpolation at lots of closely spaced abscissas an approach that uses the last index found as a start for the next search can be faster (compare Numerical Recipes C routine). Feel free to implement that on top of the binary search if you like. For out of bounds values it just does a linear extrapolation and sets the corresponding element of C<$err> to 1, which is otherwise 0. See also L, which uses the same routine, differing only in the handling of extrapolation - an error message is printed rather than returning an error ndarray. =for bad needs major (?) work to handles bad values =cut #line 2674 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *interpolate = \&PDL::interpolate; #line 2680 "Primitive.pm" #line 2649 "primitive.pd" =head2 interpol =for sig Signature: (xi(); x(n); y(n); [o] yi()) =for ref routine for 1D linear interpolation =for usage $yi = interpol($xi, $x, $y) C uses the same search method as L, hence C<$x> must be I ordered (either increasing or decreasing). The difference occurs in the handling of out-of-bounds values; here an error message is printed. =cut # kept in for backwards compatability sub interpol ($$$;$) { my $xi = shift; my $x = shift; my $y = shift; my $yi; if ( $#_ == 0 ) { $yi = $_[0]; } else { $yi = PDL->null; } interpolate( $xi, $x, $y, $yi, my $err = PDL->null ); print "some values had to be extrapolated\n" if any $err; return $yi if $#_ == -1; } # sub: interpol() *PDL::interpol = \&interpol; #line 2724 "Primitive.pm" #line 2693 "primitive.pd" =head2 interpND =for ref Interpolate values from an N-D ndarray, with switchable method =for example $source = 10*xvals(10,10) + yvals(10,10); $index = pdl([[2.2,3.5],[4.1,5.0]],[[6.0,7.4],[8,9]]); print $source->interpND( $index ); InterpND acts like L, collapsing C<$index> by lookup into C<$source>; but it does interpolation rather than direct sampling. The interpolation method and boundary condition are switchable via an options hash. By default, linear or sample interpolation is used, with constant value outside the boundaries of the source pdl. No dataflow occurs, because in general the output is computed rather than indexed. All the interpolation methods treat the pixels as value-centered, so the C method will return C<< $a->(0) >> for coordinate values on the set [-0.5,0.5), and all methods will return C<< $a->(1) >> for a coordinate value of exactly 1. Recognized options: =over 3 =item method Values can be: =over 3 =item * 0, s, sample, Sample (default for integer source types) The nearest value is taken. Pixels are regarded as centered on their respective integer coordinates (no offset from the linear case). =item * 1, l, linear, Linear (default for floating point source types) The values are N-linearly interpolated from an N-dimensional cube of size 2. =item * 3, c, cube, cubic, Cubic The values are interpolated using a local cubic fit to the data. The fit is constrained to match the original data and its derivative at the data points. The second derivative of the fit is not continuous at the data points. Multidimensional datasets are interpolated by the successive-collapse method. (Note that the constraint on the first derivative causes a small amount of ringing around sudden features such as step functions). =item * f, fft, fourier, Fourier The source is Fourier transformed, and the interpolated values are explicitly calculated from the coefficients. The boundary condition option is ignored -- periodic boundaries are imposed. If you pass in the option "fft", and it is a list (ARRAY) ref, then it is a stash for the magnitude and phase of the source FFT. If the list has two elements then they are taken as already computed; otherwise they are calculated and put in the stash. =back =item b, bound, boundary, Boundary This option is passed unmodified into L, which is used as the indexing engine for the interpolation. Some current allowed values are 'extend', 'periodic', 'truncate', and 'mirror' (default is 'truncate'). =item bad contains the fill value used for 'truncate' boundary. (default 0) =item fft An array ref whose associated list is used to stash the FFT of the source data, for the FFT method. =back =cut *interpND = *PDL::interpND; sub PDL::interpND { my $source = shift; my $index = shift; my $options = shift; barf 'Usage: interp_nd($source,$index,[{%options}])\n' if(defined $options and ref $options ne 'HASH'); my($opt) = (defined $options) ? $options : {}; my($method) = $opt->{m} || $opt->{meth} || $opt->{method} || $opt->{Method}; $method //= $source->type->integer ? 'sample' : 'linear'; my($boundary) = $opt->{b} || $opt->{boundary} || $opt->{Boundary} || $opt->{bound} || $opt->{Bound} || 'extend'; my($bad) = $opt->{bad} || $opt->{Bad} || 0.0; if($method =~ m/^s(am(p(le)?)?)?/i) { return $source->range(PDL::Math::floor($index+0.5),0,$boundary); } elsif (($method eq 1) || $method =~ m/^l(in(ear)?)?/i) { ## key: (ith = index thread; cth = cube thread; sth = source thread) my $d = $index->dim(0); my $di = $index->ndims - 1; # Grab a 2-on-a-side n-cube around each desired pixel my $samp = $source->range($index->floor,2,$boundary); # (ith, cth, sth) # Reorder to put the cube dimensions in front and convert to a list $samp = $samp->reorder( $di .. $di+$d-1, 0 .. $di-1, $di+$d .. $samp->ndims-1) # (cth, ith, sth) ->clump($d); # (clst, ith, sth) # Enumerate the corners of an n-cube and convert to a list # (the 'x' is the normal perl repeat operator) my $crnr = PDL::Basic::ndcoords( (2) x $index->dim(0) ) # (index,cth) ->mv(0,-1)->clump($index->dim(0))->mv(-1,0); # (index, clst) # a & b are the weighting coefficients. my($x,$y); my($indexwhere); ($indexwhere = $index->where( 0 * $index )) .= -10; # Change NaN to invalid { my $bb = PDL::Math::floor($index); $x = ($index - $bb) -> dummy(1,$crnr->dim(1)); # index, clst, ith $y = ($bb + 1 - $index) -> dummy(1,$crnr->dim(1)); # index, clst, ith } # Use 1/0 corners to select which multiplier happens, multiply # 'em all together to get sample weights, and sum to get the answer. my $out0 = ( ($x * ($crnr==1) + $y * ($crnr==0)) #index, clst, ith -> prodover #clst, ith ); my $out = ($out0 * $samp)->sumover; # ith, sth # Work around BAD-not-being-contagious bug in PDL <= 2.6 bad handling code --CED 3-April-2013 if ($source->badflag) { my $baddies = $samp->isbad->orover; $out = $out->setbadif($baddies); } return $out; } elsif(($method eq 3) || $method =~ m/^c(u(b(e|ic)?)?)?/i) { my ($d,@di) = $index->dims; my $di = $index->ndims - 1; # Grab a 4-on-a-side n-cube around each desired pixel my $samp = $source->range($index->floor - 1,4,$boundary) #ith, cth, sth ->reorder( $di .. $di+$d-1, 0..$di-1, $di+$d .. $source->ndims-1 ); # (cth, ith, sth) # Make a cube of the subpixel offsets, and expand its dims to # a 4-on-a-side N-1 cube, to match the slices of $samp (used below). my $y = $index - $index->floor; for my $i(1..$d-1) { $y = $y->dummy($i,4); } # Collapse by interpolation, one dimension at a time... for my $i(0..$d-1) { my $a0 = $samp->slice("(1)"); # Just-under-sample my $a1 = $samp->slice("(2)"); # Just-over-sample my $a1a0 = $a1 - $a0; my $gradient = 0.5 * ($samp->slice("2:3")-$samp->slice("0:1")); my $s0 = $gradient->slice("(0)"); # Just-under-gradient my $s1 = $gradient->slice("(1)"); # Just-over-gradient my $bb = $y->slice("($i)"); # Collapse the sample... $samp = ( $a0 + $bb * ( $s0 + $bb * ( (3 * $a1a0 - 2*$s0 - $s1) + $bb * ( $s1 + $s0 - 2*$a1a0 ) ) ) ); # "Collapse" the subpixel offset... $y = $y->slice(":,($i)"); } return $samp; } elsif($method =~ m/^f(ft|ourier)?/i) { eval "use PDL::FFT;"; my $fftref = $opt->{fft}; $fftref = [] unless(ref $fftref eq 'ARRAY'); if(@$fftref != 2) { my $x = $source->copy; my $y = zeroes($source); fftnd($x,$y); $fftref->[0] = sqrt($x*$x+$y*$y) / $x->nelem; $fftref->[1] = - atan2($y,$x); } my $i; my $c = PDL::Basic::ndcoords($source); # (dim, source-dims) for $i(1..$index->ndims-1) { $c = $c->dummy($i,$index->dim($i)) } my $id = $index->ndims-1; my $phase = (($c * $index * 3.14159 * 2 / pdl($source->dims)) ->sumover) # (index-dims, source-dims) ->reorder($id..$id+$source->ndims-1,0..$id-1); # (src, index) my $phref = $fftref->[1]->copy; # (source-dims) my $mag = $fftref->[0]->copy; # (source-dims) for $i(1..$index->ndims-1) { $phref = $phref->dummy(-1,$index->dim($i)); $mag = $mag->dummy(-1,$index->dim($i)); } my $out = cos($phase + $phref ) * $mag; $out = $out->clump($source->ndims)->sumover; return $out; } else { barf("interpND: unknown method '$method'; valid ones are 'linear' and 'sample'.\n"); } } #line 2969 "Primitive.pm" #line 2942 "primitive.pd" =head2 one2nd =for ref Converts a one dimensional index ndarray to a set of ND coordinates =for usage @coords=one2nd($x, $indices) returns an array of ndarrays containing the ND indexes corresponding to the one dimensional list indices. The indices are assumed to correspond to array C<$x> clumped using C. This routine is used in the old vector form of L, but is useful on its own occasionally. Returned ndarrays have the L datatype. C<$indices> can have values larger than C<< $x->nelem >> but negative values in C<$indices> will not give the answer you expect. =for example pdl> $x=pdl [[[1,2],[-1,1]], [[0,-3],[3,2]]]; $c=$x->clump(-1) pdl> $maxind=maximum_ind($c); p $maxind; 6 pdl> print one2nd($x, maximum_ind($c)) 0 1 1 pdl> p $x->at(0,1,1) 3 =cut *one2nd = \&PDL::one2nd; sub PDL::one2nd { barf "Usage: one2nd \$array \$indices\n" if $#_ != 1; my ($x, $ind)=@_; my @dimension=$x->dims; $ind = indx($ind); my(@index); my $count=0; foreach (@dimension) { $index[$count++]=$ind % $_; $ind /= $_; } return @index; } #line 3020 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 which =for sig Signature: (mask(n); indx [o] inds(m)) =for ref Returns indices of non-zero values from a 1-D PDL =for usage $i = which($mask); returns a pdl with indices for all those elements that are nonzero in the mask. Note that the returned indices will be 1D. If you feed in a multidimensional mask, it will be flattened before the indices are calculated. See also L for multidimensional masks. If you want to index into the original mask or a similar ndarray with output from C, remember to flatten it before calling index: $data = random 5, 5; $idx = which $data > 0.5; # $idx is now 1D $bigsum = $data->flat->index($idx)->sum; # flatten before indexing Compare also L for similar functionality. SEE ALSO: L returns separately the indices of both zero and nonzero values in the mask. L returns associated values from a data PDL, rather than indices into the mask PDL. L returns N-D indices into a multidimensional PDL. =for example pdl> $x = sequence(10); p $x [0 1 2 3 4 5 6 7 8 9] pdl> $indx = which($x>6); p $indx [7 8 9] =for bad which processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 3082 "Primitive.pm" #line 1060 "../../blib/lib/PDL/PP.pm" sub which { my ($this,$out) = @_; $this = $this->flat; $out = $this->nullcreate unless defined $out; PDL::_which_int($this,$out); return $out; } *PDL::which = \&which; #line 3094 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *which = \&PDL::which; #line 3100 "Primitive.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 which_both =for sig Signature: (mask(n); indx [o] inds(m); indx [o]notinds(q)) =for ref Returns indices of zero and nonzero values in a mask PDL =for usage ($i, $c_i) = which_both($mask); This works just as L, but the complement of C<$i> will be in C<$c_i>. =for example pdl> $x = sequence(10); p $x [0 1 2 3 4 5 6 7 8 9] pdl> ($small, $big) = which_both ($x >= 5); p "$small\n $big" [5 6 7 8 9] [0 1 2 3 4] =for bad which_both processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 3142 "Primitive.pm" #line 1060 "../../blib/lib/PDL/PP.pm" sub which_both { my ($this,$outi,$outni) = @_; $this = $this->flat; $outi = $this->nullcreate unless defined $outi; $outni = $this->nullcreate unless defined $outni; PDL::_which_both_int($this,$outi,$outni); return wantarray ? ($outi,$outni) : $outi; } *PDL::which_both = \&which_both; #line 3155 "Primitive.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *which_both = \&PDL::which_both; #line 3161 "Primitive.pm" #line 3146 "primitive.pd" =head2 where =for ref Use a mask to select values from one or more data PDLs C accepts one or more data ndarrays and a mask ndarray. It returns a list of output ndarrays, corresponding to the input data ndarrays. Each output ndarray is a 1-dimensional list of values in its corresponding data ndarray. The values are drawn from locations where the mask is nonzero. The output PDLs are still connected to the original data PDLs, for the purpose of dataflow. C combines the functionality of L and L into a single operation. BUGS: While C works OK for most N-dimensional cases, it does not thread properly over (for example) the (N+1)th dimension in data that is compared to an N-dimensional mask. Use C for that. =for usage $i = $x->where($x+5 > 0); # $i contains those elements of $x # where mask ($x+5 > 0) is 1 $i .= -5; # Set those elements (of $x) to -5. Together, these # commands clamp $x to a maximum of -5. It is also possible to use the same mask for several ndarrays with the same call: ($i,$j,$k) = where($x,$y,$z, $x+5>0); Note: C<$i> is always 1-D, even if C<$x> is E1-D. WARNING: The first argument (the values) and the second argument (the mask) currently have to have the exact same dimensions (or horrible things happen). You *cannot* thread over a smaller mask, for example. =cut sub PDL::where { barf "Usage: where( \$pdl1, ..., \$pdlN, \$mask )\n" if $#_ == 0; if($#_ == 1) { my($data,$mask) = @_; $data = $_[0]->clump(-1) if $_[0]->getndims>1; $mask = $_[1]->clump(-1) if $_[0]->getndims>1; return $data->index($mask->which()); } else { if($_[-1]->getndims > 1) { my $mask = $_[-1]->clump(-1)->which; return map {$_->clump(-1)->index($mask)} @_[0..$#_-1]; } else { my $mask = $_[-1]->which; return map {$_->index($mask)} @_[0..$#_-1]; } } } *where = \&PDL::where; #line 3230 "Primitive.pm" #line 3216 "primitive.pd" =head2 whereND =for ref C with support for ND masks and threading C accepts one or more data ndarrays and a mask ndarray. It returns a list of output ndarrays, corresponding to the input data ndarrays. The values are drawn from locations where the mask is nonzero. C differs from C in that the mask dimensionality is preserved which allows for proper threading of the selection operation over higher dimensions. As with C the output PDLs are still connected to the original data PDLs, for the purpose of dataflow. =for usage $sdata = whereND $data, $mask ($s1, $s2, ..., $sn) = whereND $d1, $d2, ..., $dn, $mask where $data is M dimensional $mask is N < M dimensional dims($data) 1..N == dims($mask) 1..N with threading over N+1 to M dimensions =for example $data = sequence(4,3,2); # example data array $mask4 = (random(4)>0.5); # example 1-D mask array, has $n4 true values $mask43 = (random(4,3)>0.5); # example 2-D mask array, has $n43 true values $sdat4 = whereND $data, $mask4; # $sdat4 is a [$n4,3,2] pdl $sdat43 = whereND $data, $mask43; # $sdat43 is a [$n43,2] pdl Just as with C, you can use the returned value in an assignment. That means that both of these examples are valid: # Used to create a new slice stored in $sdat4: $sdat4 = $data->whereND($mask4); $sdat4 .= 0; # Used in lvalue context: $data->whereND($mask4) .= 0; SEE ALSO: L returns N-D indices into a multidimensional PDL, from a mask. =cut sub PDL::whereND :lvalue { barf "Usage: whereND( \$pdl1, ..., \$pdlN, \$mask )\n" if $#_ == 0; my $mask = pop @_; # $mask has 0==false, 1==true my @to_return; my $n = PDL::sum($mask); foreach my $arr (@_) { my $sub_i = $mask * ones($arr); my $where_sub_i = PDL::where($arr, $sub_i); # count the number of dims in $mask and $arr # $mask = a b c d e f..... my @idims = dims($arr); # ...and pop off the number of dims in $mask foreach ( dims($mask) ) { shift(@idims) }; my $ndim = 0; foreach my $id ($n, @idims[0..($#idims-1)]) { $where_sub_i = $where_sub_i->splitdim($ndim++,$id) if $n>0; } push @to_return, $where_sub_i; } return (@to_return == 1) ? $to_return[0] : @to_return; } *whereND = \&PDL::whereND; #line 3320 "Primitive.pm" #line 3307 "primitive.pd" =head2 whichND =for ref Return the coordinates of non-zero values in a mask. =for usage WhichND returns the N-dimensional coordinates of each nonzero value in a mask PDL with any number of dimensions. The returned values arrive as an array-of-vectors suitable for use in L or L. $coords = whichND($mask); returns a PDL containing the coordinates of the elements that are non-zero in C<$mask>, suitable for use in L. The 0th dimension contains the full coordinate listing of each point; the 1st dimension lists all the points. For example, if $mask has rank 4 and 100 matching elements, then $coords has dimension 4x100. If no such elements exist, then whichND returns a structured empty PDL: an Nx0 PDL that contains no values (but matches, threading-wise, with the vectors that would be produced if such elements existed). DEPRECATED BEHAVIOR IN LIST CONTEXT: whichND once delivered different values in list context than in scalar context, for historical reasons. In list context, it returned the coordinates transposed, as a collection of 1-PDLs (one per dimension) in a list. This usage is deprecated in PDL 2.4.10, and will cause a warning to be issued every time it is encountered. To avoid the warning, you can set the global variable "$PDL::whichND" to 's' to get scalar behavior in all contexts, or to 'l' to get list behavior in list context. In later versions of PDL, the deprecated behavior will disappear. Deprecated list context whichND expressions can be replaced with: @list = $x->whichND->mv(0,-1)->dog; SEE ALSO: L finds coordinates of nonzero values in a 1-D mask. L extracts values from a data PDL that are associated with nonzero values in a mask PDL. L can be fed the coordinates to return the values. =for example pdl> $s=sequence(10,10,3,4) pdl> ($x, $y, $z, $w)=whichND($s == 203); p $x, $y, $z, $w [3] [0] [2] [0] pdl> print $s->at(list(cat($x,$y,$z,$w))) 203 =cut *whichND = \&PDL::whichND; sub PDL::whichND { my $mask = PDL->topdl(shift); # List context: generate a perl list by dimension if(wantarray) { if(!defined($PDL::whichND)) { printf STDERR "whichND: WARNING - list context deprecated. Set \$PDL::whichND. Details in pod."; } elsif($PDL::whichND =~ m/l/i) { # old list context enabled by setting $PDL::whichND to 'l' my $ind=($mask->clump(-1))->which; return $mask->one2nd($ind); } # if $PDL::whichND does not contain 'l' or 'L', fall through to scalar context } # Scalar context: generate an N-D index ndarray return PDL->new_from_specification(indx,$mask->ndims,0) if !$mask->nelem; return $mask ? pdl(indx,0) : PDL->new_from_specification(indx,0) if !$mask->getndims; my $ind = $mask->flat->which->dummy(0,$mask->getndims)->make_physical; # In the empty case, explicitly return the correct type of structured empty return PDL->new_from_specification(indx,$mask->ndims, 0) if !$ind->nelem; my $mult = ones(indx, $mask->getndims); my @mdims = $mask->dims; for my $i (0..$#mdims-1) { # use $tmp for 5.005_03 compatibility (my $tmp = $mult->index($i+1)) .= $mult->index($i)*$mdims[$i]; } for my $i (0..$#mdims) { my($s) = $ind->index($i); $s /= $mult->index($i); $s %= $mdims[$i]; } return $ind; } #line 3427 "Primitive.pm" #line 3420 "primitive.pd" =head2 setops =for ref Implements simple set operations like union and intersection =for usage Usage: $set = setops($x, , $y); The operator can be C, C or C. This is then applied to C<$x> viewed as a set and C<$y> viewed as a set. Set theory says that a set may not have two or more identical elements, but setops takes care of this for you, so C<$x=pdl(1,1,2)> is OK. The functioning is as follows: =over =item C The resulting vector will contain the elements that are either in C<$x> I in C<$y> or both. This is the union in set operation terms =item C The resulting vector will contain the elements that are either in C<$x> or C<$y>, but not in both. This is Union($x, $y) - Intersection($x, $y) in set operation terms. =item C The resulting vector will contain the intersection of C<$x> and C<$y>, so the elements that are in both C<$x> and C<$y>. Note that for convenience this operation is also aliased to L. =back It should be emphasized that these routines are used when one or both of the sets C<$x>, C<$y> are hard to calculate or that you get from a separate subroutine. Finally IDL users might be familiar with Craig Markwardt's C routine which has inspired this routine although it was written independently However the present routine has a few less options (but see the examples) =for example You will very often use these functions on an index vector, so that is what we will show here. We will in fact something slightly silly. First we will find all squares that are also cubes below 10000. Create a sequence vector: pdl> $x = sequence(10000) Find all odd and even elements: pdl> ($even, $odd) = which_both( ($x % 2) == 0) Find all squares pdl> $squares= which(ceil(sqrt($x)) == floor(sqrt($x))) Find all cubes (being careful with roundoff error!) pdl> $cubes= which(ceil($x**(1.0/3.0)) == floor($x**(1.0/3.0)+1e-6)) Then find all squares that are cubes: pdl> $both = setops($squares, 'AND', $cubes) And print these (assumes that C is loaded!) pdl> p $x($both) [0 1 64 729 4096] Then find all numbers that are either cubes or squares, but not both: pdl> $cube_xor_square = setops($squares, 'XOR', $cubes) pdl> p $cube_xor_square->nelem() 112 So there are a total of 112 of these! Finally find all odd squares: pdl> $odd_squares = setops($squares, 'AND', $odd) Another common occurrence is to want to get all objects that are in C<$x> and in the complement of C<$y>. But it is almost always best to create the complement explicitly since the universe that both are taken from is not known. Thus use L if possible to keep track of complements. If this is impossible the best approach is to make a temporary: This creates an index vector the size of the universe of the sets and set all elements in C<$y> to 0 pdl> $tmp = ones($n_universe); $tmp($y) .= 0; This then finds the complement of C<$y> pdl> $C_b = which($tmp == 1); and this does the final selection: pdl> $set = setops($x, 'AND', $C_b) =cut *setops = \&PDL::setops; sub PDL::setops { my ($x, $op, $y)=@_; # Check that $x and $y are 1D. if ($x->ndims() > 1 || $y->ndims() > 1) { warn 'setops: $x and $y must be 1D - flattening them!'."\n"; $x = $x->flat; $y = $y->flat; } #Make sure there are no duplicate elements. $x=$x->uniq; $y=$y->uniq; my $result; if ($op eq 'OR') { # Easy... $result = uniq(append($x, $y)); } elsif ($op eq 'XOR') { # Make ordered list of set union. my $union = append($x, $y)->qsort; # Index lists. my $s1=zeroes(byte, $union->nelem()); my $s2=zeroes(byte, $union->nelem()); # Find indices which are duplicated - these are to be excluded # # We do this by comparing x with x shifted each way. my $i1 = which($union != rotate($union, 1)); my $i2 = which($union != rotate($union, -1)); # # We then mark/mask these in the s1 and s2 arrays to indicate which ones # are not equal to their neighbours. # my $ts; ($ts = $s1->index($i1)) .= 1 if $i1->nelem() > 0; ($ts = $s2->index($i2)) .= 1 if $i2->nelem() > 0; my $inds=which($s1 == $s2); if ($inds->nelem() > 0) { return $union->index($inds); } else { return $inds; } } elsif ($op eq 'AND') { # The intersection of the arrays. # Make ordered list of set union. my $union = append($x, $y)->qsort; return $union->where($union == rotate($union, -1)); } else { print "The operation $op is not known!"; return -1; } } #line 3611 "Primitive.pm" #line 3604 "primitive.pd" =head2 intersect =for ref Calculate the intersection of two ndarrays =for usage Usage: $set = intersect($x, $y); This routine is merely a simple interface to L. See that for more information =for example Find all numbers less that 100 that are of the form 2*y and 3*x pdl> $x=sequence(100) pdl> $factor2 = which( ($x % 2) == 0) pdl> $factor3 = which( ($x % 3) == 0) pdl> $ii=intersect($factor2, $factor3) pdl> p $x($ii) [0 6 12 18 24 30 36 42 48 54 60 66 72 78 84 90 96] =cut *intersect = \&PDL::intersect; sub PDL::intersect { return setops($_[0], 'AND', $_[1]); } #line 3649 "Primitive.pm" #line 3643 "primitive.pd" =head1 AUTHOR Copyright (C) Tuomas J. Lukka 1997 (lukka@husc.harvard.edu). Contributions by Christian Soeller (c.soeller@auckland.ac.nz), Karl Glazebrook (kgb@aaoepp.aao.gov.au), Craig DeForest (deforest@boulder.swri.edu) and Jarle Brinchmann (jarle@astro.up.pt) 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. Updated for CPAN viewing compatibility by David Mertens. =cut #line 3672 "Primitive.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/Ufunc.pm0000644000175000017500000011361014200406307015424 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::Ufunc; our @EXPORT_OK = qw(prodover cprodover dprodover cumuprodover dcumuprodover sumover csumover dsumover cumusumover dcumusumover andover bandover borover orover zcover intover average avgover caverage cavgover daverage davgover minimum minover minimum_ind minover_ind minimum_n_ind minover_n_ind maximum maxover maximum_ind maxover_ind maximum_n_ind maxover_n_ind minmaximum minmaxover avg sum prod davg dsum dprod zcheck and band or bor min max median mode oddmedian any all minmax medover oddmedover modeover pctover oddpctover pct oddpct qsort qsorti qsortvec qsortveci ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Ufunc ; #line 10 "ufunc.pd" use strict; use warnings; =head1 NAME PDL::Ufunc - primitive ufunc operations for pdl =head1 DESCRIPTION This module provides some primitive and useful functions defined using PDL::PP based on functionality of what are sometimes called I (for example NumPY and Mathematica talk about these). It collects all the functions generally used to C or C along a dimension. These all do their job across the first dimension but by using the slicing functions you can do it on any dimension. The L module provides an alternative interface to many of the functions in this module. =head1 SYNOPSIS use PDL::Ufunc; =cut use PDL::Slices; use Carp; #line 54 "Ufunc.pm" =head1 FUNCTIONS =cut #line 1059 "../../blib/lib/PDL/PP.pm" =head2 prodover =for sig Signature: (a(n); int+ [o]b()) =for ref Project via product to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the product along the 1st dimension. By using L etc. it is possible to use I dimension. =for usage $y = prodover($x); =for example $spectrum = prodover $image->transpose =for bad prodover processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 107 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *prodover = \&PDL::prodover; #line 113 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 cprodover =for sig Signature: (a(n); cdouble [o]b()) =for ref Project via product to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the product along the 1st dimension. By using L etc. it is possible to use I dimension. =for usage $y = cprodover($x); =for example $spectrum = cprodover $image->transpose Unlike L, the calculations are performed in complex double precision. =for bad cprodover processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 157 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *cprodover = \&PDL::cprodover; #line 163 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 dprodover =for sig Signature: (a(n); double [o]b()) =for ref Project via product to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the product along the 1st dimension. By using L etc. it is possible to use I dimension. =for usage $y = dprodover($x); =for example $spectrum = dprodover $image->transpose Unlike L, the calculations are performed in double precision. =for bad dprodover processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 206 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *dprodover = \&PDL::dprodover; #line 212 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 cumuprodover =for sig Signature: (a(n); int+ [o]b(n)) =for ref Cumulative product This function calculates the cumulative product along the 1st dimension. By using L etc. it is possible to use I dimension. The sum is started so that the first element in the cumulative product is the first element of the parameter. =for usage $y = cumuprodover($x); =for example $spectrum = cumuprodover $image->transpose =for bad cumuprodover processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 258 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *cumuprodover = \&PDL::cumuprodover; #line 264 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 dcumuprodover =for sig Signature: (a(n); double [o]b(n)) =for ref Cumulative product This function calculates the cumulative product along the 1st dimension. By using L etc. it is possible to use I dimension. The sum is started so that the first element in the cumulative product is the first element of the parameter. =for usage $y = dcumuprodover($x); =for example $spectrum = dcumuprodover $image->transpose Unlike L, the calculations are performed in double precision. =for bad dcumuprodover processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 310 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *dcumuprodover = \&PDL::dcumuprodover; #line 316 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 sumover =for sig Signature: (a(n); int+ [o]b()) =for ref Project via sum to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the sum along the 1st dimension. By using L etc. it is possible to use I dimension. =for usage $y = sumover($x); =for example $spectrum = sumover $image->transpose =for bad sumover processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 359 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *sumover = \&PDL::sumover; #line 365 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 csumover =for sig Signature: (a(n); cdouble [o]b()) =for ref Project via sum to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the sum along the 1st dimension. By using L etc. it is possible to use I dimension. =for usage $y = csumover($x); =for example $spectrum = csumover $image->transpose Unlike L, the calculations are performed in complex double precision. =for bad csumover processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 409 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *csumover = \&PDL::csumover; #line 415 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 dsumover =for sig Signature: (a(n); double [o]b()) =for ref Project via sum to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the sum along the 1st dimension. By using L etc. it is possible to use I dimension. =for usage $y = dsumover($x); =for example $spectrum = dsumover $image->transpose Unlike L, the calculations are performed in double precision. =for bad dsumover processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 458 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *dsumover = \&PDL::dsumover; #line 464 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 cumusumover =for sig Signature: (a(n); int+ [o]b(n)) =for ref Cumulative sum This function calculates the cumulative sum along the 1st dimension. By using L etc. it is possible to use I dimension. The sum is started so that the first element in the cumulative sum is the first element of the parameter. =for usage $y = cumusumover($x); =for example $spectrum = cumusumover $image->transpose =for bad cumusumover processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 510 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *cumusumover = \&PDL::cumusumover; #line 516 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 dcumusumover =for sig Signature: (a(n); double [o]b(n)) =for ref Cumulative sum This function calculates the cumulative sum along the 1st dimension. By using L etc. it is possible to use I dimension. The sum is started so that the first element in the cumulative sum is the first element of the parameter. =for usage $y = dcumusumover($x); =for example $spectrum = dcumusumover $image->transpose Unlike L, the calculations are performed in double precision. =for bad dcumusumover processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 562 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *dcumusumover = \&PDL::dcumusumover; #line 568 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 andover =for sig Signature: (a(n); int+ [o]b()) =for ref Project via and to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the and along the 1st dimension. By using L etc. it is possible to use I dimension. =for usage $y = andover($x); =for example $spectrum = andover $image->transpose =for bad If C contains only bad data (and its bad flag is set), C is set bad. Otherwise C will have its bad flag cleared, as it will not contain any bad values. =cut #line 611 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *andover = \&PDL::andover; #line 617 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 bandover =for sig Signature: (a(n); [o]b()) =for ref Project via bitwise and to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the bitwise and along the 1st dimension. By using L etc. it is possible to use I dimension. =for usage $y = bandover($x); =for example $spectrum = bandover $image->transpose =for bad If C contains only bad data (and its bad flag is set), C is set bad. Otherwise C will have its bad flag cleared, as it will not contain any bad values. =cut #line 660 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *bandover = \&PDL::bandover; #line 666 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 borover =for sig Signature: (a(n); [o]b()) =for ref Project via bitwise or to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the bitwise or along the 1st dimension. By using L etc. it is possible to use I dimension. =for usage $y = borover($x); =for example $spectrum = borover $image->transpose =for bad If C contains only bad data (and its bad flag is set), C is set bad. Otherwise C will have its bad flag cleared, as it will not contain any bad values. =cut #line 709 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *borover = \&PDL::borover; #line 715 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 orover =for sig Signature: (a(n); int+ [o]b()) =for ref Project via or to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the or along the 1st dimension. By using L etc. it is possible to use I dimension. =for usage $y = orover($x); =for example $spectrum = orover $image->transpose =for bad If C contains only bad data (and its bad flag is set), C is set bad. Otherwise C will have its bad flag cleared, as it will not contain any bad values. =cut #line 758 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *orover = \&PDL::orover; #line 764 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 zcover =for sig Signature: (a(n); int+ [o]b()) =for ref Project via == 0 to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the == 0 along the 1st dimension. By using L etc. it is possible to use I dimension. =for usage $y = zcover($x); =for example $spectrum = zcover $image->transpose =for bad If C contains only bad data (and its bad flag is set), C is set bad. Otherwise C will have its bad flag cleared, as it will not contain any bad values. =cut #line 807 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *zcover = \&PDL::zcover; #line 813 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 intover =for sig Signature: (a(n); float+ [o]b()) =for ref Project via integral to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the integral along the 1st dimension. By using L etc. it is possible to use I dimension. =for usage $y = intover($x); =for example $spectrum = intover $image->transpose Notes: C uses a point spacing of one (i.e., delta-h==1). You will need to scale the result to correct for the true point delta). For C 3>, these are all C (like Simpson's rule), but are integrals between the end points assuming the pdl gives values just at these centres: for such `functions', sumover is correct to C, but is the natural (and correct) choice for binned data, of course. =for bad intover ignores the bad-value flag of the input ndarrays. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 865 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *intover = \&PDL::intover; #line 871 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 average =for sig Signature: (a(n); int+ [o]b()) =for ref Project via average to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the average along the 1st dimension. By using L etc. it is possible to use I dimension. =for usage $y = average($x); =for example $spectrum = average $image->transpose =for bad average processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 914 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *average = \&PDL::average; #line 920 "Ufunc.pm" #line 317 "ufunc.pd" =head2 avgover =for ref Synonym for average. =cut *PDL::avgover = *avgover = \&PDL::average; #line 934 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 caverage =for sig Signature: (a(n); cdouble [o]b()) =for ref Project via average to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the average along the 1st dimension. By using L etc. it is possible to use I dimension. =for usage $y = caverage($x); =for example $spectrum = caverage $image->transpose Unlike L, the calculation is performed in complex double precision. =for bad caverage processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 978 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *caverage = \&PDL::caverage; #line 984 "Ufunc.pm" #line 317 "ufunc.pd" =head2 cavgover =for ref Synonym for caverage. =cut *PDL::cavgover = *cavgover = \&PDL::caverage; #line 998 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 daverage =for sig Signature: (a(n); double [o]b()) =for ref Project via average to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the average along the 1st dimension. By using L etc. it is possible to use I dimension. =for usage $y = daverage($x); =for example $spectrum = daverage $image->transpose Unlike L, the calculation is performed in double precision. =for bad daverage processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1042 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *daverage = \&PDL::daverage; #line 1048 "Ufunc.pm" #line 317 "ufunc.pd" =head2 davgover =for ref Synonym for daverage. =cut *PDL::davgover = *davgover = \&PDL::daverage; #line 1062 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 minimum =for sig Signature: (a(n); [o]c()) =for ref Project via minimum to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the minimum along the 1st dimension. By using L etc. it is possible to use I dimension. =for usage $y = minimum($x); =for example $spectrum = minimum $image->transpose =for bad Output is set bad if all elements of the input are bad, otherwise the bad flag is cleared for the output ndarray. Note that C are considered to be valid values; see L and L for ways of masking NaNs. =cut #line 1109 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *minimum = \&PDL::minimum; #line 1115 "Ufunc.pm" #line 317 "ufunc.pd" =head2 minover =for ref Synonym for minimum. =cut *PDL::minover = *minover = \&PDL::minimum; #line 1129 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 minimum_ind =for sig Signature: (a(n); indx [o] c()) =for ref Like minimum but returns the index rather than the value =for bad Output is set bad if all elements of the input are bad, otherwise the bad flag is cleared for the output ndarray. =cut #line 1152 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *minimum_ind = \&PDL::minimum_ind; #line 1158 "Ufunc.pm" #line 317 "ufunc.pd" =head2 minover_ind =for ref Synonym for minimum_ind. =cut *PDL::minover_ind = *minover_ind = \&PDL::minimum_ind; #line 1172 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 minimum_n_ind =for sig Signature: (a(n); indx [o]c(m)) =for ref Returns the index of C minimum elements =for bad Not yet been converted to ignore bad values =cut #line 1194 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *minimum_n_ind = \&PDL::minimum_n_ind; #line 1200 "Ufunc.pm" #line 317 "ufunc.pd" =head2 minover_n_ind =for ref Synonym for minimum_n_ind. =cut *PDL::minover_n_ind = *minover_n_ind = \&PDL::minimum_n_ind; #line 1214 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 maximum =for sig Signature: (a(n); [o]c()) =for ref Project via maximum to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the maximum along the 1st dimension. By using L etc. it is possible to use I dimension. =for usage $y = maximum($x); =for example $spectrum = maximum $image->transpose =for bad Output is set bad if all elements of the input are bad, otherwise the bad flag is cleared for the output ndarray. Note that C are considered to be valid values; see L and L for ways of masking NaNs. =cut #line 1261 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *maximum = \&PDL::maximum; #line 1267 "Ufunc.pm" #line 317 "ufunc.pd" =head2 maxover =for ref Synonym for maximum. =cut *PDL::maxover = *maxover = \&PDL::maximum; #line 1281 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 maximum_ind =for sig Signature: (a(n); indx [o] c()) =for ref Like maximum but returns the index rather than the value =for bad Output is set bad if all elements of the input are bad, otherwise the bad flag is cleared for the output ndarray. =cut #line 1304 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *maximum_ind = \&PDL::maximum_ind; #line 1310 "Ufunc.pm" #line 317 "ufunc.pd" =head2 maxover_ind =for ref Synonym for maximum_ind. =cut *PDL::maxover_ind = *maxover_ind = \&PDL::maximum_ind; #line 1324 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 maximum_n_ind =for sig Signature: (a(n); indx [o]c(m)) =for ref Returns the index of C maximum elements =for bad Not yet been converted to ignore bad values =cut #line 1346 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *maximum_n_ind = \&PDL::maximum_n_ind; #line 1352 "Ufunc.pm" #line 317 "ufunc.pd" =head2 maxover_n_ind =for ref Synonym for maximum_n_ind. =cut *PDL::maxover_n_ind = *maxover_n_ind = \&PDL::maximum_n_ind; #line 1366 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 minmaximum =for sig Signature: (a(n); [o]cmin(); [o] cmax(); indx [o]cmin_ind(); indx [o]cmax_ind()) =for ref Find minimum and maximum and their indices for a given ndarray; =for usage pdl> $x=pdl [[-2,3,4],[1,0,3]] pdl> ($min, $max, $min_ind, $max_ind)=minmaximum($x) pdl> p $min, $max, $min_ind, $max_ind [-2 0] [4 3] [0 1] [2 2] See also L, which clumps the ndarray together. =for bad If C contains only bad data, then the output ndarrays will be set bad, along with their bad flag. Otherwise they will have their bad flags cleared, since they will not contain any bad values. =cut #line 1403 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *minmaximum = \&PDL::minmaximum; #line 1409 "Ufunc.pm" #line 317 "ufunc.pd" =head2 minmaxover =for ref Synonym for minmaximum. =cut *PDL::minmaxover = *minmaxover = \&PDL::minmaximum; #line 1423 "Ufunc.pm" #line 565 "ufunc.pd" =head2 avg =for ref Return the average of all elements in an ndarray. See the documentation for L for more information. =for usage $x = avg($data); =for bad This routine handles bad values. =cut *avg = \&PDL::avg; sub PDL::avg { my($x) = @_; my $tmp; $x->clump(-1)->average( $tmp=PDL->nullcreate($x) ); $tmp; } #line 1452 "Ufunc.pm" #line 565 "ufunc.pd" =head2 sum =for ref Return the sum of all elements in an ndarray. See the documentation for L for more information. =for usage $x = sum($data); =for bad This routine handles bad values. =cut *sum = \&PDL::sum; sub PDL::sum { my($x) = @_; my $tmp; $x->clump(-1)->sumover( $tmp=PDL->nullcreate($x) ); $tmp; } #line 1481 "Ufunc.pm" #line 565 "ufunc.pd" =head2 prod =for ref Return the product of all elements in an ndarray. See the documentation for L for more information. =for usage $x = prod($data); =for bad This routine handles bad values. =cut *prod = \&PDL::prod; sub PDL::prod { my($x) = @_; my $tmp; $x->clump(-1)->prodover( $tmp=PDL->nullcreate($x) ); $tmp; } #line 1510 "Ufunc.pm" #line 565 "ufunc.pd" =head2 davg =for ref Return the average (in double precision) of all elements in an ndarray. See the documentation for L for more information. =for usage $x = davg($data); =for bad This routine handles bad values. =cut *davg = \&PDL::davg; sub PDL::davg { my($x) = @_; my $tmp; $x->clump(-1)->daverage( $tmp=PDL->nullcreate($x) ); $tmp; } #line 1539 "Ufunc.pm" #line 565 "ufunc.pd" =head2 dsum =for ref Return the sum (in double precision) of all elements in an ndarray. See the documentation for L for more information. =for usage $x = dsum($data); =for bad This routine handles bad values. =cut *dsum = \&PDL::dsum; sub PDL::dsum { my($x) = @_; my $tmp; $x->clump(-1)->dsumover( $tmp=PDL->nullcreate($x) ); $tmp; } #line 1568 "Ufunc.pm" #line 565 "ufunc.pd" =head2 dprod =for ref Return the product (in double precision) of all elements in an ndarray. See the documentation for L for more information. =for usage $x = dprod($data); =for bad This routine handles bad values. =cut *dprod = \&PDL::dprod; sub PDL::dprod { my($x) = @_; my $tmp; $x->clump(-1)->dprodover( $tmp=PDL->nullcreate($x) ); $tmp; } #line 1597 "Ufunc.pm" #line 565 "ufunc.pd" =head2 zcheck =for ref Return the check for zero of all elements in an ndarray. See the documentation for L for more information. =for usage $x = zcheck($data); =for bad This routine handles bad values. =cut *zcheck = \&PDL::zcheck; sub PDL::zcheck { my($x) = @_; my $tmp; $x->clump(-1)->zcover( $tmp=PDL->nullcreate($x) ); $tmp; } #line 1626 "Ufunc.pm" #line 565 "ufunc.pd" =head2 and =for ref Return the logical and of all elements in an ndarray. See the documentation for L for more information. =for usage $x = and($data); =for bad This routine handles bad values. =cut *and = \&PDL::and; sub PDL::and { my($x) = @_; my $tmp; $x->clump(-1)->andover( $tmp=PDL->nullcreate($x) ); $tmp; } #line 1655 "Ufunc.pm" #line 565 "ufunc.pd" =head2 band =for ref Return the bitwise and of all elements in an ndarray. See the documentation for L for more information. =for usage $x = band($data); =for bad This routine handles bad values. =cut *band = \&PDL::band; sub PDL::band { my($x) = @_; my $tmp; $x->clump(-1)->bandover( $tmp=PDL->nullcreate($x) ); $tmp; } #line 1684 "Ufunc.pm" #line 565 "ufunc.pd" =head2 or =for ref Return the logical or of all elements in an ndarray. See the documentation for L for more information. =for usage $x = or($data); =for bad This routine handles bad values. =cut *or = \&PDL::or; sub PDL::or { my($x) = @_; my $tmp; $x->clump(-1)->orover( $tmp=PDL->nullcreate($x) ); $tmp; } #line 1713 "Ufunc.pm" #line 565 "ufunc.pd" =head2 bor =for ref Return the bitwise or of all elements in an ndarray. See the documentation for L for more information. =for usage $x = bor($data); =for bad This routine handles bad values. =cut *bor = \&PDL::bor; sub PDL::bor { my($x) = @_; my $tmp; $x->clump(-1)->borover( $tmp=PDL->nullcreate($x) ); $tmp; } #line 1742 "Ufunc.pm" #line 565 "ufunc.pd" =head2 min =for ref Return the minimum of all elements in an ndarray. See the documentation for L for more information. =for usage $x = min($data); =for bad This routine handles bad values. =cut *min = \&PDL::min; sub PDL::min { my($x) = @_; my $tmp; $x->clump(-1)->minimum( $tmp=PDL->nullcreate($x) ); $tmp; } #line 1771 "Ufunc.pm" #line 565 "ufunc.pd" =head2 max =for ref Return the maximum of all elements in an ndarray. See the documentation for L for more information. =for usage $x = max($data); =for bad This routine handles bad values. =cut *max = \&PDL::max; sub PDL::max { my($x) = @_; my $tmp; $x->clump(-1)->maximum( $tmp=PDL->nullcreate($x) ); $tmp; } #line 1800 "Ufunc.pm" #line 565 "ufunc.pd" =head2 median =for ref Return the median of all elements in an ndarray. See the documentation for L for more information. =for usage $x = median($data); =for bad This routine handles bad values. =cut *median = \&PDL::median; sub PDL::median { my($x) = @_; my $tmp; $x->clump(-1)->medover( $tmp=PDL->nullcreate($x) ); $tmp; } #line 1829 "Ufunc.pm" #line 565 "ufunc.pd" =head2 mode =for ref Return the mode of all elements in an ndarray. See the documentation for L for more information. =for usage $x = mode($data); =for bad This routine handles bad values. =cut *mode = \&PDL::mode; sub PDL::mode { my($x) = @_; my $tmp; $x->clump(-1)->modeover( $tmp=PDL->nullcreate($x) ); $tmp; } #line 1858 "Ufunc.pm" #line 565 "ufunc.pd" =head2 oddmedian =for ref Return the oddmedian of all elements in an ndarray. See the documentation for L for more information. =for usage $x = oddmedian($data); =for bad This routine handles bad values. =cut *oddmedian = \&PDL::oddmedian; sub PDL::oddmedian { my($x) = @_; my $tmp; $x->clump(-1)->oddmedover( $tmp=PDL->nullcreate($x) ); $tmp; } #line 1887 "Ufunc.pm" #line 595 "ufunc.pd" =head2 any =for ref Return true if any element in ndarray set Useful in conditional expressions: =for example if (any $x>15) { print "some values are greater than 15\n" } =for bad See L for comments on what happens when all elements in the check are bad. =cut *any = \∨ *PDL::any = \&PDL::or; =head2 all =for ref Return true if all elements in ndarray set Useful in conditional expressions: =for example if (all $x>15) { print "all values are greater than 15\n" } =for bad See L for comments on what happens when all elements in the check are bad. =cut *all = \∧ *PDL::all = \&PDL::and; =head2 minmax =for ref Returns a list with minimum and maximum values of an ndarray. =for usage ($mn, $mx) = minmax($pdl); This routine does I thread over the dimensions of C<$pdl>; it returns the minimum and maximum values of the whole ndarray. See L if this is not what is required. The two values are returned as Perl scalars similar to min/max, and therefore ignore whether the values are bad. =for example pdl> $x = pdl [1,-2,3,5,0] pdl> ($min, $max) = minmax($x); pdl> p "$min $max\n"; -2 5 =cut *minmax = \&PDL::minmax; sub PDL::minmax { my ($x)=@_; my $tmp; my @arr = $x->clump(-1)->minmaximum; map $_->sclr, @arr[0,1]; # as scalars ! } #line 1968 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 medover =for sig Signature: (a(n); [o]b(); [t]tmp(n)) =for ref Project via median to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the median along the 1st dimension. By using L etc. it is possible to use I dimension. =for usage $y = medover($x); =for example $spectrum = medover $image->transpose =for bad medover processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2011 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *medover = \&PDL::medover; #line 2017 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 oddmedover =for sig Signature: (a(n); [o]b(); [t]tmp(n)) =for ref Project via oddmedian to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the oddmedian along the 1st dimension. By using L etc. it is possible to use I dimension. =for usage $y = oddmedover($x); =for example $spectrum = oddmedover $image->transpose The median is sometimes not a good choice as if the array has an even number of elements it lies half-way between the two middle values - thus it does not always correspond to a data value. The lower-odd median is just the lower of these two values and so it ALWAYS sits on an actual data value which is useful in some circumstances. =for bad oddmedover processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2068 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *oddmedover = \&PDL::oddmedover; #line 2074 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 modeover =for sig Signature: (data(n); [o]out(); [t]sorted(n)) =for ref Project via mode to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the mode along the 1st dimension. By using L etc. it is possible to use I dimension. =for usage $y = modeover($x); =for example $spectrum = modeover $image->transpose The mode is the single element most frequently found in a discrete data set. It I makes sense for integer data types, since floating-point types are demoted to integer before the mode is calculated. C treats BAD the same as any other value: if BAD is the most common element, the returned value is also BAD. =for bad modeover does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2127 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *modeover = \&PDL::modeover; #line 2133 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 pctover =for sig Signature: (a(n); p(); [o]b(); [t]tmp(n)) =for ref Project via specified percentile to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the specified percentile along the 1st dimension. By using L etc. it is possible to use I dimension. =for usage $y = pctover($x); =for example $spectrum = pctover $image->transpose The specified percentile must be between 0.0 and 1.0. When the specified percentile falls between data points, the result is interpolated. Values outside the allowed range are clipped to 0.0 or 1.0 respectively. The algorithm implemented here is based on the interpolation variant described at L as used by Microsoft Excel and recommended by NIST. =for bad pctover processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2183 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *pctover = \&PDL::pctover; #line 2189 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 oddpctover =for sig Signature: (a(n); p(); [o]b(); [t]tmp(n)) =for ref Project via specified percentile to N-1 dimensions This function reduces the dimensionality of an ndarray by one by taking the specified percentile along the 1st dimension. By using L etc. it is possible to use I dimension. =for usage $y = oddpctover($x); =for example $spectrum = oddpctover $image->transpose The specified percentile must be between 0.0 and 1.0. When the specified percentile falls between two values, the nearest data value is the result. The algorithm implemented is from the textbook version described first at L. =for bad oddpctover processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 2237 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *oddpctover = \&PDL::oddpctover; #line 2243 "Ufunc.pm" #line 1008 "ufunc.pd" =head2 pct =for ref Return the specified percentile of all elements in an ndarray. The specified percentile (p) must be between 0.0 and 1.0. When the specified percentile falls between data points, the result is interpolated. =for usage $x = pct($data, $pct); =cut *pct = \&PDL::pct; sub PDL::pct { my($x, $p) = @_; $x->clump(-1)->pctover($p, my $tmp=PDL->nullcreate($x)); $tmp; } #line 2269 "Ufunc.pm" #line 1033 "ufunc.pd" =head2 oddpct =for ref Return the specified percentile of all elements in an ndarray. The specified percentile must be between 0.0 and 1.0. When the specified percentile falls between two values, the nearest data value is the result. =for usage $x = oddpct($data, $pct); =cut *oddpct = \&PDL::oddpct; sub PDL::oddpct { my($x, $p) = @_; $x->clump(-1)->oddpctover($p, my $tmp=PDL->nullcreate($x)); $tmp; } #line 2295 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 qsort =for sig Signature: (a(n); [o]b(n)) =for ref Quicksort a vector into ascending order. =for example print qsort random(10); =for bad Bad values are moved to the end of the array: pdl> p $y [42 47 98 BAD 22 96 74 41 79 76 96 BAD 32 76 25 59 BAD 96 32 BAD] pdl> p qsort($y) [22 25 32 32 41 42 47 59 74 76 76 79 96 96 96 98 BAD BAD BAD BAD] =cut #line 2330 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *qsort = \&PDL::qsort; #line 2336 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 qsorti =for sig Signature: (a(n); indx [o]indx(n)) =for ref Quicksort a vector and return index of elements in ascending order. =for example $ix = qsorti $x; print $x->index($ix); # Sorted list =for bad Bad elements are moved to the end of the array: pdl> p $y [42 47 98 BAD 22 96 74 41 79 76 96 BAD 32 76 25 59 BAD 96 32 BAD] pdl> p $y->index( qsorti($y) ) [22 25 32 32 41 42 47 59 74 76 76 79 96 96 96 98 BAD BAD BAD BAD] =cut #line 2372 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *qsorti = \&PDL::qsorti; #line 2378 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 qsortvec =for sig Signature: (a(n,m); [o]b(n,m)) =for ref Sort a list of vectors lexicographically. The 0th dimension of the source ndarray is dimension in the vector; the 1st dimension is list order. Higher dimensions are threaded over. =for example print qsortvec pdl([[1,2],[0,500],[2,3],[4,2],[3,4],[3,5]]); [ [ 0 500] [ 1 2] [ 2 3] [ 3 4] [ 3 5] [ 4 2] ] =for bad Vectors with bad components are moved to the end of the array: pdl> p $p = pdl("[0 0] [-100 0] [BAD 0] [100 0]")->qsortvec [ [-100 0] [ 0 0] [ 100 0] [ BAD 0] ] =cut #line 2428 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *qsortvec = \&PDL::qsortvec; #line 2434 "Ufunc.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 qsortveci =for sig Signature: (a(n,m); indx [o]indx(m)) =for ref Sort a list of vectors lexicographically, returning the indices of the sorted vectors rather than the sorted list itself. As with C, the input PDL should be an NxM array containing M separate N-dimensional vectors. The return value is an integer M-PDL containing the M-indices of original array rows, in sorted order. As with C, the zeroth element of the vectors runs slowest in the sorted list. Additional dimensions are threaded over: each plane is sorted separately, so qsortveci may be thought of as a collapse operator of sorts (groan). =for bad Vectors with bad components are moved to the end of the array as for L. =cut #line 2472 "Ufunc.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *qsortveci = \&PDL::qsortveci; #line 2478 "Ufunc.pm" #line 1302 "ufunc.pd" =head1 AUTHOR Copyright (C) Tuomas J. Lukka 1997 (lukka@husc.harvard.edu). Contributions by Christian Soeller (c.soeller@auckland.ac.nz) and Karl Glazebrook (kgb@aaoepp.aao.gov.au). 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 #line 2498 "Ufunc.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/Ops.pm0000644000175000017500000011436514200406305015113 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::Ops; our @EXPORT_OK = qw( log10 assgn carg conj czip ipow r2C i2C ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Ops ; #line 19 "ops.pd" use strict; use warnings; my %OVERLOADS; =head1 NAME PDL::Ops - Fundamental mathematical operators =head1 DESCRIPTION This module provides the functions used by PDL to overload the basic mathematical operators (C<+ - / *> etc.) and functions (C etc.) It also includes the function C, which should be a perl function so that we can overload it! Matrix multiplication (the operator C) is handled by the module L. =head1 SYNOPSIS none =cut #line 53 "Ops.pm" =head1 FUNCTIONS =cut #line 134 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'+'} = $overload_sub = sub(;@) { return PDL::plus(@_) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '+')) && $foo != $overload_sub; # recursion guard $foo->($_[1], $_[0], !$_[2]); }; } } BEGIN { # in1, in2, out, swap if true $OVERLOADS{'+='} = sub { PDL::plus($_[0], $_[1], $_[0], 0); $_[0] }; } #line 82 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 plus =for sig Signature: (a(); b(); [o]c(); int swap) =for ref add two ndarrays =for example $c = $x + $y; # overloaded call $c = plus $x, $y; # explicit call with default swap of 0 $c = plus $x, $y, 1; # explicit call with trailing 1 to swap args $x->inplace->plus($y); # modify $x inplace It can be made to work inplace with the C<< $x->inplace >> syntax. This function is used to overload the binary C<+> operator. As of 2.065, when calling this function explicitly you can omit the third argument (see second example), or supply it (see third one). =for bad plus processes bad values. The state of the bad-value flag of the output ndarrays is unknown. =cut #line 120 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *plus = \&PDL::plus; #line 126 "Ops.pm" #line 134 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'*'} = $overload_sub = sub(;@) { return PDL::mult(@_) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '*')) && $foo != $overload_sub; # recursion guard $foo->($_[1], $_[0], !$_[2]); }; } } BEGIN { # in1, in2, out, swap if true $OVERLOADS{'*='} = sub { PDL::mult($_[0], $_[1], $_[0], 0); $_[0] }; } #line 145 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 mult =for sig Signature: (a(); b(); [o]c(); int swap) =for ref multiply two ndarrays =for example $c = $x * $y; # overloaded call $c = mult $x, $y; # explicit call with default swap of 0 $c = mult $x, $y, 1; # explicit call with trailing 1 to swap args $x->inplace->mult($y); # modify $x inplace It can be made to work inplace with the C<< $x->inplace >> syntax. This function is used to overload the binary C<*> operator. As of 2.065, when calling this function explicitly you can omit the third argument (see second example), or supply it (see third one). =for bad mult processes bad values. The state of the bad-value flag of the output ndarrays is unknown. =cut #line 183 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *mult = \&PDL::mult; #line 189 "Ops.pm" #line 134 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'-'} = $overload_sub = sub(;@) { return PDL::minus(@_) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '-')) && $foo != $overload_sub; # recursion guard $foo->($_[1], $_[0], !$_[2]); }; } } BEGIN { # in1, in2, out, swap if true $OVERLOADS{'-='} = sub { PDL::minus($_[0], $_[1], $_[0], 0); $_[0] }; } #line 208 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 minus =for sig Signature: (a(); b(); [o]c(); int swap) =for ref subtract two ndarrays =for example $c = $x - $y; # overloaded call $c = minus $x, $y; # explicit call with default swap of 0 $c = minus $x, $y, 1; # explicit call with trailing 1 to swap args $x->inplace->minus($y); # modify $x inplace It can be made to work inplace with the C<< $x->inplace >> syntax. This function is used to overload the binary C<-> operator. As of 2.065, when calling this function explicitly you can omit the third argument (see second example), or supply it (see third one). =for bad minus processes bad values. The state of the bad-value flag of the output ndarrays is unknown. =cut #line 246 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *minus = \&PDL::minus; #line 252 "Ops.pm" #line 134 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'/'} = $overload_sub = sub(;@) { return PDL::divide(@_) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '/')) && $foo != $overload_sub; # recursion guard $foo->($_[1], $_[0], !$_[2]); }; } } BEGIN { # in1, in2, out, swap if true $OVERLOADS{'/='} = sub { PDL::divide($_[0], $_[1], $_[0], 0); $_[0] }; } #line 271 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 divide =for sig Signature: (a(); b(); [o]c(); int swap) =for ref divide two ndarrays =for example $c = $x / $y; # overloaded call $c = divide $x, $y; # explicit call with default swap of 0 $c = divide $x, $y, 1; # explicit call with trailing 1 to swap args $x->inplace->divide($y); # modify $x inplace It can be made to work inplace with the C<< $x->inplace >> syntax. This function is used to overload the binary C operator. As of 2.065, when calling this function explicitly you can omit the third argument (see second example), or supply it (see third one). =for bad divide processes bad values. The state of the bad-value flag of the output ndarrays is unknown. =cut #line 309 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *divide = \&PDL::divide; #line 315 "Ops.pm" #line 134 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'>'} = $overload_sub = sub(;@) { return PDL::gt(@_) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '>')) && $foo != $overload_sub; # recursion guard $foo->($_[1], $_[0], !$_[2]); }; } } #line 330 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 gt =for sig Signature: (a(); b(); [o]c(); int swap) =for ref the binary E (greater than) operation =for example $c = $x > $y; # overloaded call $c = gt $x, $y; # explicit call with default swap of 0 $c = gt $x, $y, 1; # explicit call with trailing 1 to swap args $x->inplace->gt($y); # modify $x inplace It can be made to work inplace with the C<< $x->inplace >> syntax. This function is used to overload the binary C> operator. As of 2.065, when calling this function explicitly you can omit the third argument (see second example), or supply it (see third one). =for bad gt processes bad values. The state of the bad-value flag of the output ndarrays is unknown. =cut #line 368 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *gt = \&PDL::gt; #line 374 "Ops.pm" #line 134 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'<'} = $overload_sub = sub(;@) { return PDL::lt(@_) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '<')) && $foo != $overload_sub; # recursion guard $foo->($_[1], $_[0], !$_[2]); }; } } #line 389 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 lt =for sig Signature: (a(); b(); [o]c(); int swap) =for ref the binary E (less than) operation =for example $c = $x < $y; # overloaded call $c = lt $x, $y; # explicit call with default swap of 0 $c = lt $x, $y, 1; # explicit call with trailing 1 to swap args $x->inplace->lt($y); # modify $x inplace It can be made to work inplace with the C<< $x->inplace >> syntax. This function is used to overload the binary C> operator. As of 2.065, when calling this function explicitly you can omit the third argument (see second example), or supply it (see third one). =for bad lt processes bad values. The state of the bad-value flag of the output ndarrays is unknown. =cut #line 427 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *lt = \&PDL::lt; #line 433 "Ops.pm" #line 134 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'<='} = $overload_sub = sub(;@) { return PDL::le(@_) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '<=')) && $foo != $overload_sub; # recursion guard $foo->($_[1], $_[0], !$_[2]); }; } } #line 448 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 le =for sig Signature: (a(); b(); [o]c(); int swap) =for ref the binary E= (less equal) operation =for example $c = $x <= $y; # overloaded call $c = le $x, $y; # explicit call with default swap of 0 $c = le $x, $y, 1; # explicit call with trailing 1 to swap args $x->inplace->le($y); # modify $x inplace It can be made to work inplace with the C<< $x->inplace >> syntax. This function is used to overload the binary C=> operator. As of 2.065, when calling this function explicitly you can omit the third argument (see second example), or supply it (see third one). =for bad le processes bad values. The state of the bad-value flag of the output ndarrays is unknown. =cut #line 486 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *le = \&PDL::le; #line 492 "Ops.pm" #line 134 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'>='} = $overload_sub = sub(;@) { return PDL::ge(@_) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '>=')) && $foo != $overload_sub; # recursion guard $foo->($_[1], $_[0], !$_[2]); }; } } #line 507 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 ge =for sig Signature: (a(); b(); [o]c(); int swap) =for ref the binary E= (greater equal) operation =for example $c = $x >= $y; # overloaded call $c = ge $x, $y; # explicit call with default swap of 0 $c = ge $x, $y, 1; # explicit call with trailing 1 to swap args $x->inplace->ge($y); # modify $x inplace It can be made to work inplace with the C<< $x->inplace >> syntax. This function is used to overload the binary C=> operator. As of 2.065, when calling this function explicitly you can omit the third argument (see second example), or supply it (see third one). =for bad ge processes bad values. The state of the bad-value flag of the output ndarrays is unknown. =cut #line 545 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *ge = \&PDL::ge; #line 551 "Ops.pm" #line 134 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'=='} = $overload_sub = sub(;@) { return PDL::eq(@_) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '==')) && $foo != $overload_sub; # recursion guard $foo->($_[1], $_[0], !$_[2]); }; } } #line 566 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 eq =for sig Signature: (a(); b(); [o]c(); int swap) =for ref binary I operation (C<==>) =for example $c = $x == $y; # overloaded call $c = eq $x, $y; # explicit call with default swap of 0 $c = eq $x, $y, 1; # explicit call with trailing 1 to swap args $x->inplace->eq($y); # modify $x inplace It can be made to work inplace with the C<< $x->inplace >> syntax. This function is used to overload the binary C<==> operator. As of 2.065, when calling this function explicitly you can omit the third argument (see second example), or supply it (see third one). =for bad eq processes bad values. The state of the bad-value flag of the output ndarrays is unknown. =cut #line 604 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *eq = \&PDL::eq; #line 610 "Ops.pm" #line 134 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'!='} = $overload_sub = sub(;@) { return PDL::ne(@_) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '!=')) && $foo != $overload_sub; # recursion guard $foo->($_[1], $_[0], !$_[2]); }; } } #line 625 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 ne =for sig Signature: (a(); b(); [o]c(); int swap) =for ref binary I operation (C) =for example $c = $x != $y; # overloaded call $c = ne $x, $y; # explicit call with default swap of 0 $c = ne $x, $y, 1; # explicit call with trailing 1 to swap args $x->inplace->ne($y); # modify $x inplace It can be made to work inplace with the C<< $x->inplace >> syntax. This function is used to overload the binary C operator. As of 2.065, when calling this function explicitly you can omit the third argument (see second example), or supply it (see third one). =for bad ne processes bad values. The state of the bad-value flag of the output ndarrays is unknown. =cut #line 663 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *ne = \&PDL::ne; #line 669 "Ops.pm" #line 134 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'<<'} = $overload_sub = sub(;@) { return PDL::shiftleft(@_) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '<<')) && $foo != $overload_sub; # recursion guard $foo->($_[1], $_[0], !$_[2]); }; } } BEGIN { # in1, in2, out, swap if true $OVERLOADS{'<<='} = sub { PDL::shiftleft($_[0], $_[1], $_[0], 0); $_[0] }; } #line 688 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 shiftleft =for sig Signature: (a(); b(); [o]c(); int swap) =for ref leftshift C<$a> by C<$b> =for example $c = $x << $y; # overloaded call $c = shiftleft $x, $y; # explicit call with default swap of 0 $c = shiftleft $x, $y, 1; # explicit call with trailing 1 to swap args $x->inplace->shiftleft($y); # modify $x inplace It can be made to work inplace with the C<< $x->inplace >> syntax. This function is used to overload the binary CE> operator. As of 2.065, when calling this function explicitly you can omit the third argument (see second example), or supply it (see third one). =for bad shiftleft processes bad values. The state of the bad-value flag of the output ndarrays is unknown. =cut #line 726 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *shiftleft = \&PDL::shiftleft; #line 732 "Ops.pm" #line 134 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'>>'} = $overload_sub = sub(;@) { return PDL::shiftright(@_) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '>>')) && $foo != $overload_sub; # recursion guard $foo->($_[1], $_[0], !$_[2]); }; } } BEGIN { # in1, in2, out, swap if true $OVERLOADS{'>>='} = sub { PDL::shiftright($_[0], $_[1], $_[0], 0); $_[0] }; } #line 751 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 shiftright =for sig Signature: (a(); b(); [o]c(); int swap) =for ref rightshift C<$a> by C<$b> =for example $c = $x >> $y; # overloaded call $c = shiftright $x, $y; # explicit call with default swap of 0 $c = shiftright $x, $y, 1; # explicit call with trailing 1 to swap args $x->inplace->shiftright($y); # modify $x inplace It can be made to work inplace with the C<< $x->inplace >> syntax. This function is used to overload the binary CE> operator. As of 2.065, when calling this function explicitly you can omit the third argument (see second example), or supply it (see third one). =for bad shiftright processes bad values. The state of the bad-value flag of the output ndarrays is unknown. =cut #line 789 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *shiftright = \&PDL::shiftright; #line 795 "Ops.pm" #line 134 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'|'} = $overload_sub = sub(;@) { return PDL::or2($_[2]?@_[1,0]:@_[0,1]) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '|')) && $foo != $overload_sub; # recursion guard $foo->($_[1], $_[0], !$_[2]); }; } } BEGIN { # in1, in2, out, swap if true $OVERLOADS{'|='} = sub { PDL::or2($_[0], $_[1], $_[0], 0); $_[0] }; } #line 814 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 or2 =for sig Signature: (a(); b(); [o]c(); int swap) =for ref binary I of two ndarrays =for example $c = $x | $y; # overloaded call $c = or2 $x, $y; # explicit call with default swap of 0 $c = or2 $x, $y, 1; # explicit call with trailing 1 to swap args $x->inplace->or2($y); # modify $x inplace It can be made to work inplace with the C<< $x->inplace >> syntax. This function is used to overload the binary C<|> operator. As of 2.065, when calling this function explicitly you can omit the third argument (see second example), or supply it (see third one). =for bad or2 processes bad values. The state of the bad-value flag of the output ndarrays is unknown. =cut #line 852 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *or2 = \&PDL::or2; #line 858 "Ops.pm" #line 134 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'&'} = $overload_sub = sub(;@) { return PDL::and2($_[2]?@_[1,0]:@_[0,1]) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '&')) && $foo != $overload_sub; # recursion guard $foo->($_[1], $_[0], !$_[2]); }; } } BEGIN { # in1, in2, out, swap if true $OVERLOADS{'&='} = sub { PDL::and2($_[0], $_[1], $_[0], 0); $_[0] }; } #line 877 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 and2 =for sig Signature: (a(); b(); [o]c(); int swap) =for ref binary I of two ndarrays =for example $c = $x & $y; # overloaded call $c = and2 $x, $y; # explicit call with default swap of 0 $c = and2 $x, $y, 1; # explicit call with trailing 1 to swap args $x->inplace->and2($y); # modify $x inplace It can be made to work inplace with the C<< $x->inplace >> syntax. This function is used to overload the binary C<&> operator. As of 2.065, when calling this function explicitly you can omit the third argument (see second example), or supply it (see third one). =for bad and2 processes bad values. The state of the bad-value flag of the output ndarrays is unknown. =cut #line 915 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *and2 = \&PDL::and2; #line 921 "Ops.pm" #line 134 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'^'} = $overload_sub = sub(;@) { return PDL::xor($_[2]?@_[1,0]:@_[0,1]) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '^')) && $foo != $overload_sub; # recursion guard $foo->($_[1], $_[0], !$_[2]); }; } } BEGIN { # in1, in2, out, swap if true $OVERLOADS{'^='} = sub { PDL::xor($_[0], $_[1], $_[0], 0); $_[0] }; } #line 940 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 xor =for sig Signature: (a(); b(); [o]c(); int swap) =for ref binary I of two ndarrays =for example $c = $x ^ $y; # overloaded call $c = xor $x, $y; # explicit call with default swap of 0 $c = xor $x, $y, 1; # explicit call with trailing 1 to swap args $x->inplace->xor($y); # modify $x inplace It can be made to work inplace with the C<< $x->inplace >> syntax. This function is used to overload the binary C<^> operator. As of 2.065, when calling this function explicitly you can omit the third argument (see second example), or supply it (see third one). =for bad xor processes bad values. The state of the bad-value flag of the output ndarrays is unknown. =cut #line 978 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *xor = \&PDL::xor; #line 984 "Ops.pm" #line 319 "ops.pd" BEGIN { $OVERLOADS{'~'} = sub { PDL::bitnot($_[0]) } } #line 990 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 bitnot =for sig Signature: (a(); [o]b()) =for ref unary bit negation =for example $y = ~ $x; $x->inplace->bitnot; # modify $x inplace It can be made to work inplace with the C<$x-Einplace> syntax. This function is used to overload the unary C<~> operator/function. =for bad bitnot processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1024 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *bitnot = \&PDL::bitnot; #line 1030 "Ops.pm" #line 253 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'**'} = $overload_sub = sub(;@) { return PDL::power(@_) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '**')) && $foo != $overload_sub; # recursion guard $foo->($_[1], $_[0], !$_[2]); }; } } BEGIN { # in1, in2, out, swap if true $OVERLOADS{'**='} = sub { PDL::power($_[0], $_[1], $_[0], 0); $_[0] }; } #line 1049 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 power =for sig Signature: (a(); b(); [o]c(); int swap) =for ref raise ndarray C<$a> to the power C<$b> =for example $c = $x->power($y,0); # explicit function call $c = $a ** $b; # overloaded use $x->inplace->power($y,0); # modify $x inplace It can be made to work inplace with the C<$x-Einplace> syntax. This function is used to overload the binary C<**> function. Note that when calling this function explicitly you need to supply a third argument that should generally be zero (see first example). This restriction is expected to go away in future releases. =for bad power processes bad values. The state of the bad-value flag of the output ndarrays is unknown. =cut #line 1087 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *power = \&PDL::power; #line 1093 "Ops.pm" #line 253 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'atan2'} = $overload_sub = sub(;@) { return PDL::atan2(@_) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], 'atan2')) && $foo != $overload_sub; # recursion guard $foo->($_[1], $_[0], !$_[2]); }; } } #line 1108 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 atan2 =for sig Signature: (a(); b(); [o]c(); int swap) =for ref elementwise C of two ndarrays =for example $c = $x->atan2($y,0); # explicit function call $c = atan2 $a, $b; # overloaded use $x->inplace->atan2($y,0); # modify $x inplace It can be made to work inplace with the C<$x-Einplace> syntax. This function is used to overload the binary C function. Note that when calling this function explicitly you need to supply a third argument that should generally be zero (see first example). This restriction is expected to go away in future releases. =for bad atan2 processes bad values. The state of the bad-value flag of the output ndarrays is unknown. =cut #line 1146 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *atan2 = \&PDL::atan2; #line 1152 "Ops.pm" #line 253 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'%'} = $overload_sub = sub(;@) { return PDL::modulo(@_) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '%')) && $foo != $overload_sub; # recursion guard $foo->($_[1], $_[0], !$_[2]); }; } } BEGIN { # in1, in2, out, swap if true $OVERLOADS{'%='} = sub { PDL::modulo($_[0], $_[1], $_[0], 0); $_[0] }; } #line 1171 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 modulo =for sig Signature: (a(); b(); [o]c(); int swap) =for ref elementwise C operation =for example $c = $x->modulo($y,0); # explicit function call $c = $a % $b; # overloaded use $x->inplace->modulo($y,0); # modify $x inplace It can be made to work inplace with the C<$x-Einplace> syntax. This function is used to overload the binary C<%> function. Note that when calling this function explicitly you need to supply a third argument that should generally be zero (see first example). This restriction is expected to go away in future releases. =for bad modulo processes bad values. The state of the bad-value flag of the output ndarrays is unknown. =cut #line 1209 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *modulo = \&PDL::modulo; #line 1215 "Ops.pm" #line 253 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'<=>'} = $overload_sub = sub(;@) { return PDL::spaceship(@_) unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '<=>')) && $foo != $overload_sub; # recursion guard $foo->($_[1], $_[0], !$_[2]); }; } } #line 1230 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 spaceship =for sig Signature: (a(); b(); [o]c(); int swap) =for ref elementwise "<=>" operation =for example $c = $x->spaceship($y,0); # explicit function call $c = $a <=> $b; # overloaded use $x->inplace->spaceship($y,0); # modify $x inplace It can be made to work inplace with the C<$x-Einplace> syntax. This function is used to overload the binary C=E> function. Note that when calling this function explicitly you need to supply a third argument that should generally be zero (see first example). This restriction is expected to go away in future releases. =for bad spaceship processes bad values. The state of the bad-value flag of the output ndarrays is unknown. =cut #line 1268 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *spaceship = \&PDL::spaceship; #line 1274 "Ops.pm" #line 319 "ops.pd" BEGIN { $OVERLOADS{'sqrt'} = sub { PDL::sqrt($_[0]) } } #line 1280 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 sqrt =for sig Signature: (a(); [o]b()) =for ref elementwise square root =for example $y = sqrt $x; $x->inplace->sqrt; # modify $x inplace It can be made to work inplace with the C<$x-Einplace> syntax. This function is used to overload the unary C operator/function. =for bad sqrt processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1314 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *sqrt = \&PDL::sqrt; #line 1320 "Ops.pm" #line 319 "ops.pd" BEGIN { $OVERLOADS{'sin'} = sub { PDL::sin($_[0]) } } #line 1326 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 sin =for sig Signature: (a(); [o]b()) =for ref the sin function =for example $y = sin $x; $x->inplace->sin; # modify $x inplace It can be made to work inplace with the C<$x-Einplace> syntax. This function is used to overload the unary C operator/function. =for bad sin processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1360 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *sin = \&PDL::sin; #line 1366 "Ops.pm" #line 319 "ops.pd" BEGIN { $OVERLOADS{'cos'} = sub { PDL::cos($_[0]) } } #line 1372 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 cos =for sig Signature: (a(); [o]b()) =for ref the cos function =for example $y = cos $x; $x->inplace->cos; # modify $x inplace It can be made to work inplace with the C<$x-Einplace> syntax. This function is used to overload the unary C operator/function. =for bad cos processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1406 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *cos = \&PDL::cos; #line 1412 "Ops.pm" #line 319 "ops.pd" BEGIN { $OVERLOADS{'!'} = sub { PDL::not($_[0]) } } #line 1418 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 not =for sig Signature: (a(); [o]b()) =for ref the elementwise I operation =for example $y = ! $x; $x->inplace->not; # modify $x inplace It can be made to work inplace with the C<$x-Einplace> syntax. This function is used to overload the unary C operator/function. =for bad not processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1452 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *not = \&PDL::not; #line 1458 "Ops.pm" #line 319 "ops.pd" BEGIN { $OVERLOADS{'exp'} = sub { PDL::exp($_[0]) } } #line 1464 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 exp =for sig Signature: (a(); [o]b()) =for ref the exponential function =for example $y = exp $x; $x->inplace->exp; # modify $x inplace It can be made to work inplace with the C<$x-Einplace> syntax. This function is used to overload the unary C operator/function. =for bad exp processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1498 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *exp = \&PDL::exp; #line 1504 "Ops.pm" #line 319 "ops.pd" BEGIN { $OVERLOADS{'log'} = sub { PDL::log($_[0]) } } #line 1510 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 log =for sig Signature: (a(); [o]b()) =for ref the natural logarithm =for example $y = log $x; $x->inplace->log; # modify $x inplace It can be made to work inplace with the C<$x-Einplace> syntax. This function is used to overload the unary C operator/function. =for bad log processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1544 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *log = \&PDL::log; #line 1550 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 re =for sig Signature: (complexv(); real [o]b()) =for ref Returns the real part of a complex number. =for bad re processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1574 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *re = \&PDL::re; #line 1580 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 im =for sig Signature: (complexv(); real [o]b()) =for ref Returns the imaginary part of a complex number. =for bad im processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1604 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *im = \&PDL::im; #line 1610 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 _cabs =for sig Signature: (complexv(); real [o]b()) =for ref Returns the absolute (length) of a complex number. =for bad _cabs processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1634 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" #line 1639 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" #line 1644 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 log10 =for sig Signature: (a(); [o]b()) =for ref the base 10 logarithm =for example $y = log10 $x; $x->inplace->log10; # modify $x inplace It can be made to work inplace with the C<$x-Einplace> syntax. This function is used to overload the unary C operator/function. =for bad log10 processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1678 "Ops.pm" #line 1060 "../../blib/lib/PDL/PP.pm" sub PDL::log10 { my $x = shift; if ( ! UNIVERSAL::isa($x,"PDL") ) { return log($x) / log(10); } my $y; if ( $x->is_inplace ) { $x->set_inplace(0); $y = $x; } elsif( ref($x) eq "PDL"){ #PDL Objects, use nullcreate: $y = PDL->nullcreate($x); }else{ #PDL-Derived Object, use copy: (Consistent with # Auto-creation docs in Objects.pod) $y = $x->copy; } &PDL::_log10_int( $x, $y ); return $y; }; #line 1700 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *log10 = \&PDL::log10; #line 1706 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 assgn =for sig Signature: (a(); [o]b()) =for ref Plain numerical assignment. This is used to implement the ".=" operator =for bad If C is a child ndarray (e.g., the result of a slice) and bad values are generated in C, the bad value flag is set in C, but it is B automatically propagated back to the parent of C. The following idiom ensures that the badflag is propagated back to the parent of C: $pdl->slice(":,(1)") .= PDL::Bad_aware_func(); $pdl->badflag(1); $pdl->check_badflag(); This is unnecessary if $pdl->badflag is known to be 1 before the slice is performed. See http://pdl.perl.org/PDLdocs/BadValues.html#dataflow_of_the_badflag for details. =cut #line 1738 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *assgn = \&PDL::assgn; #line 1744 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 carg =for sig Signature: (complexv(); real [o]b()) =for ref Returns the polar angle of a complex number. =for bad carg processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1768 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *carg = \&PDL::carg; #line 1774 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 conj =for sig Signature: (complexv(); [o]b()) =for ref complex conjugate. =for bad conj processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1798 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *conj = \&PDL::conj; #line 1804 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 czip =for sig Signature: (r(); i(); complex [o]c()) convert real, imaginary to native complex, (sort of) like LISP zip function. Will add the C ndarray to "i" times the C ndarray. Only takes real ndarrays as input. =for bad czip does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1829 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *czip = \&PDL::czip; #line 1835 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 ipow =for sig Signature: (a(); indx b(); [o] ans()) =for ref raise ndarray C<$a> to integer power C<$b> =for example $c = $x->ipow($y,0); # explicit function call $c = ipow $x, $y; $x->inplace->ipow($y,0); # modify $x inplace It can be made to work inplace with the C<$x-Einplace> syntax. Note that when calling this function explicitly you need to supply a third argument that should generally be zero (see first example). This restriction is expected to go away in future releases. Algorithm from L =for bad ipow does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1875 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *ipow = \&PDL::ipow; #line 1881 "Ops.pm" #line 605 "ops.pd" =head2 abs =for ref Returns the absolute value of a number. =cut sub PDL::abs { $_[0]->type->real ? goto &PDL::_rabs : goto &PDL::_cabs } #line 1896 "Ops.pm" #line 617 "ops.pd" BEGIN { $OVERLOADS{'abs'} = sub { PDL::abs($_[0]) } } #line 1902 "Ops.pm" #line 619 "ops.pd" =head2 abs2 =for ref Returns the square of the absolute value of a number. =cut sub PDL::abs2 ($) { my $r = &PDL::abs; $r * $r } #line 1917 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 r2C =for sig Signature: (r(); complex [o]c()) =for ref convert real to native complex, with an imaginary part of zero =for bad r2C does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1941 "Ops.pm" #line 1060 "../../blib/lib/PDL/PP.pm" sub PDL::r2C ($) { return $_[0] if UNIVERSAL::isa($_[0], 'PDL') and !$_[0]->type->real; my $r = $_[1] // PDL->nullcreate($_[0]); PDL::_r2C_int($_[0], $r); $r; } #line 1952 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *r2C = \&PDL::r2C; #line 1958 "Ops.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 i2C =for sig Signature: (i(); complex [o]c()) =for ref convert imaginary to native complex, with a real part of zero =for bad i2C does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1982 "Ops.pm" #line 1060 "../../blib/lib/PDL/PP.pm" sub PDL::i2C ($) { return $_[0] if UNIVERSAL::isa($_[0], 'PDL') and !$_[0]->type->real; my $r = $_[1] // PDL->nullcreate($_[0]); PDL::_i2C_int($_[0], $r); $r; } #line 1993 "Ops.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *i2C = \&PDL::i2C; #line 1999 "Ops.pm" #line 662 "ops.pd" # This is to used warn if an operand is non-numeric or non-PDL. sub warn_non_numeric_op_wrapper { require Scalar::Util; my ($cb, $op_name) = @_; return sub { my ($op1, $op2) = @_; warn "'$op2' is not numeric nor a PDL in operator $op_name" unless Scalar::Util::looks_like_number($op2) || ( Scalar::Util::blessed($op2) && $op2->isa('PDL') ); $cb->(@_); } } { package PDL; use Carp; use overload %OVERLOADS, "eq" => PDL::Ops::warn_non_numeric_op_wrapper(\&PDL::eq, 'eq'), "=" => sub {$_[0]}, # Don't deep copy, just copy reference ".=" => sub { my @args = !$_[2] ? @_[1,0] : @_[0,1]; PDL::Ops::assgn(@args); return $args[1]; }, 'bool' => sub { return 0 if $_[0]->isnull; confess("multielement ndarray in conditional expression (see PDL::FAQ questions 6-10 and 6-11)") unless $_[0]->nelem == 1; $_[0]->clump(-1)->at(0); }, '++' => sub { $_[0] += 1 }, '--' => sub { $_[0] -= 1 }, ; } #line 2037 "Ops.pm" #line 50 "ops.pd" =head1 AUTHOR Tuomas J. Lukka (lukka@fas.harvard.edu), Karl Glazebrook (kgb@aaoepp.aao.gov.au), Doug Hunt (dhunt@ucar.edu), Christian Soeller (c.soeller@auckland.ac.nz), Doug Burke (burke@ifa.hawaii.edu), and Craig DeForest (deforest@boulder.swri.edu). =cut #line 2055 "Ops.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/MatrixOps.pm0000644000175000017500000011521614200406304016273 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::MatrixOps; our @EXPORT_OK = qw(identity stretcher inv det determinant eigens_sym eigens svd lu_decomp lu_decomp2 lu_backsub simq squaretotri ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::MatrixOps ; #line 9 "matrixops.pd" use strict; use warnings; =head1 NAME PDL::MatrixOps -- Some Useful Matrix Operations =head1 SYNOPSIS $inv = $x->inv; $det = $x->det; ($lu,$perm,$par) = $x->lu_decomp; $y = lu_backsub($lu,$perm,$z); # solve $x x $y = $z =head1 DESCRIPTION PDL::MatrixOps is PDL's built-in matrix manipulation code. It contains utilities for many common matrix operations: inversion, determinant finding, eigenvalue/vector finding, singular value decomposition, etc. PDL::MatrixOps routines are written in a mixture of Perl and C, so that they are reliably present even when there is no FORTRAN compiler or external library available (e.g. L or any of the PDL::GSL family of modules). Matrix manipulation, particularly with large matrices, is a challenging field and no one algorithm is suitable in all cases. The utilities here use general-purpose algorithms that work acceptably for many cases but might not scale well to very large or pathological (near-singular) matrices. Except as noted, the matrices are PDLs whose 0th dimension ranges over column and whose 1st dimension ranges over row. The matrices appear correctly when printed. These routines should work OK with L objects as well as with normal PDLs. =head1 TIPS ON MATRIX OPERATIONS Like most computer languages, PDL addresses matrices in (column,row) order in most cases; this corresponds to (X,Y) coordinates in the matrix itself, counting rightwards and downwards from the upper left corner. This means that if you print a PDL that contains a matrix, the matrix appears correctly on the screen, but if you index a matrix element, you use the indices in the reverse order that you would in a math textbook. If you prefer your matrices indexed in (row, column) order, you can try using the L object, which includes an implicit exchange of the first two dimensions but should be compatible with most of these matrix operations. TIMTOWDTI.) Matrices, row vectors, and column vectors can be multiplied with the 'x' operator (which is, of course, threadable): $m3 = $m1 x $m2; $col_vec2 = $m1 x $col_vec1; $row_vec2 = $row_vec1 x $m1; $scalar = $row_vec x $col_vec; Because of the (column,row) addressing order, 1-D PDLs are treated as _row_ vectors; if you want a _column_ vector you must add a dummy dimension: $rowvec = pdl(1,2); # row vector $colvec = $rowvec->slice('*1'); # 1x2 column vector $matrix = pdl([[3,4],[6,2]]); # 2x2 matrix $rowvec2 = $rowvec x $matrix; # right-multiplication by matrix $colvec = $matrix x $colvec; # left-multiplication by matrix $m2 = $matrix x $rowvec; # Throws an error Implicit threading works correctly with most matrix operations, but you must be extra careful that you understand the dimensionality. In particular, matrix multiplication and other matrix ops need nx1 PDLs as row vectors and 1xn PDLs as column vectors. In most cases you must explicitly include the trailing 'x1' dimension in order to get the expected results when you thread over multiple row vectors. When threading over matrices, it's very easy to get confused about which dimension goes where. It is useful to include comments with every expression, explaining what you think each dimension means: $x = xvals(360)*3.14159/180; # (angle) $rot = cat(cat(cos($x),sin($x)), # rotmat: (col,row,angle) cat(-sin($x),cos($x))); =head1 ACKNOWLEDGEMENTS MatrixOps includes algorithms and pre-existing code from several origins. In particular, C is the work of Stephen Moshier, C uses an SVD subroutine written by Bryant Marks, and C uses a subset of the Small Scientific Library by Kenneth Geisshirt. They are free software, distributable under same terms as PDL itself. =head1 NOTES This is intended as a general-purpose linear algebra package for small-to-mid sized matrices. The algorithms may not scale well to large matrices (hundreds by hundreds) or to near singular matrices. If there is something you want that is not here, please add and document it! =cut use Carp; use strict; #line 133 "MatrixOps.pm" =head1 FUNCTIONS =cut #line 124 "matrixops.pd" =head2 identity =for sig Signature: (n; [o]a(n,n)) =for ref Return an identity matrix of the specified size. If you hand in a scalar, its value is the size of the identity matrix; if you hand in a dimensioned PDL, the 0th dimension is the first two dimensions of the matrix, with higher dimensions preserved. =cut sub identity { my $n = shift; my $out = !UNIVERSAL::isa($n,'PDL') ? zeroes($n,$n) : $n->getndims == 0 ? zeroes($n->at(0),$n->at(0)) : undef; if (!defined $out) { my @dims = $n->dims; $out = zeroes(@dims[0, 0, 2..$#dims]); } (my $tmp = $out->diagonal(0,1))++; # work around perl -d "feature" $out; } #line 176 "MatrixOps.pm" #line 157 "matrixops.pd" =head2 stretcher =for sig Signature: (a(n); [o]b(n,n)) =for usage $mat = stretcher($eigenvalues); =for ref Return a diagonal matrix with the specified diagonal elements =cut sub stretcher { my $in = shift; my $out = zeroes($in->dim(0),$in->dims); my $tmp; # work around for perl -d "feature" ($tmp = $out->diagonal(0,1)) += $in; $out; } #line 205 "MatrixOps.pm" #line 188 "matrixops.pd" =head2 inv =for sig Signature: (a(m,m); sv opt ) =for usage $a1 = inv($a, {$opt}); =for ref Invert a square matrix. You feed in an NxN matrix in $a, and get back its inverse (if it exists). The code is inplace-aware, so you can get back the inverse in $a itself if you want -- though temporary storage is used either way. You can cache the LU decomposition in an output option variable. C uses C by default; that is a numerically stable (pivoting) LU decomposition method. OPTIONS: =over 3 =item * s Boolean value indicating whether to complain if the matrix is singular. If this is false, singular matrices cause inverse to barf. If it is true, then singular matrices cause inverse to return undef. =item * lu (I/O) This value contains a list ref with the LU decomposition, permutation, and parity values for C<$a>. If you do not mention the key, or if the value is undef, then inverse calls C. If the key exists with an undef value, then the output of C is stashed here (unless the matrix is singular). If the value exists, then it is assumed to hold the LU decomposition. =item * det (Output) If this key exists, then the determinant of C<$a> get stored here, whether or not the matrix is singular. =back =cut *PDL::inv = \&inv; sub inv { my $x = shift; my $opt = shift; $opt = {} unless defined($opt); barf "inverse needs a square PDL as a matrix\n" unless(UNIVERSAL::isa($x,'PDL') && $x->dims >= 2 && $x->dim(0) == $x->dim(1) ); my ($lu,$perm,$par); if(exists($opt->{lu}) && ref $opt->{lu} eq 'ARRAY' && ref $opt->{lu}->[0] eq 'PDL') { ($lu,$perm,$par) = @{$opt->{lu}}; } else { ($lu,$perm,$par) = lu_decomp($x); @{$opt->{lu}} = ($lu,$perm,$par) if(ref $opt->{lu} eq 'ARRAY'); } my $det = (defined $lu) ? $lu->diagonal(0,1)->prodover * $par : pdl(0); $opt->{det} = $det if exists($opt->{det}); unless($det->nelem > 1 || $det) { return undef if $opt->{s}; barf("PDL::inv: got a singular matrix or LU decomposition\n"); } my $out = lu_backsub($lu,$perm,$par,identity($x))->transpose->sever; return $out unless($x->is_inplace); $x .= $out; $x; } #line 304 "MatrixOps.pm" #line 289 "matrixops.pd" =head2 det =for sig Signature: (a(m,m); sv opt) =for usage $det = det($a,{opt}); =for ref Determinant of a square matrix using LU decomposition (for large matrices) You feed in a square matrix, you get back the determinant. Some options exist that allow you to cache the LU decomposition of the matrix (note that the LU decomposition is invalid if the determinant is zero!). The LU decomposition is cacheable, in case you want to re-use it. This method of determinant finding is more rapid than recursive-descent on large matrices, and if you reuse the LU decomposition it's essentially free. OPTIONS: =over 3 =item * lu (I/O) Provides a cache for the LU decomposition of the matrix. If you provide the key but leave the value undefined, then the LU decomposition goes in here; if you put an LU decomposition here, it will be used and the matrix will not be decomposed again. =back =cut *PDL::det = \&det; sub det { my($x) = shift; my($opt) = shift; $opt = {} unless defined($opt); my($lu,$perm,$par); if(exists ($opt->{lu}) and (ref $opt->{lu} eq 'ARRAY')) { ($lu,$perm,$par) = @{$opt->{lu}}; } else { ($lu,$perm,$par) = lu_decomp($x); $opt->{lu} = [$lu,$perm,$par] if(exists($opt->{lu})); } ( (defined $lu) ? $lu->diagonal(0,1)->prodover * $par : 0 ); } #line 364 "MatrixOps.pm" #line 351 "matrixops.pd" =head2 determinant =for sig Signature: (a(m,m)) =for usage $det = determinant($x); =for ref Determinant of a square matrix, using recursive descent (threadable). This is the traditional, robust recursive determinant method taught in most linear algebra courses. It scales like C (and hence is pitifully slow for large matrices) but is very robust because no division is involved (hence no division-by-zero errors for singular matrices). It's also threadable, so you can find the determinants of a large collection of matrices all at once if you want. Matrices up to 3x3 are handled by direct multiplication; larger matrices are handled by recursive descent to the 3x3 case. The LU-decomposition method L is faster in isolation for single matrices larger than about 4x4, and is much faster if you end up reusing the LU decomposition of C<$a> (NOTE: check performance and threading benchmarks with new code). =cut *PDL::determinant = \&determinant; sub determinant { my($x) = shift; my($n); return undef unless( UNIVERSAL::isa($x,'PDL') && $x->getndims >= 2 && ($n = $x->dim(0)) == $x->dim(1) ); return $x->clump(2) if($n==1); if($n==2) { my($y) = $x->clump(2); return $y->index(0)*$y->index(3) - $y->index(1)*$y->index(2); } if($n==3) { my($y) = $x->clump(2); my $y3 = $y->index(3); my $y4 = $y->index(4); my $y5 = $y->index(5); my $y6 = $y->index(6); my $y7 = $y->index(7); my $y8 = $y->index(8); return ( $y->index(0) * ( $y4 * $y8 - $y5 * $y7 ) + $y->index(1) * ( $y5 * $y6 - $y3 * $y8 ) + $y->index(2) * ( $y3 * $y7 - $y4 * $y6 ) ); } my($i); my($sum) = zeroes($x->slice('(0),(0)')); # Do middle submatrices for $i(1..$n-2) { my $el = $x->slice("($i),(0)"); next if( ($el==0)->all ); # Optimize away unnecessary recursion $sum += $el * (1-2*($i%2)) * determinant($x->slice("0:".($i-1).",1:-1")-> append($x->slice(($i+1).":-1,1:-1"))); } # Do beginning and end submatrices $sum += $x->slice("(0),(0)") * determinant($x->slice('1:-1,1:-1')); $sum -= $x->slice("(-1),(0)") * determinant($x->slice('0:-2,1:-1')) * (1 - 2*($n % 2)); return $sum; } #line 451 "MatrixOps.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 eigens_sym =for sig Signature: ([phys]a(m); [o,phys]ev(n,n); [o,phys]e(n)) =for ref Eigenvalues and -vectors of a symmetric square matrix. If passed an asymmetric matrix, the routine will warn and symmetrize it, by taking the average value. That is, it will solve for 0.5*($a+$a->transpose). It's threadable, so if C<$a> is 3x3x100, it's treated as 100 separate 3x3 matrices, and both C<$ev> and C<$e> get extra dimensions accordingly. If called in scalar context it hands back only the eigenvalues. Ultimately, it should switch to a faster algorithm in this case (as discarding the eigenvectors is wasteful). The algorithm used is due to J. vonNeumann, which was a rediscovery of L . The eigenvectors are returned in COLUMNS of the returned PDL. That makes it slightly easier to access individual eigenvectors, since the 0th dim of the output PDL runs across the eigenvectors and the 1st dim runs across their components. ($ev,$e) = eigens_sym $x; # Make eigenvector matrix $vector = $ev->slice($n); # Select nth eigenvector as a column-vector $vector = $ev->slice("($n)"); # Select nth eigenvector as a row-vector =for usage ($ev, $e) = eigens_sym($x); # e-vects & e-values $e = eigens_sym($x); # just eigenvalues =for bad eigens_sym ignores the bad-value flag of the input ndarrays. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 504 "MatrixOps.pm" #line 1060 "../../blib/lib/PDL/PP.pm" sub PDL::eigens_sym { my ($x) = @_; my (@d) = $x->dims; barf "Need real square matrix for eigens_sym" if $#d < 1 or $d[0] != $d[1]; my ($n) = $d[0]; my ($sym) = 0.5*($x + $x->transpose); my ($err) = PDL::max(abs($sym)); barf "Need symmetric component non-zero for eigens_sym" if $err == 0; $err = PDL::max(abs($x-$sym))/$err; warn "Using symmetrized version of the matrix in eigens_sym" if $err > 1e-5 && $PDL::debug; ## Get lower diagonal form ## Use whichND/indexND because whereND doesn't exist (yet?) and ## the combo is threadable (unlike where). Note that for historical ## reasons whichND needs a scalar() around it to give back a ## nice 2xn PDL index. my $lt = PDL::indexND($sym, scalar(PDL::whichND(PDL->xvals($n,$n) <= PDL->yvals($n,$n))) )->copy; my $ev = PDL->zeroes($sym->dims); my $e = PDL->zeroes($sym->index(0)->dims); &PDL::_eigens_sym_int($lt, $ev, $e); return $ev->transpose, $e if(wantarray); $e; #just eigenvalues } #line 542 "MatrixOps.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *eigens_sym = \&PDL::eigens_sym; #line 548 "MatrixOps.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 eigens =for sig Signature: ([phys]a(m); [o,phys]ev(l,n,n); [o,phys]e(l,n)) =for ref Real eigenvalues and -vectors of a real square matrix. (See also L<"eigens_sym"|/eigens_sym>, for eigenvalues and -vectors of a real, symmetric, square matrix). The eigens function will attempt to compute the eigenvalues and eigenvectors of a square matrix with real components. If the matrix is symmetric, the same underlying code as L<"eigens_sym"|/eigens_sym> is used. If asymmetric, the eigenvalues and eigenvectors are computed with algorithms from the sslib library. If any imaginary components exist in the eigenvalues, the results are currently considered to be invalid, and such eigenvalues are returned as "NaN"s. This is true for eigenvectors also. That is if there are imaginary components to any of the values in the eigenvector, the eigenvalue and corresponding eigenvectors are all set to "NaN". Finally, if there are any repeated eigenvectors, they are replaced with all "NaN"s. Use of the eigens function on asymmetric matrices should be considered experimental! For asymmetric matrices, nearly all observed matrices with real eigenvalues produce incorrect results, due to errors of the sslib algorithm. If your assymmetric matrix returns all NaNs, do not assume that the values are complex. Also, problems with memory access is known in this library. Not all square matrices are diagonalizable. If you feed in a non-diagonalizable matrix, then one or more of the eigenvectors will be set to NaN, along with the corresponding eigenvalues. C is threadable, so you can solve 100 eigenproblems by feeding in a 3x3x100 array. Both C<$ev> and C<$e> get extra dimensions accordingly. If called in scalar context C hands back only the eigenvalues. This is somewhat wasteful, as it calculates the eigenvectors anyway. The eigenvectors are returned in COLUMNS of the returned PDL (ie the the 0 dimension). That makes it slightly easier to access individual eigenvectors, since the 0th dim of the output PDL runs across the eigenvectors and the 1st dim runs across their components. ($ev,$e) = eigens $x; # Make eigenvector matrix $vector = $ev->slice($n); # Select nth eigenvector as a column-vector $vector = $ev->slice("($n)"); # Select nth eigenvector as a row-vector DEVEL NOTES: For now, there is no distinction between a complex eigenvalue and an invalid eigenvalue, although the underlying code generates complex numbers. It might be useful to be able to return complex eigenvalues. =for usage ($ev, $e) = eigens($x); # e'vects & e'vals $e = eigens($x); # just eigenvalues =for bad eigens ignores the bad-value flag of the input ndarrays. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 627 "MatrixOps.pm" #line 1060 "../../blib/lib/PDL/PP.pm" sub PDL::eigens { my ($x) = @_; my (@d) = $x->dims; my $n = $d[0]; barf "Need real square matrix for eigens" if $#d < 1 or $d[0] != $d[1]; my $deviation = PDL::max(abs($x - $x->transpose))/PDL::max(abs($x)); if ( $deviation <= 1e-5 ) { #taken from eigens_sym code my $lt = PDL::indexND($x, scalar(PDL::whichND(PDL->xvals($n,$n) <= PDL->yvals($n,$n))) )->copy; my $ev = PDL->zeroes($x->dims); my $e = PDL->zeroes($x->index(0)->dims); &PDL::_eigens_sym_int($lt, $ev, $e); return $ev->transpose, $e if wantarray; return $e; #just eigenvalues } else { if($PDL::verbose || $PDL::debug) { print "eigens: using the asymmetric case from SSL\n"; } if( !$PDL::eigens_bug_ack && !$ENV{PDL_EIGENS_ACK} ) { print STDERR "WARNING: using sketchy algorithm for PDL::eigens asymmetric case -- you might\n". " miss an eigenvector or two\nThis should be fixed in PDL v2.5 (due 2009), \n". " or you might fix it yourself (hint hint). You can shut off this warning\n". " by setting the variable $PDL::eigens_bug_ack, or the environment variable\n". " PDL_EIGENS_HACK prior to calling eigens() with a non-symmetric matrix.\n"; $PDL::eigens_bug_ack = 1; } my $ev = PDL->zeroes(2, $x->dims); my $e = PDL->zeroes(2, $x->index(0)->dims); &PDL::_eigens_int($x->clump(0,1), $ev, $e); return $ev->index(0)->transpose->sever, $e->index(0)->sever if(wantarray); return $e->index(0)->sever; #just eigenvalues } } #line 678 "MatrixOps.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *eigens = \&PDL::eigens; #line 684 "MatrixOps.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 svd =for sig Signature: (a(n,m); [o]u(n,m); [o,phys]z(n); [o]v(n,n)) =for usage ($u, $s, $v) = svd($x); =for ref Singular value decomposition of a matrix. C is threadable. Given an m x n matrix C<$a> that has m rows and n columns (m >= n), C computes matrices C<$u> and C<$v>, and a vector of the singular values C<$s>. Like most implementations, C computes what is commonly referred to as the "thin SVD" of C<$a>, such that C<$u> is m x n, C<$v> is n x n, and there are <=n singular values. As long as m >= n, the original matrix can be reconstructed as follows: ($u,$s,$v) = svd($x); $ess = zeroes($x->dim(0),$x->dim(0)); $ess->slice("$_","$_").=$s->slice("$_") foreach (0..$x->dim(0)-1); #generic diagonal $a_copy = $u x $ess x $v->transpose; If m==n, C<$u> and C<$v> can be thought of as rotation matrices that convert from the original matrix's singular coordinates to final coordinates, and from original coordinates to singular coordinates, respectively, and $ess is a diagonal scaling matrix. If n>m, C will barf. This can be avoided by passing in the transpose of C<$a>, and reconstructing the original matrix like so: ($u,$s,$v) = svd($x->transpose); $ess = zeroes($x->dim(1),$x->dim(1)); $ess->slice($_,$_).=$s->slice($_) foreach (0..$x->dim(1)-1); #generic diagonal $x_copy = $v x $ess x $u->transpose; EXAMPLE The computing literature has loads of examples of how to use SVD. Here's a trivial example (used in L) of how to make a matrix less, er, singular, without changing the orientation of the ellipsoid of transformation: { my($r1,$s,$r2) = svd $x; $s++; # fatten all singular values $r2 *= $s; # implicit threading for cheap mult. $x .= $r2 x $r1; # a gets r2 x ess x r1 } =for bad svd ignores the bad-value flag of the input ndarrays. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 755 "MatrixOps.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *svd = \&PDL::svd; #line 761 "MatrixOps.pm" #line 817 "matrixops.pd" =head2 lu_decomp =for sig Signature: (a(m,m); [o]lu(m,m); [o]perm(m); [o]parity) =for ref LU decompose a matrix, with row permutation =for usage ($lu, $perm, $parity) = lu_decomp($x); $lu = lu_decomp($x, $perm, $par); # $perm and $par are outputs! lu_decomp($x->inplace,$perm,$par); # Everything in place. =for description C returns an LU decomposition of a square matrix, using Crout's method with partial pivoting. It's ported from I. The partial pivoting keeps it numerically stable but means a little more overhead from threading. C decomposes the input matrix into matrices L and U such that LU = A, L is a subdiagonal matrix, and U is a superdiagonal matrix. By convention, the diagonal of L is all 1's. The single output matrix contains all the variable elements of both the L and U matrices, stacked together. Because the method uses pivoting (rearranging the lower part of the matrix for better numerical stability), you have to permute input vectors before applying the L and U matrices. The permutation is returned either in the second argument or, in list context, as the second element of the list. You need the permutation for the output to make any sense, so be sure to get it one way or the other. LU decomposition is the answer to a lot of matrix questions, including inversion and determinant-finding, and C is used by L. If you pass in C<$perm> and C<$parity>, they either must be predeclared PDLs of the correct size ($perm is an n-vector, C<$parity> is a scalar) or scalars. If the matrix is singular, then the LU decomposition might not be defined; in those cases, C silently returns undef. Some singular matrices LU-decompose just fine, and those are handled OK but give a zero determinant (and hence can't be inverted). C uses pivoting, which rearranges the values in the matrix for more numerical stability. This makes it really good for large and even near-singular matrices. There is a non-pivoting version C available which is from 5 to 60 percent faster for typical problems at the expense of failing to compute a result in some cases. Now that the C is threaded, it is the recommended LU decomposition routine. It no longer falls back to C. C is ported from I to PDL. It should probably be implemented in C. =cut *PDL::lu_decomp = \&lu_decomp; sub lu_decomp { my($in) = shift; my($permute) = shift; my($parity) = shift; my($sing_ok) = shift; my $TINY = 1e-30; barf("lu_decomp requires a square (2D) PDL\n") if(!UNIVERSAL::isa($in,'PDL') || $in->ndims < 2 || $in->dim(0) != $in->dim(1)); my($n) = $in->dim(0); my($n1) = $n; $n1--; my($inplace) = $in->is_inplace; my($out) = ($inplace) ? $in : $in->copy; if(defined $permute) { barf('lu_decomp: permutation vector must match the matrix') if(!UNIVERSAL::isa($permute,'PDL') || $permute->ndims != 1 || $permute->dim(0) != $out->dim(0)); $permute .= PDL->xvals($in->dim(0)); } else { $permute = $in->slice("(0)")->xvals; } if(defined $parity) { barf('lu_decomp: parity must be a scalar PDL') if(!UNIVERSAL::isa($parity,'PDL') || $parity->dim(0) != 1); $parity .= 1.0; } else { $parity = $in->slice('(0),(0)')->ones; } my($scales) = $in->copy->abs->maximum; # elementwise by rows if(($scales==0)->sum) { return undef; } # Some holding tanks my($tmprow) = $out->slice('(0)')->double->zeroes; my($tmpval) = $tmprow->slice('(0)')->sever; my($col,$row); for $col(0..$n1) { for $row(1..$n1) { my($klim) = $row<$col ? $row : $col; if($klim > 0) { $klim--; my($el) = $out->index2d($col,$row); $el -= ( $out->slice("($col),0:$klim") * $out->slice("0:$klim,($row)") )->sumover; } } # Figure a_ij, with pivoting if($col < $n1) { # Find the maximum value in the rest of the row my $sl = $out->slice("($col),$col:$n1"); my $wh = $sl->abs->maximum_ind; my $big = $sl->index($wh)->sever; # Permute if necessary to make the diagonal the maximum # if($wh != 0) { # Permute rows to place maximum element on diagonal. my $whc = $wh+$col; my $sl1 = $out->mv(1,0)->index($whc->slice("*$n")); my $sl2 = $out->slice(":,($col)"); $tmprow .= $sl1; $sl1 .= $sl2; $sl2 .= $tmprow; $sl1 = $permute->index($whc); $sl2 = $permute->index($col); $tmpval .= $sl1; $sl1 .= $sl2; $sl2 .= $tmpval; { my $tmp; ($tmp = $parity->where($wh>0)) *= -1.0; } } # Sidestep near-singularity (NR does this; not sure if it is helpful) my $notbig = $big->where(abs($big) < $TINY); $notbig .= $TINY * (1.0 - 2.0*($notbig < 0)); # Divide by the diagonal element (which is now the largest element) my $tout; ($tout = $out->slice("($col),".($col+1).":$n1")) /= $big->slice('*1'); } # end of pivoting part } # end of column loop if(wantarray) { return ($out,$permute,$parity); } $out; } #line 943 "MatrixOps.pm" #line 1000 "matrixops.pd" =head2 lu_decomp2 =for sig Signature: (a(m,m); [o]lu(m,m)) =for ref LU decompose a matrix, with no row permutation =for usage ($lu, $perm, $parity) = lu_decomp2($x); $lu = lu_decomp2($x,$perm,$parity); # or $lu = lu_decomp2($x); # $perm and $parity are optional lu_decomp($x->inplace,$perm,$parity); # or lu_decomp($x->inplace); # $perm and $parity are optional =for description C works just like L, but it does B pivoting at all. For compatibility with L, it will give you a permutation list and a parity scalar if you ask for them -- but they are always trivial. Because C does not pivot, it is numerically B -- that means it is less precise than L, particularly for large or near-singular matrices. There are also specific types of non-singular matrices that confuse it (e.g. ([0,-1,0],[1,0,0],[0,0,1]), which is a 90 degree rotation matrix but which confuses C). On the other hand, if you want to invert rapidly a few hundred thousand small matrices and don't mind missing one or two, it could be the ticket. It can be up to 60% faster at the expense of possible failure of the decomposition for some of the input matrices. The output is a single matrix that contains the LU decomposition of C<$a>; you can even do it in-place, thereby destroying C<$a>, if you want. See L for more information about LU decomposition. C is ported from I into PDL. =cut *PDL::lu_decomp2 = \&lu_decomp2; sub lu_decomp2 { my($in) = shift; my($perm) = shift; my($par) = shift; my($sing_ok) = shift; my $TINY = 1e-30; barf("lu_decomp2 requires a square (2D) PDL\n") if(!UNIVERSAL::isa($in,'PDL') || $in->ndims < 2 || $in->dim(0) != $in->dim(1)); my($n) = $in->dim(0); my($n1) = $n; $n1--; my($inplace) = $in->is_inplace; my($out) = ($inplace) ? $in : $in->copy; if(defined $perm) { barf('lu_decomp2: permutation vector must match the matrix') if(!UNIVERSAL::isa($perm,'PDL') || $perm->ndims != 1 || $perm->dim(0) != $out->dim(0)); $perm .= PDL->xvals($in->dim(0)); } else { $perm = PDL->xvals($in->dim(0)); } if(defined $par) { barf('lu_decomp: parity must be a scalar PDL') if(!UNIVERSAL::isa($par,'PDL') || $par->nelem != 1); $par .= 1.0; } else { $par = pdl(1.0); } my $diagonal = $out->diagonal(0,1); my($col,$row); for $col(0..$n1) { for $row(1..$n1) { my($klim) = $row<$col ? $row : $col; if($klim > 0) { $klim--; my($el) = $out->index2d($col,$row); $el -= ( $out->slice("($col),0:$klim") * $out->slice("0:$klim,($row)") )->sumover; } } # Figure a_ij, with no pivoting if($col < $n1) { # Divide the rest of the column by the diagonal element my $tmp; # work around for perl -d "feature" ($tmp = $out->slice("($col),".($col+1).":$n1")) /= $diagonal->index($col)->dummy(0,$n1-$col); } } # end of column loop if(wantarray) { return ($out,$perm,$par); } $out; } #line 1067 "MatrixOps.pm" #line 1125 "matrixops.pd" =head2 lu_backsub =for sig Signature: (lu(m,m); perm(m); b(m)) =for ref Solve A x = B for matrix A, by back substitution into A's LU decomposition. =for usage ($lu,$perm,$par) = lu_decomp($A); $x = lu_backsub($lu,$perm,$par,$A); # or $x = lu_backsub($lu,$perm,$B); # $par is not required for lu_backsub lu_backsub($lu,$perm,$B->inplace); # modify $B in-place $x = lu_backsub(lu_decomp($A),$B); # (ignores parity value from lu_decomp) # starting from square matrix A and columns matrix B, with mathematically # correct dimensions $A = identity(4) + ones(4, 4); $A->slice('2,0') .= 0; # break symmetry to see if need transpose $B = sequence(2, 4); # all these functions take B as rows, interpret as though notional columns # mathematically confusing but can't change as back-compat and also # familiar to Fortran users, so just transpose inputs and outputs # using lu_backsub ($lu,$perm,$par) = lu_decomp($A); $x = lu_backsub($lu,$perm,$par, $B->transpose)->transpose; # or with Slatec LINPACK use PDL::Slatec; gefa($lu=$A->copy, $ipiv=null, $info=null); # 1 = do transpose because Fortran's idea of rows vs columns gesl($lu, $ipiv, $x=$B->transpose->copy, 1); $x = $x->inplace->transpose; # or with LAPACK use PDL::LinearAlgebra::Real; getrf($lu=$A->copy, $ipiv=null, $info=null); getrs($lu, 1, $x=$B->transpose->copy, $ipiv, $info=null); # again, need transpose $x=$x->inplace->transpose; # or with GSL use PDL::GSL::LINALG; LU_decomp(my $lu=$A->copy, my $p=null, my $signum=null); # $B and $x, first dim is because GSL treats as vector, higher dims thread # so we transpose in and back out LU_solve($lu, $p, $B->transpose, my $x=null); $x=$x->inplace->transpose; # proof of the pudding is in the eating: print $A x $x; =for description Given the LU decomposition of a square matrix (from L), C does back substitution into the matrix to solve C for given vector C. It is separated from the C method so that you can call the cheap C multiple times and not have to do the expensive LU decomposition more than once. C acts on single vectors and threads in the usual way, which means that it treats C<$y> as the I of the input. If you want to process a matrix, you must hand in the I of the matrix, and then transpose the output when you get it back. that is because pdls are indexed by (col,row), and matrices are (row,column) by convention, so a 1-D pdl corresponds to a row vector, not a column vector. If C<$lu> is dense and you have more than a few points to solve for, it is probably cheaper to find C with L, and just multiply C.) in fact, L works by calling C with the identity matrix. C is ported from section 2.3 of I. It is written in PDL but should probably be implemented in C. =cut *PDL::lu_backsub = \&lu_backsub; sub lu_backsub { my ($lu, $perm, $y, $par); print STDERR "lu_backsub: entering debug version...\n" if $PDL::debug; if(@_==3) { ($lu, $perm, $y) = @_; } elsif(@_==4) { ($lu, $perm, $par, $y) = @_; } barf("lu_backsub: LU decomposition is undef -- probably from a singular matrix.\n") unless defined($lu); barf("Usage: \$x = lu_backsub(\$lu,\$perm,\$y); all must be PDLs\n") unless(UNIVERSAL::isa($lu,'PDL') && UNIVERSAL::isa($perm,'PDL') && UNIVERSAL::isa($y,'PDL')); my $n = $y->dim(0); my $n1 = $n; $n1--; # Make sure threading dimensions are compatible. # There are two possible sources of thread dims: # # (1) over multiple LU (i.e., $lu,$perm) instances # (2) over multiple B (i.e., $y) column instances # # The full dimensions of the function call looks like # # lu_backsub( lu(m,m,X), perm(m,X), b(m,Y) ) # # where X is the list of extra LU dims and Y is # the list of extra B dims. We have several possible # cases: # # (1) Check that m dims are compatible my $ludims = pdl($lu->dims); my $permdims = pdl($perm->dims); my $bdims = pdl($y->dims); print STDERR "lu_backsub: called with args: \$lu$ludims, \$perm$permdims, \$y$bdims\n" if $PDL::debug; my $m = $ludims->slice("(0)"); # this is the sig dimension unless ( ($ludims->slice(0) == $m) and ($ludims->slice(1) == $m) and ($permdims->slice(0) == $m) and ($bdims->slice(0) == $m)) { barf "lu_backsub: mismatched sig dimensions"; } my $lunumthr = $ludims->dim(0)-2; my $permnumthr = $permdims->dim(0)-1; my $bnumthr = $bdims->dim(0)-1; unless ( ($lunumthr == $permnumthr) and ($ludims->slice("1:-1") == $permdims)->all ) { barf "lu_backsub: \$lu and \$perm thread dims not equal! \n"; } # (2) If X == Y then default threading is ok if ( ($bnumthr==$permnumthr) and ($bdims==$permdims)->all) { print STDERR "lu_backsub: have explicit thread dims, goto THREAD_OK\n" if $PDL::debug; goto THREAD_OK; } # (3) If X == (x,Y) then add x dummy to lu,perm # (4) If ndims(X) > ndims(Y) then must have #3 # (5) If ndims(X) < ndims(Y) then foreach # non-trivial leading dim in X (x0,x1,..) # insert dummy (x0,x1) into lu and perm # This means that threading occurs over all # leading non-trivial (not length 1) dims of # B unless all the thread dims are explicitly # matched to the LU dims. THREAD_OK: # Permute the vector and make a copy if necessary. my $out = $y->dummy(1,$y->dim(0))->index($perm->dummy(1)); $out = $out->sever if !$y->is_inplace; print STDERR "lu_backsub: starting with \$out" . pdl($out->dims) . "\n" if $PDL::debug; # Make sure threading over lu happens OK... if($out->ndims < $lu->ndims-1) { print STDERR "lu_backsub: adjusting dims for \$out" . pdl($out->dims) . "\n" if $PDL::debug; do { $out = $out->dummy(-1,$lu->dim($out->ndims+1)); } while($out->ndims < $lu->ndims-1); } ## Do forward substitution into L my $row; my $r1; for $row(1..$n1) { $r1 = $row-1; my $tmp; # work around perl -d "feature ($tmp = $out->index($row)) -= ($lu->slice("0:$r1,$row") * $out->slice("0:$r1") )->sumover; } ## Do backward substitution into U, and normalize by the diagonal my $ludiag = $lu->diagonal(0,1); { my $tmp; # work around for perl -d "feature" ($tmp = $out->index($n1)) /= $ludiag->index($n1)->dummy(0); # TODO: check threading } for ($row=$n1; $row>0; $row--) { $r1 = $row-1; my $tmp; # work around for perl -d "feature" ($tmp = $out->index($r1)) -= ($lu->slice("$row:$n1,$r1") * # TODO: check thread dims $out->slice("$row:$n1") )->sumover; ($tmp = $out->index($r1)) /= $ludiag->index($r1)->dummy(0); # TODO: check thread dims } if ($y->is_inplace) { $y->setdims([$out->dims]) if !PDL::all($y->shape == $out->shape); # assgn needs same shape $y .= $out; } $out; } #line 1284 "MatrixOps.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 simq =for sig Signature: ([phys]a(n,n); [phys]b(n); [o,phys]x(n); int [o,phys]ips(n); int flag) =for ref Solution of simultaneous linear equations, C. C<$a> is an C matrix (i.e., a vector of length C), stored row-wise: that is, C, where C. While this is the transpose of the normal column-wise storage, this corresponds to normal PDL usage. The contents of matrix a may be altered (but may be required for subsequent calls with flag = -1). C<$y>, C<$x>, C<$ips> are vectors of length C. Set C to solve. Set C to do a new back substitution for different C<$y> vector using the same a matrix previously reduced when C (the C<$ips> vector generated in the previous solution is also required). See also L, which does the same thing with a slightly less opaque interface. =for bad simq ignores the bad-value flag of the input ndarrays. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1329 "MatrixOps.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *simq = \&PDL::simq; #line 1335 "MatrixOps.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 squaretotri =for sig Signature: (a(n,n); b(m)) =for ref Convert a symmetric square matrix to triangular vector storage. =for bad squaretotri does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1362 "MatrixOps.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *squaretotri = \&PDL::squaretotri; #line 1368 "MatrixOps.pm" #line 1420 "matrixops.pd" =head1 AUTHOR Copyright (C) 2002 Craig DeForest (deforest@boulder.swri.edu), R.J.R. Williams (rjrw@ast.leeds.ac.uk), Karl Glazebrook (kgb@aaoepp.aao.gov.au). There is no warranty. You are allowed to redistribute and/or modify this work under the same conditions as PDL itself. If this file is separated from the PDL distribution, then the PDL copyright notice should be included in this file. =cut #line 1386 "MatrixOps.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/Slatec.pm0000644000175000017500000010230714200406317015561 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::Slatec; our @EXPORT_OK = qw(eigsys matinv polyfit polycoef polyvalue svdc poco geco gefa podi gedi gesl rs ezffti ezfftf ezfftb pcoef pvalue chim chic chsp chfd chfe chia chid chcm chbs polfit ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Slatec ; #line 6 "slatec.pd" use strict; use warnings; =head1 NAME PDL::Slatec - PDL interface to the slatec numerical programming library =head1 SYNOPSIS use PDL::Slatec; ($ndeg, $r, $ierr, $c) = polyfit($x, $y, $w, $maxdeg, $eps); =head1 DESCRIPTION This module serves the dual purpose of providing an interface to parts of the slatec library and showing how to interface PDL to an external library. Using this library requires a fortran compiler; the source for the routines is provided for convenience. Currently available are routines to: manipulate matrices; calculate FFT's; fit data using polynomials; and interpolate/integrate data using piecewise cubic Hermite interpolation. =head2 Piecewise cubic Hermite interpolation (PCHIP) PCHIP is the slatec package of routines to perform piecewise cubic Hermite interpolation of data. It features software to produce a monotone and "visually pleasing" interpolant to monotone data. According to Fritsch & Carlson ("Monotone piecewise cubic interpolation", SIAM Journal on Numerical Analysis 17, 2 (April 1980), pp. 238-246), such an interpolant may be more reasonable than a cubic spline if the data contains both "steep" and "flat" sections. Interpolation of cumulative probability distribution functions is another application. These routines are cryptically named (blame FORTRAN), beginning with 'ch', and accept either float or double ndarrays. Most of the routines require an integer parameter called C; if set to 0, then no checks on the validity of the input data are made, otherwise these checks are made. The value of C can be set to 0 if a routine such as L has already been successfully called. =over 4 =item * If not known, estimate derivative values for the points using the L, L, or L routines (the following routines require both the function (C) and derivative (C) values at a set of points (C)). =item * Evaluate, integrate, or differentiate the resulting PCH function using the routines: L; L; L; L. =item * If desired, you can check the monotonicity of your data using L. =back =cut #line 97 "Slatec.pm" =head1 FUNCTIONS =cut #line 92 "slatec.pd" =head2 eigsys =for ref Eigenvalues and eigenvectors of a real positive definite symmetric matrix. =for usage ($eigvals,$eigvecs) = eigsys($mat) Note: this function should be extended to calculate only eigenvalues if called in scalar context! =head2 matinv =for ref Inverse of a square matrix =for usage ($inv) = matinv($mat) =head2 polyfit Convenience wrapper routine about the C C function. Separates supplied arguments and return values. =for ref Fit discrete data in a least squares sense by polynomials in one variable. Handles threading correctly--one can pass in a 2D PDL (as C<$y>) and it will pass back a 2D PDL, the rows of which are the polynomial regression results (in C<$r> corresponding to the rows of $y. =for usage ($ndeg, $r, $ierr, $c, $coeffs, $rms) = polyfit($x, $y, $w, $maxdeg, [$eps]); $coeffs = polyfit($x,$y,$w,$maxdeg,[$eps]); where on input: C<$x> and C<$y> are the values to fit to a polynomial. C<$w> are weighting factors C<$maxdeg> is the maximum degree of polynomial to use and C<$eps> is the required degree of fit. and the output switches on list/scalar context. In list context: C<$ndeg> is the degree of polynomial actually used C<$r> is the values of the fitted polynomial C<$ierr> is a return status code, and C<$c> is some working array or other (preserved for historical purposes) C<$coeffs> is the polynomial coefficients of the best fit polynomial. C<$rms> is the rms error of the fit. In scalar context, only $coeffs is returned. Historically, C<$eps> was modified in-place to be a return value of the rms error. This usage is deprecated, and C<$eps> is an optional parameter now. It is still modified if present. C<$c> is a working array accessible to Slatec - you can feed it to several other Slatec routines to get nice things out. It does not thread correctly and should probably be fixed by someone. If you are reading this, that someone might be you. =for bad This version of polyfit handles bad values correctly. Bad values in $y are ignored for the fit and give computed values on the fitted curve in the return. Bad values in $x or $w are ignored for the fit and result in bad elements in the output. =head2 polycoef Convenience wrapper routine around the C C function. Separates supplied arguments and return values. =for ref Convert the C/C coefficients to Taylor series form. =for usage $tc = polycoef($l, $c, $x); =head2 polyvalue Convenience wrapper routine around the C C function. Separates supplied arguments and return values. For multiple input x positions, a corresponding y position is calculated. The derivatives PDL is one dimensional (of size C) if a single x position is supplied, two dimensional if more than one x position is supplied. =for ref Use the coefficients C generated by C (or C) to evaluate the polynomial fit of degree C, along with the first C of its derivatives, at a specified point C. =for usage ($yfit, $yp) = polyvalue($l, $nder, $x, $c); =head2 detslatec =for ref compute the determinant of an invertible matrix =for example $mat = zeroes(5,5); $mat->diagonal(0,1) .= 1; # unity matrix $det = detslatec $mat; Usage: =for usage $determinant = detslatec $matrix; =for sig Signature: detslatec(mat(n,m); [o] det()) C computes the determinant of an invertible matrix and barfs if the matrix argument provided is non-invertible. The matrix threads as usual. This routine was previously known as C which clashes now with L which is provided by L. =head2 fft =for ref Fast Fourier Transform =for example $v_in = pdl(1,0,1,0); ($azero,$x,$y) = PDL::Slatec::fft($v_in); C is a convenience wrapper for L, and performs a Fast Fourier Transform on an input vector C<$v_in>. The return values are the same as for L. =head2 rfft =for ref reverse Fast Fourier Transform =for example $v_out = PDL::Slatec::rfft($azero,$x,$y); print $v_in, $vout [1 0 1 0] [1 0 1 0] C is a convenience wrapper for L, and performs a reverse Fast Fourier Transform. The input is the same as the output of L, and the output of C is a data vector, similar to what is input into L. =cut #line 284 "Slatec.pm" #line 424 "slatec.pd" use PDL::Core; use PDL::Basic; use PDL::Primitive; use PDL::Ufunc; use strict; # Note: handles only real symmetric positive-definite. *eigsys = \&PDL::eigsys; sub PDL::eigsys { my($h) = @_; $h = float($h); rs($h, my $eigval=PDL->null, 1,my $eigmat=PDL->null, my $errflag=PDL->null ); # print $covar,$eigval,$eigmat,$fvone,$fvtwo,$errflag; if(sum($errflag) > 0) { barf("Non-positive-definite matrix given to eigsys: $h\n"); } return ($eigval,$eigmat); } *matinv = \&PDL::matinv; sub PDL::matinv { my($m) = @_; my(@dims) = $m->dims; # Keep from dumping core (FORTRAN does no error checking) barf("matinv requires a 2-D square matrix") unless( @dims >= 2 && $dims[0] == $dims[1] ); $m = $m->copy(); # Make sure we don't overwrite :( gefa($m,(my $ipvt=null),(my $info=null)); if(sum($info) > 0) { barf("Uninvertible matrix given to inv: $m\n"); } gedi($m,$ipvt,pdl(0,0),null,1); $m; } *detslatec = \&PDL::detslatec; sub PDL::detslatec { my($m) = @_; $m = $m->copy(); # Make sure we don't overwrite :( gefa($m,(my $ipvt=null),(my $info=null)); if(sum($info) > 0) { barf("Uninvertible matrix given to inv: $m\n"); } gedi($m,$ipvt,my $det=null,null,10); return $det->slice('(0)')*10**$det->slice('(1)'); } sub prepfft { my($n) = @_; my $tmp = PDL->zeroes(float(),$n*3+15); $n = pdl $n; ezffti($n,$tmp); return $tmp; } sub fft (;@) { my($v) = @_; my $ws = prepfft($v->getdim(0)); ezfftf($v,(my $az = PDL->null), (my $x = PDL->null), (my $y = PDL->null), $ws); return ($az,$x,$y); } sub rfft { my($az,$x,$y) = @_; my $ws = prepfft($x->getdim(0)); my $v = $x->copy(); ezfftb($v,$az,$x,$y,$ws); return $v; } # polynomial fitting routines # simple wrappers around the SLATEC implementations *polyfit = \&PDL::polyfit; sub PDL::polyfit { barf 'Usage: polyfit($x, $y, $w, $maxdeg, [$eps]);' unless (@_ == 5 || @_==4 ); my ($x_in, $y_in, $w_in, $maxdeg_in, $eps_in) = @_; # if $w_in does not match the data vectors ($x_in, $y_in), then we can resize # it to match the size of $y_in : $w_in = $w_in + $y_in->zeros; # Create the output arrays my $r = PDL->null; # A array needs some work space my $sz = ((3 * $x_in->getdim(0)) + (3*$maxdeg_in) + 3); # Buffer size called for by Slatec my @otherdims = $_[0]->dims; shift @otherdims; # Thread dims my $a1 = PDL->new_from_specification($x_in->type,$sz,@otherdims); my $coeffs = PDL->new_from_specification($x_in->type, $maxdeg_in + 1, @otherdims); my $ierr = PDL->null; my $ndeg = PDL->null; # Now call polfit my $rms = pdl($eps_in); polfit($x_in, $y_in, $w_in, $maxdeg_in, $ndeg, $rms, $r, $ierr, $a1, $coeffs); # Preserve historic compatibility by flowing rms error back into the argument if( UNIVERSAL::isa($eps_in,'PDL') ){ $eps_in .= $rms; } # Return the arrays if(wantarray) { return ($ndeg, $r, $ierr, $a1, $coeffs, $rms ); } else { return $coeffs; } } *polycoef = \&PDL::polycoef; sub PDL::polycoef { barf 'Usage: polycoef($l, $c, $x);' unless @_ == 3; # Allocate memory for return PDL # Simply l + 1 but cant see how to get PP to do this - TJ # Not sure the return type since I do not know # where PP will get the information from my $tc = PDL->zeroes( abs($_[0]) + 1 ); # Run the slatec routine pcoef($_[0], $_[1], $tc, $_[2]); # Return results return $tc; } *polyvalue = \&PDL::polyvalue; sub PDL::polyvalue { barf 'Usage: polyvalue($l, $nder, $x, $c);' unless @_ == 4; # Two output arrays my $yfit = PDL->null; # This one must be preallocated and must take into account # the size of $x if greater than 1 my $yp; if ($_[2]->getdim(0) == 1) { $yp = $_[2]->zeroes($_[1]); } else { $yp = $_[2]->zeroes($_[1], $_[2]->getdim(0)); } # Run the slatec function pvalue($_[0], $_[2], $yfit, $yp, $_[3]); # Returns return ($yfit, $yp); } #line 458 "Slatec.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 svdc =for sig Signature: (x(n,p);[o]s(p);[o]e(p);[o]u(n,p);[o]v(p,p);[o]work(n);longlong job();longlong [o]info()) =for ref singular value decomposition of a matrix =for bad svdc does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 482 "Slatec.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *svdc = \&PDL::svdc; #line 488 "Slatec.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 poco =for sig Signature: (a(n,n);rcond();[o]z(n);longlong [o]info()) Factor a real symmetric positive definite matrix and estimate the condition number of the matrix. =for bad poco does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 511 "Slatec.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *poco = \&PDL::poco; #line 517 "Slatec.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 geco =for sig Signature: (a(n,n);longlong [o]ipvt(n);[o]rcond();[o]z(n)) Factor a matrix using Gaussian elimination and estimate the condition number of the matrix. =for bad geco does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 540 "Slatec.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *geco = \&PDL::geco; #line 546 "Slatec.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 gefa =for sig Signature: (a(n,n);longlong [o]ipvt(n);longlong [o]info()) =for ref Factor a matrix using Gaussian elimination. =for bad gefa does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 570 "Slatec.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *gefa = \&PDL::gefa; #line 576 "Slatec.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 podi =for sig Signature: (a(n,n);[o]det(two=2);longlong job()) Compute the determinant and inverse of a certain real symmetric positive definite matrix using the factors computed by L. =for bad podi does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 600 "Slatec.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *podi = \&PDL::podi; #line 606 "Slatec.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 gedi =for sig Signature: (a(n,n);longlong [o]ipvt(n);[o]det(two=2);[o]work(n);longlong job()) Compute the determinant and inverse of a matrix using the factors computed by L or L. =for bad gedi does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 629 "Slatec.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *gedi = \&PDL::gedi; #line 635 "Slatec.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 gesl =for sig Signature: (a(lda,n);longlong ipvt(n);b(n);longlong job()) Solve the real system C or C using the factors computed by L or L. =for bad gesl does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 658 "Slatec.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *gesl = \&PDL::gesl; #line 664 "Slatec.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 rs =for sig Signature: (a(n,n);[o]w(n);longlong matz();[o]z(n,n);[t]fvone(n);[t]fvtwo(n);longlong [o]ierr()) This subroutine calls the recommended sequence of subroutines from the eigensystem subroutine package (EISPACK) to find the eigenvalues and eigenvectors (if desired) of a REAL SYMMETRIC matrix. =for bad rs does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 689 "Slatec.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *rs = \&PDL::rs; #line 695 "Slatec.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 ezffti =for sig Signature: (longlong n();[o]wsave(foo)) Subroutine ezffti initializes the work array C which is used in both L and L. The prime factorization of C together with a tabulation of the trigonometric functions are computed and stored in C. =for bad ezffti does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 722 "Slatec.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *ezffti = \&PDL::ezffti; #line 728 "Slatec.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 ezfftf =for sig Signature: (r(n);[o]azero();[o]a(n);[o]b(n);wsave(foo)) =for ref =for bad ezfftf does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 752 "Slatec.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *ezfftf = \&PDL::ezfftf; #line 758 "Slatec.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 ezfftb =for sig Signature: ([o]r(n);azero();a(n);b(n);wsave(foo)) =for ref =for bad ezfftb does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 782 "Slatec.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *ezfftb = \&PDL::ezfftb; #line 788 "Slatec.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 pcoef =for sig Signature: (longlong l();c();[o]tc(bar);a(foo)) Convert the C coefficients to Taylor series form. C and C must be of the same type. =for bad pcoef does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 811 "Slatec.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *pcoef = \&PDL::pcoef; #line 817 "Slatec.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 pvalue =for sig Signature: (longlong l();x();[o]yfit();[o]yp(nder);a(foo)) Use the coefficients generated by C to evaluate the polynomial fit of degree C, along with the first C of its derivatives, at a specified point. C and C must be of the same type. =for bad pvalue does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 842 "Slatec.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *pvalue = \&PDL::pvalue; #line 848 "Slatec.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 chim =for sig Signature: (x(n);f(n);[o]d(n);longlong [o]ierr()) =for ref Calculate the derivatives of (x,f(x)) using cubic Hermite interpolation. Calculate the derivatives at the given set of points (C<$x,$f>, where C<$x> is strictly increasing). The resulting set of points - C<$x,$f,$d>, referred to as the cubic Hermite representation - can then be used in other functions, such as L, L, and L. The boundary conditions are compatible with monotonicity, and if the data are only piecewise monotonic, the interpolant will have an extremum at the switch points; for more control over these issues use L. Error status returned by C<$ierr>: =over 4 =item * 0 if successful. =item * E 0 if there were C switches in the direction of monotonicity (data still valid). =item * -1 if C 2>. =item * -3 if C<$x> is not strictly increasing. =back =for bad chim does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 910 "Slatec.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *chim = \&PDL::chim; #line 916 "Slatec.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 chic =for sig Signature: (longlong ic(two=2);vc(two=2);mflag();x(n);f(n);[o]d(n);wk(nwk);longlong [o]ierr()) =for ref Calculate the derivatives of (x,f(x)) using cubic Hermite interpolation. Calculate the derivatives at the given points (C<$x,$f>, where C<$x> is strictly increasing). Control over the boundary conditions is given by the C<$ic> and C<$vc> ndarrays, and the value of C<$mflag> determines the treatment of points where monotoncity switches direction. A simpler, more restricted, interface is available using L. The first and second elements of C<$ic> determine the boundary conditions at the start and end of the data respectively. If the value is 0, then the default condition, as used by L, is adopted. If greater than zero, no adjustment for monotonicity is made, otherwise if less than zero the derivative will be adjusted. The allowed magnitudes for C are: =over 4 =item * 1 if first derivative at C is given in C. =item * 2 if second derivative at C is given in C. =item * 3 to use the 3-point difference formula for C. (Reverts to the default b.c. if C 3>) =item * 4 to use the 4-point difference formula for C. (Reverts to the default b.c. if C 4>) =item * 5 to set C so that the second derivative is continuous at C. (Reverts to the default b.c. if C 4>) =back The values for C are the same as above, except that the first-derivative value is stored in C for cases 1 and 2. The values of C<$vc> need only be set if options 1 or 2 are chosen for C<$ic>. Set C<$mflag = 0> if interpolant is required to be monotonic in each interval, regardless of the data. This causes C<$d> to be set to 0 at all switch points. Set C<$mflag> to be non-zero to use a formula based on the 3-point difference formula at switch points. If C<$mflag E 0>, then the interpolant at swich points is forced to not deviate from the data by more than C<$mflag*dfloc>, where C is the maximum of the change of C<$f> on this interval and its two immediate neighbours. If C<$mflag E 0>, no such control is to be imposed. The ndarray C<$wk> is only needed for work space. However, I could not get it to work as a temporary variable, so you must supply it; it is a 1D ndarray with C<2*n> elements. Error status returned by C<$ierr>: =over 4 =item * 0 if successful. =item * 1 if C 0> and C had to be adjusted for monotonicity. =item * 2 if C 0> and C had to be adjusted for monotonicity. =item * 3 if both 1 and 2 are true. =item * -1 if C 2>. =item * -3 if C<$x> is not strictly increasing. =item * -4 if C 5>. =item * -5 if C 5>. =item * -6 if both -4 and -5 are true. =item * -7 if C 2*(n-1)>. =back =for bad chic does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1054 "Slatec.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *chic = \&PDL::chic; #line 1060 "Slatec.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 chsp =for sig Signature: (longlong ic(two=2);vc(two=2);x(n);f(n);[o]d(n);wk(nwk);longlong [o]ierr()) =for ref Calculate the derivatives of (x,f(x)) using cubic spline interpolation. Calculate the derivatives, using cubic spline interpolation, at the given points (C<$x,$f>), with the specified boundary conditions. Control over the boundary conditions is given by the C<$ic> and C<$vc> ndarrays. The resulting values - C<$x,$f,$d> - can be used in all the functions which expect a cubic Hermite function. The first and second elements of C<$ic> determine the boundary conditions at the start and end of the data respectively. The allowed values for C are: =over 4 =item * 0 to set C so that the third derivative is continuous at C. =item * 1 if first derivative at C is given in C). =item * 2 if second derivative at C) is given in C. =item * 3 to use the 3-point difference formula for C. (Reverts to the default b.c. if C 3>.) =item * 4 to use the 4-point difference formula for C. (Reverts to the default b.c. if C 4>.) =back The values for C are the same as above, except that the first-derivative value is stored in C for cases 1 and 2. The values of C<$vc> need only be set if options 1 or 2 are chosen for C<$ic>. The ndarray C<$wk> is only needed for work space. However, I could not get it to work as a temporary variable, so you must supply it; it is a 1D ndarray with C<2*n> elements. Error status returned by C<$ierr>: =over 4 =item * 0 if successful. =item * -1 if C 2>. =item * -3 if C<$x> is not strictly increasing. =item * -4 if C 0> or C 4>. =item * -5 if C 0> or C 4>. =item * -6 if both of the above are true. =item * -7 if C 2*n>. =item * -8 in case of trouble solving the linear system for the interior derivative values. =back =for bad chsp does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1175 "Slatec.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *chsp = \&PDL::chsp; #line 1181 "Slatec.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 chfd =for sig Signature: (x(n);f(n);d(n);longlong check();xe(ne);[o]fe(ne);[o]de(ne);longlong [o]ierr()) =for ref Interpolate function and derivative values. Given a piecewise cubic Hermite function - such as from L - evaluate the function (C<$fe>) and derivative (C<$de>) at a set of points (C<$xe>). If function values alone are required, use L. Set C to 0 to skip checks on the input data. Error status returned by C<$ierr>: =over 4 =item * 0 if successful. =item * E0 if extrapolation was performed at C points (data still valid). =item * -1 if C 2> =item * -3 if C<$x> is not strictly increasing. =item * -4 if C 1>. =item * -5 if an error has occurred in a lower-level routine, which should never happen. =back =for bad chfd does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1246 "Slatec.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *chfd = \&PDL::chfd; #line 1252 "Slatec.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 chfe =for sig Signature: (x(n);f(n);d(n);longlong check();xe(ne);[o]fe(ne);longlong [o]ierr()) =for ref Interpolate function values. Given a piecewise cubic Hermite function - such as from L - evaluate the function (C<$fe>) at a set of points (C<$xe>). If derivative values are also required, use L. Set C to 0 to skip checks on the input data. Error status returned by C<$ierr>: =over 4 =item * 0 if successful. =item * E0 if extrapolation was performed at C points (data still valid). =item * -1 if C 2> =item * -3 if C<$x> is not strictly increasing. =item * -4 if C 1>. =back =for bad chfe does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1312 "Slatec.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *chfe = \&PDL::chfe; #line 1318 "Slatec.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 chia =for sig Signature: (x(n);f(n);d(n);longlong check();la();lb();[o]ans();longlong [o]ierr()) =for ref Integrate (x,f(x)) over arbitrary limits. Evaluate the definite integral of a piecewise cubic Hermite function over an arbitrary interval, given by C<[$la,$lb]>. C<$d> should contain the derivative values, computed by L. See L if the integration limits are data points. Set C to 0 to skip checks on the input data. The values of C<$la> and C<$lb> do not have to lie within C<$x>, although the resulting integral value will be highly suspect if they are not. Error status returned by C<$ierr>: =over 4 =item * 0 if successful. =item * 1 if C<$la> lies outside C<$x>. =item * 2 if C<$lb> lies outside C<$x>. =item * 3 if both 1 and 2 are true. =item * -1 if C 2> =item * -3 if C<$x> is not strictly increasing. =item * -4 if an error has occurred in a lower-level routine, which should never happen. =back =for bad chia does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1391 "Slatec.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *chia = \&PDL::chia; #line 1397 "Slatec.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 chid =for sig Signature: (x(n);f(n);d(n);longlong check();longlong ia();longlong ib();[o]ans();longlong [o]ierr()) =for ref Integrate (x,f(x)) between data points. Evaluate the definite integral of a a piecewise cubic Hermite function between C and C. See L for integration between arbitrary limits. Although using a fortran routine, the values of C<$ia> and C<$ib> are zero offset. C<$d> should contain the derivative values, computed by L. Set C to 0 to skip checks on the input data. Error status returned by C<$ierr>: =over 4 =item * 0 if successful. =item * -1 if C 2>. =item * -3 if C<$x> is not strictly increasing. =item * -4 if C<$ia> or C<$ib> is out of range. =back =for bad chid does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1458 "Slatec.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *chid = \&PDL::chid; #line 1464 "Slatec.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 chcm =for sig Signature: (x(n);f(n);d(n);longlong check();longlong [o]ismon(n);longlong [o]ierr()) =for ref Check the given piecewise cubic Hermite function for monotonicity. The outout ndarray C<$ismon> indicates over which intervals the function is monotonic. Set C to 0 to skip checks on the input data. For the data interval C<[x(i),x(i+1)]>, the values of C can be: =over 4 =item * -3 if function is probably decreasing =item * -1 if function is strictly decreasing =item * 0 if function is constant =item * 1 if function is strictly increasing =item * 2 if function is non-monotonic =item * 3 if function is probably increasing =back If C, the derivative values are near the boundary of the monotonicity region. A small increase produces non-monotonicity, whereas a decrease produces strict monotonicity. The above applies to C. The last element of C<$ismon> indicates whether the entire function is monotonic over $x. Error status returned by C<$ierr>: =over 4 =item * 0 if successful. =item * -1 if C 2>. =item * -3 if C<$x> is not strictly increasing. =back =for bad chcm does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1553 "Slatec.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *chcm = \&PDL::chcm; #line 1559 "Slatec.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 chbs =for sig Signature: (x(n);f(n);d(n);longlong knotyp();longlong nknots();t(tsize);[o]bcoef(bsize);longlong [o]ndim();longlong [o]kord();longlong [o]ierr()) =for ref Piecewise Cubic Hermite function to B-Spline converter. The resulting B-spline representation of the data (i.e. C, C, C, C, and C) can be evaluated by C (which is currently not available). Array sizes: C, C, and C. C is a flag which controls the knot sequence. The knot sequence C is normally computed from C<$x> by putting a double knot at each C and setting the end knot pairs according to the value of C (where C): =over =item * 0 - Quadruple knots at the first and last points. =item * 1 - Replicate lengths of extreme subintervals: C and C =item * 2 - Periodic placement of boundary knots: C and C =item * E0 - Assume the C and C were set in a previous call. =back C is the number of knots and may be changed by the routine. If C= 0>, C will be set to C, otherwise it is an input variable, and an error will occur if its value is not equal to C. C is the array of C<2*n+4> knots for the B-representation and may be changed by the routine. If C= 0>, C will be changed so that the interior double knots are equal to the x-values and the boundary knots set as indicated above, otherwise it is assumed that C was set by a previous call (no check is made to verify that the data forms a legitimate knot sequence). Error status returned by C<$ierr>: =over 4 =item * 0 if successful. =item * -4 if C 2>. =item * -5 if C 0> and C. =back =for bad chbs does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1655 "Slatec.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *chbs = \&PDL::chbs; #line 1661 "Slatec.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 polfit =for sig Signature: (x(n); y(n); w(n); longlong maxdeg(); longlong [o]ndeg(); [o]eps(); [o]r(n); longlong [o]ierr(); [o]a(foo); [o]coeffs(bar);[t]xtmp(n);[t]ytmp(n);[t]wtmp(n);[t]rtmp(n)) Fit discrete data in a least squares sense by polynomials in one variable. C, C and C must be of the same type. This version handles bad values appropriately =for bad polfit processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 1685 "Slatec.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *polfit = \&PDL::polfit; #line 1691 "Slatec.pm" #line 1605 "slatec.pd" =head1 AUTHOR Copyright (C) 1997 Tuomas J. Lukka. Copyright (C) 2000 Tim Jenness, Doug Burke. 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 #line 1708 "Slatec.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/Math.pm0000644000175000017500000003431714200406303015237 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::Math; our @EXPORT_OK = qw(acos asin atan cosh sinh tan tanh ceil floor rint pow acosh asinh atanh erf erfc bessj0 bessj1 bessy0 bessy1 bessjn bessyn lgamma badmask isfinite erfi ndtri polyroots ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Math ; #line 14 "math.pd" use strict; use warnings; =head1 NAME PDL::Math - extended mathematical operations and special functions =head1 SYNOPSIS use PDL::Math; use PDL::Graphics::TriD; imag3d [SURF2D,bessj0(rvals(zeroes(50,50))/2)]; =head1 DESCRIPTION This module extends PDL with more advanced mathematical functions than provided by standard Perl. All the functions have one input pdl, and one output, unless otherwise stated. Many of the functions are linked from the system maths library or the Cephes maths library (determined when PDL is compiled); a few are implemented entirely in PDL. =cut ### Kludge for backwards compatibility with older scripts ### This should be deleted at some point later than 21-Nov-2003. BEGIN {use PDL::MatrixOps;} #line 57 "Math.pm" =head1 FUNCTIONS =cut #line 1059 "../../blib/lib/PDL/PP.pm" =head2 acos =for sig Signature: (a(); [o]b()) The usual trigonometric function. Works inplace. =for bad acos processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 90 "Math.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *acos = \&PDL::acos; #line 96 "Math.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 asin =for sig Signature: (a(); [o]b()) The usual trigonometric function. Works inplace. =for bad asin processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 119 "Math.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *asin = \&PDL::asin; #line 125 "Math.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 atan =for sig Signature: (a(); [o]b()) The usual trigonometric function. Works inplace. =for bad atan processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 148 "Math.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *atan = \&PDL::atan; #line 154 "Math.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 cosh =for sig Signature: (a(); [o]b()) The standard hyperbolic function. Works inplace. =for bad cosh processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 177 "Math.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *cosh = \&PDL::cosh; #line 183 "Math.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 sinh =for sig Signature: (a(); [o]b()) The standard hyperbolic function. Works inplace. =for bad sinh processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 206 "Math.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *sinh = \&PDL::sinh; #line 212 "Math.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 tan =for sig Signature: (a(); [o]b()) The usual trigonometric function. Works inplace. =for bad tan processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 235 "Math.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *tan = \&PDL::tan; #line 241 "Math.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 tanh =for sig Signature: (a(); [o]b()) The standard hyperbolic function. Works inplace. =for bad tanh processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 264 "Math.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *tanh = \&PDL::tanh; #line 270 "Math.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 ceil =for sig Signature: (a(); [o]b()) =for ref Round to integer values in floating-point format. Works inplace. =for bad ceil processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 294 "Math.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *ceil = \&PDL::ceil; #line 300 "Math.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 floor =for sig Signature: (a(); [o]b()) =for ref Round to integer values in floating-point format. Works inplace. =for bad floor processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 324 "Math.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *floor = \&PDL::floor; #line 330 "Math.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 rint =for sig Signature: (a(); [o]b()) =for ref Round to integer values in floating-point format. =for method rint uses the 'round half to even' rounding method (also known as banker's rounding). Half-integers are rounded to the nearest even number. This avoids a slight statistical bias inherent in always rounding half-integers up or away from zero. If you are looking to round half-integers up (regardless of sign), try C. If you want to round half-integers away from zero, try C<< ceil(abs($x)+0.5)*($x<=>0) >>. Works inplace. =for bad rint processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 365 "Math.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *rint = \&PDL::rint; #line 371 "Math.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 pow =for sig Signature: (a(); b(); [o]c()) =for ref Synonym for `**'. Works inplace. =for bad pow processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 395 "Math.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *pow = \&PDL::pow; #line 401 "Math.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 acosh =for sig Signature: (a(); [o]b()) The standard hyperbolic function. Works inplace. =for bad acosh processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 424 "Math.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *acosh = \&PDL::acosh; #line 430 "Math.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 asinh =for sig Signature: (a(); [o]b()) The standard hyperbolic function. Works inplace. =for bad asinh processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 453 "Math.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *asinh = \&PDL::asinh; #line 459 "Math.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 atanh =for sig Signature: (a(); [o]b()) The standard hyperbolic function. Works inplace. =for bad atanh processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 482 "Math.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *atanh = \&PDL::atanh; #line 488 "Math.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 erf =for sig Signature: (a(); [o]b()) =for ref The error function. Works inplace. =for bad erf processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 512 "Math.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *erf = \&PDL::erf; #line 518 "Math.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 erfc =for sig Signature: (a(); [o]b()) =for ref The complement of the error function. Works inplace. =for bad erfc processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 542 "Math.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *erfc = \&PDL::erfc; #line 548 "Math.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 bessj0 =for sig Signature: (a(); [o]b()) =for ref The regular Bessel function of the first kind, J_n Works inplace. =for bad bessj0 processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 572 "Math.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *bessj0 = \&PDL::bessj0; #line 578 "Math.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 bessj1 =for sig Signature: (a(); [o]b()) =for ref The regular Bessel function of the first kind, J_n Works inplace. =for bad bessj1 processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 602 "Math.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *bessj1 = \&PDL::bessj1; #line 608 "Math.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 bessy0 =for sig Signature: (a(); [o]b()) =for ref The regular Bessel function of the second kind, Y_n. Works inplace. =for bad bessy0 processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 632 "Math.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *bessy0 = \&PDL::bessy0; #line 638 "Math.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 bessy1 =for sig Signature: (a(); [o]b()) =for ref The regular Bessel function of the second kind, Y_n. Works inplace. =for bad bessy1 processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 662 "Math.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *bessy1 = \&PDL::bessy1; #line 668 "Math.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 bessjn =for sig Signature: (a(); int n(); [o]b()) =for ref The regular Bessel function of the first kind, J_n . This takes a second int argument which gives the order of the function required. Works inplace. =for bad bessjn processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 696 "Math.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *bessjn = \&PDL::bessjn; #line 702 "Math.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 bessyn =for sig Signature: (a(); int n(); [o]b()) =for ref The regular Bessel function of the first kind, Y_n . This takes a second int argument which gives the order of the function required. Works inplace. =for bad bessyn processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 730 "Math.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *bessyn = \&PDL::bessyn; #line 736 "Math.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 lgamma =for sig Signature: (a(); [o]b(); int[o]s()) =for ref log gamma function This returns 2 ndarrays -- the first set gives the log(gamma) values, while the second set, of integer values, gives the sign of the gamma function. This is useful for determining factorials, amongst other things. =for bad lgamma processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 767 "Math.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *lgamma = \&PDL::lgamma; #line 773 "Math.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 badmask =for sig Signature: (a(); b(); [o]c()) =for ref Clears all C and C in C<$a> to the corresponding value in C<$b>. badmask can be run with C<$x> inplace: badmask($x->inplace,0); $x->inplace->badmask(0); =for bad If bad values are present, these are also cleared. =cut #line 802 "Math.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *badmask = \&PDL::badmask; #line 808 "Math.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 isfinite =for sig Signature: (a(); int [o]mask()) =for ref Sets C<$mask> true if C<$a> is not a C or C (either positive or negative). Works inplace. =for bad Bad values are treated as C or C. =cut #line 830 "Math.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *isfinite = \&PDL::isfinite; #line 836 "Math.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 erfi =for sig Signature: (a(); [o]b()) =for ref The inverse of the error function. Works inplace. =for bad erfi processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 860 "Math.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *erfi = \&PDL::erfi; #line 866 "Math.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 ndtri =for sig Signature: (a(); [o]b()) =for ref The value for which the area under the Gaussian probability density function (integrated from minus infinity) is equal to the argument (cf L). Works inplace. =for bad ndtri processes bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 892 "Math.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *ndtri = \&PDL::ndtri; #line 898 "Math.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 polyroots =for sig Signature: (cr(n); ci(n); [o]rr(m); [o]ri(m)) =for ref Complex roots of a complex polynomial, given coefficients in order of decreasing powers. =for usage ($rr, $ri) = polyroots($cr, $ci); =for bad polyroots does not process bad values. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut #line 931 "Math.pm" #line 1061 "../../blib/lib/PDL/PP.pm" *polyroots = \&PDL::polyroots; #line 937 "Math.pm" #line 423 "math.pd" =head1 BUGS Hasn't been tested on all platforms to ensure Cephes versions are picked up automatically and used correctly. =head1 AUTHOR Copyright (C) R.J.R. Williams 1997 (rjrw@ast.leeds.ac.uk), Karl Glazebrook (kgb@aaoepp.aao.gov.au) and Tuomas J. Lukka (Tuomas.Lukka@helsinki.fi). Portions (C) Craig DeForest 2002 (deforest@boulder.swri.edu). 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 PDL copyright notice should be included in the file. =cut #line 963 "Math.pm" # Exit with OK status 1; PDL-2.074/GENERATED/PDL/Transform.pm0000644000175000017500000031456614200406317016335 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::Transform; our @EXPORT_OK = qw(apply invert map map unmap t_inverse t_compose t_wrap t_identity t_lookup t_linear t_scale t_offset t_rot t_fits t_code t_cylindrical t_radial t_quadratic t_cubic t_quadratic t_spherical t_projective ); our %EXPORT_TAGS = (Func=>\@EXPORT_OK); use PDL::Core; use PDL::Exporter; use DynaLoader; our @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::Transform ; #line 3 "transform.pd" =head1 NAME PDL::Transform - Coordinate transforms, image warping, and N-D functions =head1 SYNOPSIS use PDL::Transform; my $t = new PDL::Transform::() $out = $t->apply($in) # Apply transform to some N-vectors (Transform method) $out = $in->apply($t) # Apply transform to some N-vectors (PDL method) $im1 = $t->map($im); # Transform image coordinates (Transform method) $im1 = $im->map($t); # Transform image coordinates (PDL method) $t2 = $t->compose($t1); # compose two transforms $t2 = $t x $t1; # compose two transforms (by analogy to matrix mult.) $t3 = $t2->inverse(); # invert a transform $t3 = !$t2; # invert a transform (by analogy to logical "not") =head1 DESCRIPTION PDL::Transform is a convenient way to represent coordinate transformations and resample images. It embodies functions mapping R^N -> R^M, both with and without inverses. Provision exists for parametrizing functions, and for composing them. You can use this part of the Transform object to keep track of arbitrary functions mapping R^N -> R^M with or without inverses. The simplest way to use a Transform object is to transform vector data between coordinate systems. The L method accepts a PDL whose 0th dimension is coordinate index (all other dimensions are threaded over) and transforms the vectors into the new coordinate system. Transform also includes image resampling, via the L method. You define a coordinate transform using a Transform object, then use it to remap an image PDL. The output is a remapped, resampled image. You can define and compose several transformations, then apply them all at once to an image. The image is interpolated only once, when all the composed transformations are applied. In keeping with standard practice, but somewhat counterintuitively, the L engine uses the inverse transform to map coordinates FROM the destination dataspace (or image plane) TO the source dataspace; hence PDL::Transform keeps track of both the forward and inverse transform. For terseness and convenience, most of the constructors are exported into the current package with the name C<< t_ >>, so the following (for example) are synonyms: $t = new PDL::Transform::Radial(); # Long way $t = t_radial(); # Short way Several math operators are overloaded, so that you can compose and invert functions with expression syntax instead of method syntax (see below). =head1 EXAMPLE Coordinate transformations and mappings are a little counterintuitive at first. Here are some examples of transforms in action: use PDL::Transform; $x = rfits('m51.fits'); # Substitute path if necessary! $ts = t_linear(Scale=>3); # Scaling transform $w = pgwin(xs); $w->imag($x); ## Grow m51 by a factor of 3; origin is at lower left. $y = $ts->map($x,{pix=>1}); # pix option uses direct pixel coord system $w->imag($y); ## Shrink m51 by a factor of 3; origin still at lower left. $c = $ts->unmap($x, {pix=>1}); $w->imag($c); ## Grow m51 by a factor of 3; origin is at scientific origin. $d = $ts->map($x,$x->hdr); # FITS hdr template prevents autoscaling $w->imag($d); ## Shrink m51 by a factor of 3; origin is still at sci. origin. $e = $ts->unmap($x,$x->hdr); $w->imag($e); ## A no-op: shrink m51 by a factor of 3, then autoscale back to size $f = $ts->map($x); # No template causes autoscaling of output =head1 OPERATOR OVERLOADS =over 3 =item '!' The bang is a unary inversion operator. It binds exactly as tightly as the normal bang operator. =item 'x' By analogy to matrix multiplication, 'x' is the compose operator, so these two expressions are equivalent: $f->inverse()->compose($g)->compose($f) # long way !$f x $g x $f # short way Both of those expressions are equivalent to the mathematical expression f^-1 o g o f, or f^-1(g(f(x))). =item '**' By analogy to numeric powers, you can apply an operator a positive integer number of times with the ** operator: $f->compose($f)->compose($f) # long way $f**3 # short way =back =head1 INTERNALS Transforms are perl hashes. Here's a list of the meaning of each key: =over 3 =item func Ref to a subroutine that evaluates the transformed coordinates. It's called with the input coordinate, and the "params" hash. This springboarding is done via explicit ref rather than by subclassing, for convenience both in coding new transforms (just add the appropriate sub to the module) and in adding custom transforms at run-time. Note that, if possible, new Cs should support L operation to save memory when the data are flagged inplace. But C should always return its result even when flagged to compute in-place. C should treat the 0th dimension of its input as a dimensional index (running 0..N-1 for R^N operation) and thread over all other input dimensions. =item inv Ref to an inverse method that reverses the transformation. It must accept the same "params" hash that the forward method accepts. This key can be left undefined in cases where there is no inverse. =item idim, odim Number of useful dimensions for indexing on the input and output sides (ie the order of the 0th dimension of the coordinates to be fed in or that come out). If this is set to 0, then as many are allocated as needed. =item name A shorthand name for the transformation (convenient for debugging). You should plan on using UNIVERAL::isa to identify classes of transformation, e.g. all linear transformations should be subclasses of PDL::Transform::Linear. That makes it easier to add smarts to, e.g., the compose() method. =item itype An array containing the name of the quantity that is expected from the input ndarray for the transform, for each dimension. This field is advisory, and can be left blank if there's no obvious quantity associated with the transform. This is analogous to the CTYPEn field used in FITS headers. =item oname Same as itype, but reporting what quantity is delivered for each dimension. =item iunit The units expected on input, if a specific unit (e.g. degrees) is expected. This field is advisory, and can be left blank if there's no obvious unit associated with the transform. =item ounit Same as iunit, but reporting what quantity is delivered for each dimension. =item params Hash ref containing relevant parameters or anything else the func needs to work right. =item is_inverse Bit indicating whether the transform has been inverted. That is useful for some stringifications (see the PDL::Transform::Linear stringifier), and may be useful for other things. =back Transforms should be inplace-aware where possible, to prevent excessive memory usage. If you define a new type of transform, consider generating a new stringify method for it. Just define the sub "stringify" in the subclass package. It should call SUPER::stringify to generate the first line (though the PDL::Transform::Composition bends this rule by tweaking the top-level line), then output (indented) additional lines as necessary to fully describe the transformation. =head1 NOTES Transforms have a mechanism for labeling the units and type of each coordinate, but it is just advisory. A routine to identify and, if necessary, modify units by scaling would be a good idea. Currently, it just assumes that the coordinates are correct for (e.g.) FITS scientific-to-pixel transformations. Composition works OK but should probably be done in a more sophisticated way so that, for example, linear transformations are combined at the matrix level instead of just strung together pixel-to-pixel. =head1 MODULE INTERFACE There are both operators and constructors. The constructors are all exported, all begin with "t_", and all return objects that are subclasses of PDL::Transform. The L, L, L, and L methods are also exported to the C package: they are both Transform methods and PDL methods. =cut use strict; use warnings; #line 263 "Transform.pm" =head1 FUNCTIONS =cut #line 315 "transform.pd" =head2 apply =for sig Signature: (data(); PDL::Transform t) =for usage $out = $data->apply($t); $out = $t->apply($data); =for ref Apply a transformation to some input coordinates. In the example, C<$t> is a PDL::Transform and C<$data> is a PDL to be interpreted as a collection of N-vectors (with index in the 0th dimension). The output is a similar but transformed PDL. For convenience, this is both a PDL method and a Transform method. =cut use Carp; *PDL::apply = \&apply; sub apply { my($me) = shift; my($from) = shift; if(UNIVERSAL::isa($me,'PDL')){ my($x) = $from; $from = $me; $me = $x; } if(UNIVERSAL::isa($me,'PDL::Transform') && UNIVERSAL::isa($from,'PDL')){ croak "Applying a PDL::Transform with no func! Oops.\n" unless(defined($me->{func}) and ref($me->{func}) eq 'CODE'); my $result = &{$me->{func}}($from,$me->{params}); $result->is_inplace(0); # clear inplace flag, just in case. return $result; } else { croak "apply requires both a PDL and a PDL::Transform.\n"; } } #line 325 "Transform.pm" #line 367 "transform.pd" =head2 invert =for sig Signature: (data(); PDL::Transform t) =for usage $out = $t->invert($data); $out = $data->invert($t); =for ref Apply an inverse transformation to some input coordinates. In the example, C<$t> is a PDL::Transform and C<$data> is an ndarray to be interpreted as a collection of N-vectors (with index in the 0th dimension). The output is a similar ndarray. For convenience this is both a PDL method and a PDL::Transform method. =cut *PDL::invert = \&invert; sub invert { my($me) = shift; my($data) = shift; if(UNIVERSAL::isa($me,'PDL')){ my($x) = $data; $data = $me; $me = $x; } if(UNIVERSAL::isa($me,'PDL::Transform') && UNIVERSAL::isa($data,'PDL')){ croak "Inverting a PDL::Transform with no inverse! Oops.\n" unless(defined($me->{inv}) and ref($me->{inv}) eq 'CODE'); my $result = &{$me->{inv}}($data, $me->{params}); $result->is_inplace(0); # make sure inplace flag is clear. return $result; } else { croak("invert requires a PDL and a PDL::Transform (did you want 'inverse' instead?)\n"); } } #line 374 "Transform.pm" #line 1059 "../../blib/lib/PDL/PP.pm" =head2 map =for sig Signature: (k0(); pdl *in; pdl *out; pdl *map; SV *boundary; SV *method; long big; double blur; double sv_min; char flux; SV *bv) =head2 match =for usage $y = $x->match($c); # Match $c's header and size $y = $x->match([100,200]); # Rescale to 100x200 pixels $y = $x->match([100,200],{rect=>1}); # Rescale and remove rotation/skew. =for ref Resample a scientific image to the same coordinate system as another. The example above is syntactic sugar for $y = $x->map(t_identity, $c, ...); it resamples the input PDL with the identity transformation in scientific coordinates, and matches the pixel coordinate system to $c's FITS header. There is one difference between match and map: match makes the C option to C default to 0, not 1. This only affects matching where autoscaling is required (i.e. the array ref example above). By default, that example simply scales $x to the new size and maintains any rotation or skew in its scientific-to-pixel coordinate transform. =head2 map =for usage $y = $x->map($xform,[

- print Builds a C expression in the C<$cmd>; this will get executed at the bottom of the loop. =cut # p - print (no args): print $_. $cmd =~ s/^p$/print {\$DB::OUT} \$_/; # p - print the given expression. $cmd =~ s/^p\b/print {\$DB::OUT} /; =head4 C<=> - define command alias Manipulates C<%alias> to add or list command aliases. =cut # = - set up a command alias. $cmd =~ s/^=\s*// && do { my @keys; if ( length $cmd == 0 ) { # No args, get current aliases. @keys = sort keys %alias; } elsif ( my ( $k, $v ) = ( $cmd =~ /^(\S+)\s+(\S.*)/ ) ) { # Creating a new alias. $k is alias name, $v is # alias value. # can't use $_ or kill //g state for my $x ( $k, $v ) { # Escape "alarm" characters. $x =~ s/\a/\\a/g; } # Substitute key for value, using alarm chars # as separators (which is why we escaped them in # the command). $alias{$k} = "s\a$k\a$v\a"; # Turn off standard warn and die behavior. local $SIG{__DIE__}; local $SIG{__WARN__}; # Is it valid Perl? unless ( eval "sub { s\a$k\a$v\a }; 1" ) { # Nope. Bad alias. Say so and get out. print $OUT "Can't alias $k to $v: $@\n"; delete $alias{$k}; next CMD; } # We'll only list the new one. @keys = ($k); } ## end elsif (my ($k, $v) = ($cmd... # The argument is the alias to list. else { @keys = ($cmd); } # List aliases. for my $k (@keys) { # Messy metaquoting: Trim the substiution code off. # We use control-G as the delimiter because it's not # likely to appear in the alias. if ( ( my $v = $alias{$k} ) =~ ss\a$k\a(.*)\a$1 ) { # Print the alias. print $OUT "$k\t= $1\n"; } elsif ( defined $alias{$k} ) { # Couldn't trim it off; just print the alias code. print $OUT "$k\t$alias{$k}\n"; } else { # No such, dude. print "No alias for $k\n"; } } ## end for my $k (@keys) next CMD; }; =head4 C - read commands from a file. Opens a lexical filehandle and stacks it on C<@cmdfhs>; C will pick it up. =cut # source - read commands from a file (or pipe!) and execute. $cmd =~ /^source\s+(.*\S)/ && do { if ( open my $fh, $1 ) { # Opened OK; stick it in the list of file handles. push @cmdfhs, $fh; } else { # Couldn't open it. &warn("Can't execute `$1': $!\n"); } next CMD; }; =head4 C - send current history to a file Takes the complete history, (not the shrunken version you see with C), and saves it to the given filename, so it can be replayed using C. Note that all C<^(save|source)>'s are commented out with a view to minimise recursion. =cut # save source - write commands to a file for later use $cmd =~ /^save\s*(.*)$/ && do { my $file = $1 || '.perl5dbrc'; # default? if ( open my $fh, "> $file" ) { # chomp to remove extraneous newlines from source'd files chomp( my @truelist = map { m/^\s*(save|source)/ ? "#$_" : $_ } @truehist ); print $fh join( "\n", @truelist ); print "commands saved in $file\n"; } else { &warn("Can't save debugger commands in '$1': $!\n"); } next CMD; }; =head4 C - restart Restart the debugger session. =head4 C - rerun the current session Return to any given position in the B-history list =cut # R - restart execution. # rerun - controlled restart execution. $cmd =~ /^(R|rerun\s*(.*))$/ && do { my @args = ($1 eq 'R' ? restart() : rerun($2)); # Close all non-system fds for a clean restart. A more # correct method would be to close all fds that were not # open when the process started, but this seems to be # hard. See "debugger 'R'estart and open database # connections" on p5p. my $max_fd = 1024; # default if POSIX can't be loaded if (eval { require POSIX }) { $max_fd = POSIX::sysconf(POSIX::_SC_OPEN_MAX()); } if (defined $max_fd) { foreach ($^F+1 .. $max_fd-1) { next unless open FD_TO_CLOSE, "<&=$_"; close(FD_TO_CLOSE); } } # And run Perl again. We use exec() to keep the # PID stable (and that way $ini_pids is still valid). exec(@args) || print $OUT "exec failed: $!\n"; last CMD; }; =head4 C<|, ||> - pipe output through the pager. For C<|>, we save C (the debugger's output filehandle) and C (the program's standard output). For C<||>, we only save C. We open a pipe to the pager (restoring the output filehandles if this fails). If this is the C<|> command, we also set up a C handler which will simply set C<$signal>, sending us back into the debugger. We then trim off the pipe symbols and C the command loop at the C label, causing us to evaluate the command in C<$cmd> without reading another. =cut # || - run command in the pager, with output to DB::OUT. $cmd =~ /^\|\|?\s*[^|]/ && do { if ( $pager =~ /^\|/ ) { # Default pager is into a pipe. Redirect I/O. open( SAVEOUT, ">&STDOUT" ) || &warn("Can't save STDOUT"); open( STDOUT, ">&OUT" ) || &warn("Can't redirect STDOUT"); } ## end if ($pager =~ /^\|/) else { # Not into a pipe. STDOUT is safe. open( SAVEOUT, ">&OUT" ) || &warn("Can't save DB::OUT"); } # Fix up environment to record we have less if so. fix_less(); unless ( $piped = open( OUT, $pager ) ) { # Couldn't open pipe to pager. &warn("Can't pipe output to `$pager'"); if ( $pager =~ /^\|/ ) { # Redirect I/O back again. open( OUT, ">&STDOUT" ) # XXX: lost message || &warn("Can't restore DB::OUT"); open( STDOUT, ">&SAVEOUT" ) || &warn("Can't restore STDOUT"); close(SAVEOUT); } ## end if ($pager =~ /^\|/) else { # Redirect I/O. STDOUT already safe. open( OUT, ">&STDOUT" ) # XXX: lost message || &warn("Can't restore DB::OUT"); } next CMD; } ## end unless ($piped = open(OUT,... # Set up broken-pipe handler if necessary. $SIG{PIPE} = \&DB::catch if $pager =~ /^\|/ && ( "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE} ); # Save current filehandle, unbuffer out, and put it back. $selected = select(OUT); $| = 1; # Don't put it back if pager was a pipe. select($selected), $selected = "" unless $cmd =~ /^\|\|/; # Trim off the pipe symbols and run the command now. $cmd =~ s/^\|+\s*//; redo PIPE; }; =head3 END OF COMMAND PARSING Anything left in C<$cmd> at this point is a Perl expression that we want to evaluate. We'll always evaluate in the user's context, and fully qualify any variables we might want to address in the C package. =cut # t - turn trace on. $cmd =~ s/^t\s/\$DB::trace |= 1;\n/; # s - single-step. Remember the last command was 's'. $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do { $laststep = 's' }; # n - single-step, but not into subs. Remember last command # was 'n'. $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do { $laststep = 'n' }; } # PIPE: # Make sure the flag that says "the debugger's running" is # still on, to make sure we get control again. $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; # Run *our* eval that executes in the caller's context. &eval; # Turn off the one-time-dump stuff now. if ($onetimeDump) { $onetimeDump = undef; $onetimedumpDepth = undef; } elsif ( $term_pid == $$ ) { eval { # May run under miniperl, when not available... STDOUT->flush(); STDERR->flush(); }; # XXX If this is the master pid, print a newline. print $OUT "\n"; } } ## end while (($term || &setterm... =head3 POST-COMMAND PROCESSING After each command, we check to see if the command output was piped anywhere. If so, we go through the necessary code to unhook the pipe and go back to our standard filehandles for input and output. =cut continue { # CMD: # At the end of every command: if ($piped) { # Unhook the pipe mechanism now. if ( $pager =~ /^\|/ ) { # No error from the child. $? = 0; # we cannot warn here: the handle is missing --tchrist close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n"; # most of the $? crud was coping with broken cshisms # $? is explicitly set to 0, so this never runs. if ($?) { print SAVEOUT "Pager `$pager' failed: "; if ( $? == -1 ) { print SAVEOUT "shell returned -1\n"; } elsif ( $? >> 8 ) { print SAVEOUT ( $? & 127 ) ? " (SIG#" . ( $? & 127 ) . ")" : "", ( $? & 128 ) ? " -- core dumped" : "", "\n"; } else { print SAVEOUT "status ", ( $? >> 8 ), "\n"; } } ## end if ($?) # Reopen filehandle for our output (if we can) and # restore STDOUT (if we can). open( OUT, ">&STDOUT" ) || &warn("Can't restore DB::OUT"); open( STDOUT, ">&SAVEOUT" ) || &warn("Can't restore STDOUT"); # Turn off pipe exception handler if necessary. $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch; # Will stop ignoring SIGPIPE if done like nohup(1) # does SIGINT but Perl doesn't give us a choice. } ## end if ($pager =~ /^\|/) else { # Non-piped "pager". Just restore STDOUT. open( OUT, ">&SAVEOUT" ) || &warn("Can't restore DB::OUT"); } # Close filehandle pager was using, restore the normal one # if necessary, close(SAVEOUT); select($selected), $selected = "" unless $selected eq ""; # No pipes now. $piped = ""; } ## end if ($piped) } # CMD: =head3 COMMAND LOOP TERMINATION When commands have finished executing, we come here. If the user closed the input filehandle, we turn on C<$fall_off_end> to emulate a C command. We evaluate any post-prompt items. We restore C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>, C<$\>, and C<$^W>, and return a null list as expected by the Perl interpreter. The interpreter will then execute the next line and then return control to us again. =cut # No more commands? Quit. $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF # Evaluate post-prompt commands. foreach $evalarg (@$post) { &eval; } } # if ($single || $signal) # Put the user's globals back where you found them. ( $@, $!, $^E, $,, $/, $\, $^W ) = @saved; (); } ## end sub DB # The following code may be executed now: # BEGIN {warn 4} =head2 sub C is called whenever a subroutine call happens in the program being debugged. The variable C<$DB::sub> contains the name of the subroutine being called. The core function of this subroutine is to actually call the sub in the proper context, capturing its output. This of course causes C to get called again, repeating until the subroutine ends and returns control to C again. Once control returns, C figures out whether or not to dump the return value, and returns its captured copy of the return value as its own return value. The value then feeds back into the program being debugged as if C hadn't been there at all. C does all the work of printing the subroutine entry and exit messages enabled by setting C<$frame>. It notes what sub the autoloader got called for, and also prints the return value if needed (for the C command and if the 16 bit is set in C<$frame>). It also tracks the subroutine call depth by saving the current setting of C<$single> in the C<@stack> package global; if this exceeds the value in C<$deep>, C automatically turns on printing of the current depth by setting the C<4> bit in C<$single>. In any case, it keeps the current setting of stop/don't stop on entry to subs set as it currently is set. =head3 C support If C is called from the package C, it provides some additional data, in the following order: =over 4 =item * C<$package> The package name the sub was in =item * C<$filename> The filename it was defined in =item * C<$line> The line number it was defined on =item * C<$subroutine> The subroutine name; C<(eval)> if an C(). =item * C<$hasargs> 1 if it has arguments, 0 if not =item * C<$wantarray> 1 if array context, 0 if scalar context =item * C<$evaltext> The C() text, if any (undefined for C) =item * C<$is_require> frame was created by a C or C statement =item * C<$hints> pragma information; subject to change between versions =item * C<$bitmask> pragma information; subject to change between versions =item * C<@DB::args> arguments with which the subroutine was invoked =back =cut sub sub { # Do not use a regex in this subroutine -> results in corrupted memory # See: [perl #66110] # lock ourselves under threads lock($DBGR); # Whether or not the autoloader was running, a scalar to put the # sub's return value in (if needed), and an array to put the sub's # return value in (if needed). my ( $al, $ret, @ret ) = ""; if ($sub eq 'threads::new' && $ENV{PERL5DB_THREADED}) { print "creating new thread\n"; } # If the last ten characters are '::AUTOLOAD', note we've traced # into AUTOLOAD for $sub. if ( length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) { $al = " for $$sub" if defined $$sub; } # We stack the stack pointer and then increment it to protect us # from a situation that might unwind a whole bunch of call frames # at once. Localizing the stack pointer means that it will automatically # unwind the same amount when multiple stack frames are unwound. local $stack_depth = $stack_depth + 1; # Protect from non-local exits # Expand @stack. $#stack = $stack_depth; # Save current single-step setting. $stack[-1] = $single; # Turn off all flags except single-stepping. $single &= 1; # If we've gotten really deeply recursed, turn on the flag that will # make us stop with the 'deep recursion' message. $single |= 4 if $stack_depth == $deep; # If frame messages are on ... ( $frame & 4 # Extended frame entry message ? ( print_lineinfo( ' ' x ( $stack_depth - 1 ), "in " ), # Why -1? But it works! :-( # Because print_trace will call add 1 to it and then call # dump_trace; this results in our skipping -1+1 = 0 stack frames # in dump_trace. print_trace( $LINEINFO, -1, 1, 1, "$sub$al" ) ) : print_lineinfo( ' ' x ( $stack_depth - 1 ), "entering $sub$al\n" ) # standard frame entry message ) if $frame; # Determine the sub's return type,and capture approppriately. if (wantarray) { # Called in array context. call sub and capture output. # DB::DB will recursively get control again if appropriate; we'll come # back here when the sub is finished. @ret = &$sub; # Pop the single-step value back off the stack. $single |= $stack[ $stack_depth-- ]; # Check for exit trace messages... ( $frame & 4 # Extended exit message ? ( print_lineinfo( ' ' x $stack_depth, "out " ), print_trace( $LINEINFO, -1, 1, 1, "$sub$al" ) ) : print_lineinfo( ' ' x $stack_depth, "exited $sub$al\n" ) # Standard exit message ) if $frame & 2; # Print the return info if we need to. if ( $doret eq $stack_depth or $frame & 16 ) { # Turn off output record separator. local $\ = ''; my $fh = ( $doret eq $stack_depth ? $OUT : $LINEINFO ); # Indent if we're printing because of $frame tracing. print $fh ' ' x $stack_depth if $frame & 16; # Print the return value. print $fh "list context return from $sub:\n"; dumpit( $fh, \@ret ); # And don't print it again. $doret = -2; } ## end if ($doret eq $stack_depth... # And we have to return the return value now. @ret; } ## end if (wantarray) # Scalar context. else { if ( defined wantarray ) { # Save the value if it's wanted at all. $ret = &$sub; } else { # Void return, explicitly. &$sub; undef $ret; } # Pop the single-step value off the stack. $single |= $stack[ $stack_depth-- ]; # If we're doing exit messages... ( $frame & 4 # Extended messsages ? ( print_lineinfo( ' ' x $stack_depth, "out " ), print_trace( $LINEINFO, -1, 1, 1, "$sub$al" ) ) : print_lineinfo( ' ' x $stack_depth, "exited $sub$al\n" ) # Standard messages ) if $frame & 2; # If we are supposed to show the return value... same as before. if ( $doret eq $stack_depth or $frame & 16 and defined wantarray ) { local $\ = ''; my $fh = ( $doret eq $stack_depth ? $OUT : $LINEINFO ); print $fh ( ' ' x $stack_depth ) if $frame & 16; print $fh ( defined wantarray ? "scalar context return from $sub: " : "void context return from $sub\n" ); dumpit( $fh, $ret ) if defined wantarray; $doret = -2; } ## end if ($doret eq $stack_depth... # Return the appropriate scalar value. $ret; } ## end else [ if (wantarray) } ## end sub sub sub lsub : lvalue { # lock ourselves under threads lock($DBGR); # Whether or not the autoloader was running, a scalar to put the # sub's return value in (if needed), and an array to put the sub's # return value in (if needed). my ( $al, $ret, @ret ) = ""; if ($sub =~ /^threads::new$/ && $ENV{PERL5DB_THREADED}) { print "creating new thread\n"; } # If the last ten characters are C'::AUTOLOAD', note we've traced # into AUTOLOAD for $sub. if ( length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) { $al = " for $$sub"; } # We stack the stack pointer and then increment it to protect us # from a situation that might unwind a whole bunch of call frames # at once. Localizing the stack pointer means that it will automatically # unwind the same amount when multiple stack frames are unwound. local $stack_depth = $stack_depth + 1; # Protect from non-local exits # Expand @stack. $#stack = $stack_depth; # Save current single-step setting. $stack[-1] = $single; # Turn off all flags except single-stepping. $single &= 1; # If we've gotten really deeply recursed, turn on the flag that will # make us stop with the 'deep recursion' message. $single |= 4 if $stack_depth == $deep; # If frame messages are on ... ( $frame & 4 # Extended frame entry message ? ( print_lineinfo( ' ' x ( $stack_depth - 1 ), "in " ), # Why -1? But it works! :-( # Because print_trace will call add 1 to it and then call # dump_trace; this results in our skipping -1+1 = 0 stack frames # in dump_trace. print_trace( $LINEINFO, -1, 1, 1, "$sub$al" ) ) : print_lineinfo( ' ' x ( $stack_depth - 1 ), "entering $sub$al\n" ) # standard frame entry message ) if $frame; # Pop the single-step value back off the stack. $single |= $stack[ $stack_depth-- ]; # call the original lvalue sub. &$sub; } =head1 EXTENDED COMMAND HANDLING AND THE COMMAND API In Perl 5.8.0, there was a major realignment of the commands and what they did, Most of the changes were to systematize the command structure and to eliminate commands that threw away user input without checking. The following sections describe the code added to make it easy to support multiple command sets with conflicting command names. This section is a start at unifying all command processing to make it simpler to develop commands. Note that all the cmd_[a-zA-Z] subroutines require the command name, a line number, and C<$dbline> (the current line) as arguments. Support functions in this section which have multiple modes of failure C on error; the rest simply return a false value. The user-interface functions (all of the C functions) just output error messages. =head2 C<%set> The C<%set> hash defines the mapping from command letter to subroutine name suffix. C<%set> is a two-level hash, indexed by set name and then by command name. Note that trying to set the CommandSet to C simply results in the 5.8.0 command set being used, since there's no top-level entry for C. =cut ### The API section my %set = ( # 'pre580' => { 'a' => 'pre580_a', 'A' => 'pre580_null', 'b' => 'pre580_b', 'B' => 'pre580_null', 'd' => 'pre580_null', 'D' => 'pre580_D', 'h' => 'pre580_h', 'M' => 'pre580_null', 'O' => 'o', 'o' => 'pre580_null', 'v' => 'M', 'w' => 'v', 'W' => 'pre580_W', }, 'pre590' => { '<' => 'pre590_prepost', '<<' => 'pre590_prepost', '>' => 'pre590_prepost', '>>' => 'pre590_prepost', '{' => 'pre590_prepost', '{{' => 'pre590_prepost', }, ); =head2 C (API) C allows the debugger to switch command sets depending on the value of the C option. It tries to look up the command in the C<%set> package-level I (which means external entities can't fiddle with it) and create the name of the sub to call based on the value found in the hash (if it's there). I of the commands to be handled in a set have to be added to C<%set>; if they aren't found, the 5.8.0 equivalent is called (if there is one). This code uses symbolic references. =cut sub cmd_wrapper { my $cmd = shift; my $line = shift; my $dblineno = shift; # Assemble the command subroutine's name by looking up the # command set and command name in %set. If we can't find it, # default to the older version of the command. my $call = 'cmd_' . ( $set{$CommandSet}{$cmd} || ( $cmd =~ /^[<>{]+/o ? 'prepost' : $cmd ) ); # Call the command subroutine, call it by name. return &$call( $cmd, $line, $dblineno ); } ## end sub cmd_wrapper =head3 C (command) The C command handles pre-execution actions. These are associated with a particular line, so they're stored in C<%dbline>. We default to the current line if none is specified. =cut sub cmd_a { my $cmd = shift; my $line = shift || ''; # [.|line] expr my $dbline = shift; # If it's dot (here), or not all digits, use the current line. $line =~ s/^(\.|(?:[^\d]))/$dbline/; # Should be a line number followed by an expression. if ( $line =~ /^\s*(\d*)\s*(\S.+)/ ) { my ( $lineno, $expr ) = ( $1, $2 ); # If we have an expression ... if ( length $expr ) { # ... but the line isn't breakable, complain. if ( $dbline[$lineno] == 0 ) { print $OUT "Line $lineno($dbline[$lineno]) does not have an action?\n"; } else { # It's executable. Record that the line has an action. $had_breakpoints{$filename} |= 2; # Remove any action, temp breakpoint, etc. $dbline{$lineno} =~ s/\0[^\0]*//; # Add the action to the line. $dbline{$lineno} .= "\0" . action($expr); } } ## end if (length $expr) } ## end if ($line =~ /^\s*(\d*)\s*(\S.+)/) else { # Syntax wrong. print $OUT "Adding an action requires an optional lineno and an expression\n" ; # hint } } ## end sub cmd_a =head3 C (command) Delete actions. Similar to above, except the delete code is in a separate subroutine, C. =cut sub cmd_A { my $cmd = shift; my $line = shift || ''; my $dbline = shift; # Dot is this line. $line =~ s/^\./$dbline/; # Call delete_action with a null param to delete them all. # The '1' forces the eval to be true. It'll be false only # if delete_action blows up for some reason, in which case # we print $@ and get out. if ( $line eq '*' ) { eval { &delete_action(); 1 } or print $OUT $@ and return; } # There's a real line number. Pass it to delete_action. # Error trapping is as above. elsif ( $line =~ /^(\S.*)/ ) { eval { &delete_action($1); 1 } or print $OUT $@ and return; } # Swing and a miss. Bad syntax. else { print $OUT "Deleting an action requires a line number, or '*' for all\n" ; # hint } } ## end sub cmd_A =head3 C (API) C accepts either a line number or C. If a line number is specified, we check for the line being executable (if it's not, it couldn't have had an action). If it is, we just take the action off (this will get any kind of an action, including breakpoints). =cut sub delete_action { my $i = shift; if ( defined($i) ) { # Can there be one? die "Line $i has no action .\n" if $dbline[$i] == 0; # Nuke whatever's there. $dbline{$i} =~ s/\0[^\0]*//; # \^a delete $dbline{$i} if $dbline{$i} eq ''; } else { print $OUT "Deleting all actions...\n"; for my $file ( keys %had_breakpoints ) { local *dbline = $main::{ '_<' . $file }; my $max = $#dbline; my $was; for ( $i = 1 ; $i <= $max ; $i++ ) { if ( defined $dbline{$i} ) { $dbline{$i} =~ s/\0[^\0]*//; delete $dbline{$i} if $dbline{$i} eq ''; } unless ( $had_breakpoints{$file} &= ~2 ) { delete $had_breakpoints{$file}; } } ## end for ($i = 1 ; $i <= $max... } ## end for my $file (keys %had_breakpoints) } ## end else [ if (defined($i)) } ## end sub delete_action =head3 C (command) Set breakpoints. Since breakpoints can be set in so many places, in so many ways, conditionally or not, the breakpoint code is kind of complex. Mostly, we try to parse the command type, and then shuttle it off to an appropriate subroutine to actually do the work of setting the breakpoint in the right place. =cut sub cmd_b { my $cmd = shift; my $line = shift; # [.|line] [cond] my $dbline = shift; # Make . the current line number if it's there.. $line =~ s/^\./$dbline/; # No line number, no condition. Simple break on current line. if ( $line =~ /^\s*$/ ) { &cmd_b_line( $dbline, 1 ); } # Break on load for a file. elsif ( $line =~ /^load\b\s*(.*)/ ) { my $file = $1; $file =~ s/\s+$//; &cmd_b_load($file); } # b compile|postpone [] # The interpreter actually traps this one for us; we just put the # necessary condition in the %postponed hash. elsif ( $line =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ ) { # Capture the condition if there is one. Make it true if none. my $cond = length $3 ? $3 : '1'; # Save the sub name and set $break to 1 if $1 was 'postpone', 0 # if it was 'compile'. my ( $subname, $break ) = ( $2, $1 eq 'postpone' ); # De-Perl4-ify the name - ' separators to ::. $subname =~ s/\'/::/g; # Qualify it into the current package unless it's already qualified. $subname = "${'package'}::" . $subname unless $subname =~ /::/; # Add main if it starts with ::. $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::"; # Save the break type for this sub. $postponed{$subname} = $break ? "break +0 if $cond" : "compile"; } ## end elsif ($line =~ ... # b [] elsif ( $line =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ ) { # $subname = $1; $cond = length $2 ? $2 : '1'; &cmd_b_sub( $subname, $cond ); } # b []. elsif ( $line =~ /^(\d*)\s*(.*)/ ) { # Capture the line. If none, it's the current line. $line = $1 || $dbline; # If there's no condition, make it '1'. $cond = length $2 ? $2 : '1'; # Break on line. &cmd_b_line( $line, $cond ); } # Line didn't make sense. else { print "confused by line($line)?\n"; } } ## end sub cmd_b =head3 C (API) We want to break when this file is loaded. Mark this file in the C<%break_on_load> hash, and note that it has a breakpoint in C<%had_breakpoints>. =cut sub break_on_load { my $file = shift; $break_on_load{$file} = 1; $had_breakpoints{$file} |= 1; } =head3 C (API) Gives us an array of filenames that are set to break on load. Note that only files with break-on-load are in here, so simply showing the keys suffices. =cut sub report_break_on_load { sort keys %break_on_load; } =head3 C (command) We take the file passed in and try to find it in C<%INC> (which maps modules to files they came from). We mark those files for break-on-load via C and then report that it was done. =cut sub cmd_b_load { my $file = shift; my @files; # This is a block because that way we can use a redo inside it # even without there being any looping structure at all outside it. { # Save short name and full path if found. push @files, $file; push @files, $::INC{$file} if $::INC{$file}; # Tack on .pm and do it again unless there was a '.' in the name # already. $file .= '.pm', redo unless $file =~ /\./; } # Do the real work here. break_on_load($_) for @files; # All the files that have break-on-load breakpoints. @files = report_break_on_load; # Normalize for the purposes of our printing this. local $\ = ''; local $" = ' '; print $OUT "Will stop on load of `@files'.\n"; } ## end sub cmd_b_load =head3 C<$filename_error> (API package global) Several of the functions we need to implement in the API need to work both on the current file and on other files. We don't want to duplicate code, so C<$filename_error> is used to contain the name of the file that's being worked on (if it's not the current one). We can now build functions in pairs: the basic function works on the current file, and uses C<$filename_error> as part of its error message. Since this is initialized to C<"">, no filename will appear when we are working on the current file. The second function is a wrapper which does the following: =over 4 =item * Localizes C<$filename_error> and sets it to the name of the file to be processed. =item * Localizes the C<*dbline> glob and reassigns it to point to the file we want to process. =item * Calls the first function. The first function works on the I file (i.e., the one we changed to), and prints C<$filename_error> in the error message (the name of the other file) if it needs to. When the functions return, C<*dbline> is restored to point to the actual current file (the one we're executing in) and C<$filename_error> is restored to C<"">. This restores everything to the way it was before the second function was called at all. See the comments in C and C for more details. =back =cut $filename_error = ''; =head3 breakable_line(from, to) (API) The subroutine decides whether or not a line in the current file is breakable. It walks through C<@dbline> within the range of lines specified, looking for the first line that is breakable. If C<$to> is greater than C<$from>, the search moves forwards, finding the first line I C<$to> that's breakable, if there is one. If C<$from> is greater than C<$to>, the search goes I, finding the first line I C<$to> that's breakable, if there is one. =cut sub breakable_line { my ( $from, $to ) = @_; # $i is the start point. (Where are the FORTRAN programs of yesteryear?) my $i = $from; # If there are at least 2 arguments, we're trying to search a range. if ( @_ >= 2 ) { # $delta is positive for a forward search, negative for a backward one. my $delta = $from < $to ? +1 : -1; # Keep us from running off the ends of the file. my $limit = $delta > 0 ? $#dbline : 1; # Clever test. If you're a mathematician, it's obvious why this # test works. If not: # If $delta is positive (going forward), $limit will be $#dbline. # If $to is less than $limit, ($limit - $to) will be positive, times # $delta of 1 (positive), so the result is > 0 and we should use $to # as the stopping point. # # If $to is greater than $limit, ($limit - $to) is negative, # times $delta of 1 (positive), so the result is < 0 and we should # use $limit ($#dbline) as the stopping point. # # If $delta is negative (going backward), $limit will be 1. # If $to is zero, ($limit - $to) will be 1, times $delta of -1 # (negative) so the result is > 0, and we use $to as the stopping # point. # # If $to is less than zero, ($limit - $to) will be positive, # times $delta of -1 (negative), so the result is not > 0, and # we use $limit (1) as the stopping point. # # If $to is 1, ($limit - $to) will zero, times $delta of -1 # (negative), still giving zero; the result is not > 0, and # we use $limit (1) as the stopping point. # # if $to is >1, ($limit - $to) will be negative, times $delta of -1 # (negative), giving a positive (>0) value, so we'll set $limit to # $to. $limit = $to if ( $limit - $to ) * $delta > 0; # The real search loop. # $i starts at $from (the point we want to start searching from). # We move through @dbline in the appropriate direction (determined # by $delta: either -1 (back) or +1 (ahead). # We stay in as long as we haven't hit an executable line # ($dbline[$i] == 0 means not executable) and we haven't reached # the limit yet (test similar to the above). $i += $delta while $dbline[$i] == 0 and ( $limit - $i ) * $delta > 0; } ## end if (@_ >= 2) # If $i points to a line that is executable, return that. return $i unless $dbline[$i] == 0; # Format the message and print it: no breakable lines in range. my ( $pl, $upto ) = ( '', '' ); ( $pl, $upto ) = ( 's', "..$to" ) if @_ >= 2 and $from != $to; # If there's a filename in filename_error, we'll see it. # If not, not. die "Line$pl $from$upto$filename_error not breakable\n"; } ## end sub breakable_line =head3 breakable_line_in_filename(file, from, to) (API) Like C, but look in another file. =cut sub breakable_line_in_filename { # Capture the file name. my ($f) = shift; # Swap the magic line array over there temporarily. local *dbline = $main::{ '_<' . $f }; # If there's an error, it's in this other file. local $filename_error = " of `$f'"; # Find the breakable line. breakable_line(@_); # *dbline and $filename_error get restored when this block ends. } ## end sub breakable_line_in_filename =head3 break_on_line(lineno, [condition]) (API) Adds a breakpoint with the specified condition (or 1 if no condition was specified) to the specified line. Dies if it can't. =cut sub break_on_line { my ( $i, $cond ) = @_; # Always true if no condition supplied. $cond = 1 unless @_ >= 2; my $inii = $i; my $after = ''; my $pl = ''; # Woops, not a breakable line. $filename_error allows us to say # if it was in a different file. die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0; # Mark this file as having breakpoints in it. $had_breakpoints{$filename} |= 1; # If there is an action or condition here already ... if ( $dbline{$i} ) { # ... swap this condition for the existing one. $dbline{$i} =~ s/^[^\0]*/$cond/; } else { # Nothing here - just add the condition. $dbline{$i} = $cond; } } ## end sub break_on_line =head3 cmd_b_line(line, [condition]) (command) Wrapper for C. Prints the failure message if it doesn't work. =cut sub cmd_b_line { eval { break_on_line(@_); 1 } or do { local $\ = ''; print $OUT $@ and return; }; } ## end sub cmd_b_line =head3 break_on_filename_line(file, line, [condition]) (API) Switches to the file specified and then calls C to set the breakpoint. =cut sub break_on_filename_line { my ( $f, $i, $cond ) = @_; # Always true if condition left off. $cond = 1 unless @_ >= 3; # Switch the magical hash temporarily. local *dbline = $main::{ '_<' . $f }; # Localize the variables that break_on_line uses to make its message. local $filename_error = " of `$f'"; local $filename = $f; # Add the breakpoint. break_on_line( $i, $cond ); } ## end sub break_on_filename_line =head3 break_on_filename_line_range(file, from, to, [condition]) (API) Switch to another file, search the range of lines specified for an executable one, and put a breakpoint on the first one you find. =cut sub break_on_filename_line_range { my ( $f, $from, $to, $cond ) = @_; # Find a breakable line if there is one. my $i = breakable_line_in_filename( $f, $from, $to ); # Always true if missing. $cond = 1 unless @_ >= 3; # Add the breakpoint. break_on_filename_line( $f, $i, $cond ); } ## end sub break_on_filename_line_range =head3 subroutine_filename_lines(subname, [condition]) (API) Search for a subroutine within a given file. The condition is ignored. Uses C to locate the desired subroutine. =cut sub subroutine_filename_lines { my ( $subname, $cond ) = @_; # Returned value from find_sub() is fullpathname:startline-endline. # The match creates the list (fullpathname, start, end). Falling off # the end of the subroutine returns this implicitly. find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/; } ## end sub subroutine_filename_lines =head3 break_subroutine(subname) (API) Places a break on the first line possible in the specified subroutine. Uses C to find the subroutine, and C to place the break. =cut sub break_subroutine { my $subname = shift; # Get filename, start, and end. my ( $file, $s, $e ) = subroutine_filename_lines($subname) or die "Subroutine $subname not found.\n"; # Null condition changes to '1' (always true). $cond = 1 unless @_ >= 2; # Put a break the first place possible in the range of lines # that make up this subroutine. break_on_filename_line_range( $file, $s, $e, @_ ); } ## end sub break_subroutine =head3 cmd_b_sub(subname, [condition]) (command) We take the incoming subroutine name and fully-qualify it as best we can. =over 4 =item 1. If it's already fully-qualified, leave it alone. =item 2. Try putting it in the current package. =item 3. If it's not there, try putting it in CORE::GLOBAL if it exists there. =item 4. If it starts with '::', put it in 'main::'. =back After all this cleanup, we call C to try to set the breakpoint. =cut sub cmd_b_sub { my ( $subname, $cond ) = @_; # Add always-true condition if we have none. $cond = 1 unless @_ >= 2; # If the subname isn't a code reference, qualify it so that # break_subroutine() will work right. unless ( ref $subname eq 'CODE' ) { # Not Perl4. $subname =~ s/\'/::/g; my $s = $subname; # Put it in this package unless it's already qualified. $subname = "${'package'}::" . $subname unless $subname =~ /::/; # Requalify it into CORE::GLOBAL if qualifying it into this # package resulted in its not being defined, but only do so # if it really is in CORE::GLOBAL. $subname = "CORE::GLOBAL::$s" if not defined &$subname and $s !~ /::/ and defined &{"CORE::GLOBAL::$s"}; # Put it in package 'main' if it has a leading ::. $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::"; } ## end unless (ref $subname eq 'CODE') # Try to set the breakpoint. eval { break_subroutine( $subname, $cond ); 1 } or do { local $\ = ''; print $OUT $@ and return; } } ## end sub cmd_b_sub =head3 C - delete breakpoint(s) (command) The command mostly parses the command line and tries to turn the argument into a line spec. If it can't, it uses the current line. It then calls C to actually do the work. If C<*> is specified, C calls C with no arguments, thereby deleting all the breakpoints. =cut sub cmd_B { my $cmd = shift; # No line spec? Use dbline. # If there is one, use it if it's non-zero, or wipe it out if it is. my $line = ( $_[0] =~ /^\./ ) ? $dbline : shift || ''; my $dbline = shift; # If the line was dot, make the line the current one. $line =~ s/^\./$dbline/; # If it's * we're deleting all the breakpoints. if ( $line eq '*' ) { eval { &delete_breakpoint(); 1 } or print $OUT $@ and return; } # If there is a line spec, delete the breakpoint on that line. elsif ( $line =~ /^(\S.*)/ ) { eval { &delete_breakpoint( $line || $dbline ); 1 } or do { local $\ = ''; print $OUT $@ and return; }; } ## end elsif ($line =~ /^(\S.*)/) # No line spec. else { print $OUT "Deleting a breakpoint requires a line number, or '*' for all\n" ; # hint } } ## end sub cmd_B =head3 delete_breakpoint([line]) (API) This actually does the work of deleting either a single breakpoint, or all of them. For a single line, we look for it in C<@dbline>. If it's nonbreakable, we just drop out with a message saying so. If it is, we remove the condition part of the 'condition\0action' that says there's a breakpoint here. If, after we've done that, there's nothing left, we delete the corresponding line in C<%dbline> to signal that no action needs to be taken for this line. For all breakpoints, we iterate through the keys of C<%had_breakpoints>, which lists all currently-loaded files which have breakpoints. We then look at each line in each of these files, temporarily switching the C<%dbline> and C<@dbline> structures to point to the files in question, and do what we did in the single line case: delete the condition in C<@dbline>, and delete the key in C<%dbline> if nothing's left. We then wholesale delete C<%postponed>, C<%postponed_file>, and C<%break_on_load>, because these structures contain breakpoints for files and code that haven't been loaded yet. We can just kill these off because there are no magical debugger structures associated with them. =cut sub delete_breakpoint { my $i = shift; # If we got a line, delete just that one. if ( defined($i) ) { # Woops. This line wasn't breakable at all. die "Line $i not breakable.\n" if $dbline[$i] == 0; # Kill the condition, but leave any action. $dbline{$i} =~ s/^[^\0]*//; # Remove the entry entirely if there's no action left. delete $dbline{$i} if $dbline{$i} eq ''; } # No line; delete them all. else { print $OUT "Deleting all breakpoints...\n"; # %had_breakpoints lists every file that had at least one # breakpoint in it. for my $file ( keys %had_breakpoints ) { # Switch to the desired file temporarily. local *dbline = $main::{ '_<' . $file }; my $max = $#dbline; my $was; # For all lines in this file ... for ( $i = 1 ; $i <= $max ; $i++ ) { # If there's a breakpoint or action on this line ... if ( defined $dbline{$i} ) { # ... remove the breakpoint. $dbline{$i} =~ s/^[^\0]+//; if ( $dbline{$i} =~ s/^\0?$// ) { # Remove the entry altogether if no action is there. delete $dbline{$i}; } } ## end if (defined $dbline{$i... } ## end for ($i = 1 ; $i <= $max... # If, after we turn off the "there were breakpoints in this file" # bit, the entry in %had_breakpoints for this file is zero, # we should remove this file from the hash. if ( not $had_breakpoints{$file} &= ~1 ) { delete $had_breakpoints{$file}; } } ## end for my $file (keys %had_breakpoints) # Kill off all the other breakpoints that are waiting for files that # haven't been loaded yet. undef %postponed; undef %postponed_file; undef %break_on_load; } ## end else [ if (defined($i)) } ## end sub delete_breakpoint =head3 cmd_stop (command) This is meant to be part of the new command API, but it isn't called or used anywhere else in the debugger. XXX It is probably meant for use in development of new commands. =cut sub cmd_stop { # As on ^C, but not signal-safy. $signal = 1; } =head3 C - threads Display the current thread id: e This could be how (when implemented) to send commands to this thread id (e cmd) or that thread id (e tid cmd). =cut sub cmd_e { my $cmd = shift; my $line = shift; unless (exists($INC{'threads.pm'})) { print "threads not loaded($ENV{PERL5DB_THREADED}) please run the debugger with PERL5DB_THREADED=1 set in the environment\n"; } else { my $tid = threads->tid; print "thread id: $tid\n"; } } ## end sub cmd_e =head3 C - list of thread ids Display the list of available thread ids: E This could be used (when implemented) to send commands to all threads (E cmd). =cut sub cmd_E { my $cmd = shift; my $line = shift; unless (exists($INC{'threads.pm'})) { print "threads not loaded($ENV{PERL5DB_THREADED}) please run the debugger with PERL5DB_THREADED=1 set in the environment\n"; } else { my $tid = threads->tid; print "thread ids: ".join(', ', map { ($tid == $_->tid ? '<'.$_->tid.'>' : $_->tid) } threads->list )."\n"; } } ## end sub cmd_E =head3 C - help command (command) Does the work of either =over 4 =item * Showing all the debugger help =item * Showing help for a specific command =back =cut sub cmd_h { my $cmd = shift; # If we have no operand, assume null. my $line = shift || ''; # 'h h'. Print the long-format help. if ( $line =~ /^h\s*/ ) { print_help($help); } # 'h '. Search for the command and print only its help. elsif ( $line =~ /^(\S.*)$/ ) { # support long commands; otherwise bogus errors # happen when you ask for h on for example my $asked = $1; # the command requested # (for proper error message) my $qasked = quotemeta($asked); # for searching; we don't # want to use it as a pattern. # XXX: finds CR but not # Search the help string for the command. if ( $help =~ /^ # Start of a line is not a debugger command.\n"); } } ## end elsif ($line =~ /^(\S.*)$/) # 'h' - print the summary help. else { print_help($summary); } } ## end sub cmd_h =head3 C - inheritance display Display the (nested) parentage of the module or object given. =cut sub cmd_i { my $cmd = shift; my $line = shift; eval { require Class::ISA }; if ($@) { &warn( $@ =~ /locate/ ? "Class::ISA module not found - please install\n" : $@ ); } else { ISA: foreach my $isa ( split( /\s+/, $line ) ) { $evalarg = $isa; ($isa) = &eval; no strict 'refs'; print join( ', ', map { # snaffled unceremoniously from Class::ISA "$_" . ( defined( ${"$_\::VERSION"} ) ? ' ' . ${"$_\::VERSION"} : undef ) } Class::ISA::self_and_super_path(ref($isa) || $isa) ); print "\n"; } } } ## end sub cmd_i =head3 C - list lines (command) Most of the command is taken up with transforming all the different line specification syntaxes into 'start-stop'. After that is done, the command runs a loop over C<@dbline> for the specified range of lines. It handles the printing of each line and any markers (C<==E> for current line, C for break on this line, C for action on this line, C<:> for this line breakable). We save the last line listed in the C<$start> global for further listing later. =cut sub cmd_l { my $current_line = $line; my $cmd = shift; my $line = shift; # If this is '-something', delete any spaces after the dash. $line =~ s/^-\s*$/-/; # If the line is '$something', assume this is a scalar containing a # line number. if ( $line =~ /^(\$.*)/s ) { # Set up for DB::eval() - evaluate in *user* context. $evalarg = $1; # $evalarg = $2; my ($s) = &eval; # Ooops. Bad scalar. print( $OUT "Error: $@\n" ), next CMD if $@; # Good scalar. If it's a reference, find what it points to. $s = CvGV_name($s); print( $OUT "Interpreted as: $1 $s\n" ); $line = "$1 $s"; # Call self recursively to really do the command. &cmd_l( 'l', $s ); } ## end if ($line =~ /^(\$.*)/s) # l name. Try to find a sub by that name. elsif ( $line =~ /^([\':A-Za-z_][\':\w]*(\[.*\])?)/s ) { my $s = $subname = $1; # De-Perl4. $subname =~ s/\'/::/; # Put it in this package unless it starts with ::. $subname = $package . "::" . $subname unless $subname =~ /::/; # Put it in CORE::GLOBAL if t doesn't start with :: and # it doesn't live in this package and it lives in CORE::GLOBAL. $subname = "CORE::GLOBAL::$s" if not defined &$subname and $s !~ /::/ and defined &{"CORE::GLOBAL::$s"}; # Put leading '::' names into 'main::'. $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::"; # Get name:start-stop from find_sub, and break this up at # colons. @pieces = split( /:/, find_sub($subname) || $sub{$subname} ); # Pull off start-stop. $subrange = pop @pieces; # If the name contained colons, the split broke it up. # Put it back together. $file = join( ':', @pieces ); # If we're not in that file, switch over to it. if ( $file ne $filename ) { print $OUT "Switching to file '$file'.\n" unless $slave_editor; # Switch debugger's magic structures. *dbline = $main::{ '_<' . $file }; $max = $#dbline; $filename = $file; } ## end if ($file ne $filename) # Subrange is 'start-stop'. If this is less than a window full, # swap it to 'start+', which will list a window from the start point. if ($subrange) { if ( eval($subrange) < -$window ) { $subrange =~ s/-.*/+/; } # Call self recursively to list the range. $line = $subrange; &cmd_l( 'l', $subrange ); } ## end if ($subrange) # Couldn't find it. else { print $OUT "Subroutine $subname not found.\n"; } } ## end elsif ($line =~ /^([\':A-Za-z_][\':\w]*(\[.*\])?)/s) # Bare 'l' command. elsif ( $line =~ /^\s*$/ ) { # Compute new range to list. $incr = $window - 1; $line = $start . '-' . ( $start + $incr ); # Recurse to do it. &cmd_l( 'l', $line ); } # l [start]+number_of_lines elsif ( $line =~ /^(\d*)\+(\d*)$/ ) { # Don't reset start for 'l +nnn'. $start = $1 if $1; # Increment for list. Use window size if not specified. # (Allows 'l +' to work.) $incr = $2; $incr = $window - 1 unless $incr; # Create a line range we'll understand, and recurse to do it. $line = $start . '-' . ( $start + $incr ); &cmd_l( 'l', $line ); } ## end elsif ($line =~ /^(\d*)\+(\d*)$/) # l start-stop or l start,stop elsif ( $line =~ /^((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ ) { # Determine end point; use end of file if not specified. $end = ( !defined $2 ) ? $max : ( $4 ? $4 : $2 ); # Go on to the end, and then stop. $end = $max if $end > $max; # Determine start line. $i = $2; $i = $line if $i eq '.'; $i = 1 if $i < 1; $incr = $end - $i; # If we're running under a slave editor, force it to show the lines. if ($slave_editor) { print $OUT "\032\032$filename:$i:0\n"; $i = $end; } # We're doing it ourselves. We want to show the line and special # markers for: # - the current line in execution # - whether a line is breakable or not # - whether a line has a break or not # - whether a line has an action or not else { for ( ; $i <= $end ; $i++ ) { # Check for breakpoints and actions. my ( $stop, $action ); ( $stop, $action ) = split( /\0/, $dbline{$i} ) if $dbline{$i}; # ==> if this is the current line in execution, # : if it's breakable. $arrow = ( $i == $current_line and $filename eq $filename_ini ) ? '==>' : ( $dbline[$i] + 0 ? ':' : ' ' ); # Add break and action indicators. $arrow .= 'b' if $stop; $arrow .= 'a' if $action; # Print the line. print $OUT "$i$arrow\t", $dbline[$i]; # Move on to the next line. Drop out on an interrupt. $i++, last if $signal; } ## end for (; $i <= $end ; $i++) # Line the prompt up; print a newline if the last line listed # didn't have a newline. print $OUT "\n" unless $dbline[ $i - 1 ] =~ /\n$/; } ## end else [ if ($slave_editor) # Save the point we last listed to in case another relative 'l' # command is desired. Don't let it run off the end. $start = $i; $start = $max if $start > $max; } ## end elsif ($line =~ /^((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/) } ## end sub cmd_l =head3 C - list breakpoints, actions, and watch expressions (command) To list breakpoints, the command has to look determine where all of them are first. It starts a C<%had_breakpoints>, which tells us what all files have breakpoints and/or actions. For each file, we switch the C<*dbline> glob (the magic source and breakpoint data structures) to the file, and then look through C<%dbline> for lines with breakpoints and/or actions, listing them out. We look through C<%postponed> not-yet-compiled subroutines that have breakpoints, and through C<%postponed_file> for not-yet-C'd files that have breakpoints. Watchpoints are simpler: we just list the entries in C<@to_watch>. =cut sub cmd_L { my $cmd = shift; # If no argument, list everything. Pre-5.8.0 version always lists # everything my $arg = shift || 'abw'; $arg = 'abw' unless $CommandSet eq '580'; # sigh... # See what is wanted. my $action_wanted = ( $arg =~ /a/ ) ? 1 : 0; my $break_wanted = ( $arg =~ /b/ ) ? 1 : 0; my $watch_wanted = ( $arg =~ /w/ ) ? 1 : 0; # Breaks and actions are found together, so we look in the same place # for both. if ( $break_wanted or $action_wanted ) { # Look in all the files with breakpoints... for my $file ( keys %had_breakpoints ) { # Temporary switch to this file. local *dbline = $main::{ '_<' . $file }; # Set up to look through the whole file. my $max = $#dbline; my $was; # Flag: did we print something # in this file? # For each line in the file ... for ( $i = 1 ; $i <= $max ; $i++ ) { # We've got something on this line. if ( defined $dbline{$i} ) { # Print the header if we haven't. print $OUT "$file:\n" unless $was++; # Print the line. print $OUT " $i:\t", $dbline[$i]; # Pull out the condition and the action. ( $stop, $action ) = split( /\0/, $dbline{$i} ); # Print the break if there is one and it's wanted. print $OUT " break if (", $stop, ")\n" if $stop and $break_wanted; # Print the action if there is one and it's wanted. print $OUT " action: ", $action, "\n" if $action and $action_wanted; # Quit if the user hit interrupt. last if $signal; } ## end if (defined $dbline{$i... } ## end for ($i = 1 ; $i <= $max... } ## end for my $file (keys %had_breakpoints) } ## end if ($break_wanted or $action_wanted) # Look for breaks in not-yet-compiled subs: if ( %postponed and $break_wanted ) { print $OUT "Postponed breakpoints in subroutines:\n"; my $subname; for $subname ( keys %postponed ) { print $OUT " $subname\t$postponed{$subname}\n"; last if $signal; } } ## end if (%postponed and $break_wanted) # Find files that have not-yet-loaded breaks: my @have = map { # Combined keys keys %{ $postponed_file{$_} } } keys %postponed_file; # If there are any, list them. if ( @have and ( $break_wanted or $action_wanted ) ) { print $OUT "Postponed breakpoints in files:\n"; my ( $file, $line ); for $file ( keys %postponed_file ) { my $db = $postponed_file{$file}; print $OUT " $file:\n"; for $line ( sort { $a <=> $b } keys %$db ) { print $OUT " $line:\n"; my ( $stop, $action ) = split( /\0/, $$db{$line} ); print $OUT " break if (", $stop, ")\n" if $stop and $break_wanted; print $OUT " action: ", $action, "\n" if $action and $action_wanted; last if $signal; } ## end for $line (sort { $a <=>... last if $signal; } ## end for $file (keys %postponed_file) } ## end if (@have and ($break_wanted... if ( %break_on_load and $break_wanted ) { print $OUT "Breakpoints on load:\n"; my $file; for $file ( keys %break_on_load ) { print $OUT " $file\n"; last if $signal; } } ## end if (%break_on_load and... if ($watch_wanted) { if ( $trace & 2 ) { print $OUT "Watch-expressions:\n" if @to_watch; for my $expr (@to_watch) { print $OUT " $expr\n"; last if $signal; } } ## end if ($trace & 2) } ## end if ($watch_wanted) } ## end sub cmd_L =head3 C - list modules (command) Just call C. =cut sub cmd_M { &list_modules(); } =head3 C - options (command) If this is just C by itself, we list the current settings via C. If there's a nonblank value following it, we pass that on to C for processing. =cut sub cmd_o { my $cmd = shift; my $opt = shift || ''; # opt[=val] # Nonblank. Try to parse and process. if ( $opt =~ /^(\S.*)/ ) { &parse_options($1); } # Blank. List the current option settings. else { for (@options) { &dump_option($_); } } } ## end sub cmd_o =head3 C - nonexistent in 5.8.x (command) Advises the user that the O command has been renamed. =cut sub cmd_O { print $OUT "The old O command is now the o command.\n"; # hint print $OUT "Use 'h' to get current command help synopsis or\n"; # print $OUT "use 'o CommandSet=pre580' to revert to old usage\n"; # } =head3 C - view window (command) Uses the C<$preview> variable set in the second C block (q.v.) to move back a few lines to list the selected line in context. Uses C to do the actual listing after figuring out the range of line to request. =cut sub cmd_v { my $cmd = shift; my $line = shift; # Extract the line to list around. (Astute readers will have noted that # this pattern will match whether or not a numeric line is specified, # which means that we'll always enter this loop (though a non-numeric # argument results in no action at all)). if ( $line =~ /^(\d*)$/ ) { # Total number of lines to list (a windowful). $incr = $window - 1; # Set the start to the argument given (if there was one). $start = $1 if $1; # Back up by the context amount. $start -= $preview; # Put together a linespec that cmd_l will like. $line = $start . '-' . ( $start + $incr ); # List the lines. &cmd_l( 'l', $line ); } ## end if ($line =~ /^(\d*)$/) } ## end sub cmd_v =head3 C - add a watch expression (command) The 5.8 version of this command adds a watch expression if one is specified; it does nothing if entered with no operands. We extract the expression, save it, evaluate it in the user's context, and save the value. We'll re-evaluate it each time the debugger passes a line, and will stop (see the code at the top of the command loop) if the value of any of the expressions changes. =cut sub cmd_w { my $cmd = shift; # Null expression if no arguments. my $expr = shift || ''; # If expression is not null ... if ( $expr =~ /^(\S.*)/ ) { # ... save it. push @to_watch, $expr; # Parameterize DB::eval and call it to get the expression's value # in the user's context. This version can handle expressions which # return a list value. $evalarg = $expr; my ($val) = join( ' ', &eval ); $val = ( defined $val ) ? "'$val'" : 'undef'; # Save the current value of the expression. push @old_watch, $val; # We are now watching expressions. $trace |= 2; } ## end if ($expr =~ /^(\S.*)/) # You have to give one to get one. else { print $OUT "Adding a watch-expression requires an expression\n"; # hint } } ## end sub cmd_w =head3 C - delete watch expressions (command) This command accepts either a watch expression to be removed from the list of watch expressions, or C<*> to delete them all. If C<*> is specified, we simply empty the watch expression list and the watch expression value list. We also turn off the bit that says we've got watch expressions. If an expression (or partial expression) is specified, we pattern-match through the expressions and remove the ones that match. We also discard the corresponding values. If no watch expressions are left, we turn off the I bit. =cut sub cmd_W { my $cmd = shift; my $expr = shift || ''; # Delete them all. if ( $expr eq '*' ) { # Not watching now. $trace &= ~2; print $OUT "Deleting all watch expressions ...\n"; # And all gone. @to_watch = @old_watch = (); } # Delete one of them. elsif ( $expr =~ /^(\S.*)/ ) { # Where we are in the list. my $i_cnt = 0; # For each expression ... foreach (@to_watch) { my $val = $to_watch[$i_cnt]; # Does this one match the command argument? if ( $val eq $expr ) { # =~ m/^\Q$i$/) { # Yes. Turn it off, and its value too. splice( @to_watch, $i_cnt, 1 ); splice( @old_watch, $i_cnt, 1 ); } $i_cnt++; } ## end foreach (@to_watch) # We don't bother to turn watching off because # a) we don't want to stop calling watchfunction() it it exists # b) foreach over a null list doesn't do anything anyway } ## end elsif ($expr =~ /^(\S.*)/) # No command arguments entered. else { print $OUT "Deleting a watch-expression requires an expression, or '*' for all\n" ; # hint } } ## end sub cmd_W ### END of the API section =head1 SUPPORT ROUTINES These are general support routines that are used in a number of places throughout the debugger. =head2 save save() saves the user's versions of globals that would mess us up in C<@saved>, and installs the versions we like better. =cut sub save { # Save eval failure, command failure, extended OS error, output field # separator, input record separator, output record separator and # the warning setting. @saved = ( $@, $!, $^E, $,, $/, $\, $^W ); $, = ""; # output field separator is null string $/ = "\n"; # input record separator is newline $\ = ""; # output record separator is null string $^W = 0; # warnings are off } ## end sub save =head2 C - show where we are now print_lineinfo prints whatever it is that it is handed; it prints it to the C<$LINEINFO> filehandle instead of just printing it to STDOUT. This allows us to feed line information to a slave editor without messing up the debugger output. =cut sub print_lineinfo { # Make the terminal sensible if we're not the primary debugger. resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$; local $\ = ''; local $, = ''; print $LINEINFO @_; } ## end sub print_lineinfo =head2 C Handles setting postponed breakpoints in subroutines once they're compiled. For breakpoints, we use C to locate the source file and line range for the subroutine, then mark the file as having a breakpoint, temporarily switch the C<*dbline> glob over to the source file, and then search the given range of lines to find a breakable line. If we find one, we set the breakpoint on it, deleting the breakpoint from C<%postponed>. =cut # The following takes its argument via $evalarg to preserve current @_ sub postponed_sub { # Get the subroutine name. my $subname = shift; # If this is a 'break + if ' ... if ( $postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s// ) { # If there's no offset, use '+0'. my $offset = $1 || 0; # find_sub's value is 'fullpath-filename:start-stop'. It's # possible that the filename might have colons in it too. my ( $file, $i ) = ( find_sub($subname) =~ /^(.*):(\d+)-.*$/ ); if ($i) { # We got the start line. Add the offset '+' from # $postponed{subname}. $i += $offset; # Switch to the file this sub is in, temporarily. local *dbline = $main::{ '_<' . $file }; # No warnings, please. local $^W = 0; # != 0 is magical below # This file's got a breakpoint in it. $had_breakpoints{$file} |= 1; # Last line in file. my $max = $#dbline; # Search forward until we hit a breakable line or get to # the end of the file. ++$i until $dbline[$i] != 0 or $i >= $max; # Copy the breakpoint in and delete it from %postponed. $dbline{$i} = delete $postponed{$subname}; } ## end if ($i) # find_sub didn't find the sub. else { local $\ = ''; print $OUT "Subroutine $subname not found.\n"; } return; } ## end if ($postponed{$subname... elsif ( $postponed{$subname} eq 'compile' ) { $signal = 1 } #print $OUT "In postponed_sub for `$subname'.\n"; } ## end sub postponed_sub =head2 C Called after each required file is compiled, but before it is executed; also called if the name of a just-compiled subroutine is a key of C<%postponed>. Propagates saved breakpoints (from C, C, etc.) into the just-compiled code. If this is a C'd file, the incoming parameter is the glob C<*{"_<$filename"}>, with C<$filename> the name of the C'd file. If it's a subroutine, the incoming parameter is the subroutine name. =cut sub postponed { # If there's a break, process it. if ($ImmediateStop) { # Right, we've stopped. Turn it off. $ImmediateStop = 0; # Enter the command loop when DB::DB gets called. $signal = 1; } # If this is a subroutine, let postponed_sub() deal with it. return &postponed_sub unless ref \$_[0] eq 'GLOB'; # Not a subroutine. Deal with the file. local *dbline = shift; my $filename = $dbline; $filename =~ s/^_ C is the debugger's wrapper around dumpvar.pl. It gets a filehandle (to which C's output will be directed) and a reference to a variable (the thing to be dumped) as its input. The incoming filehandle is selected for output (C is printing to the currently-selected filehandle, thank you very much). The current values of the package globals C<$single> and C<$trace> are backed up in lexicals, and they are turned off (this keeps the debugger from trying to single-step through C (I think.)). C<$frame> is localized to preserve its current value and it is set to zero to prevent entry/exit messages from printing, and C<$doret> is localized as well and set to -2 to prevent return values from being shown. C then checks to see if it needs to load C and tries to load it (note: if you have a C ahead of the installed version in C<@INC>, yours will be used instead. Possible security problem?). It then checks to see if the subroutine C is now defined (it should have been defined by C). If it has, C localizes the globals necessary for things to be sane when C is called, and picks up the variable to be dumped from the parameter list. It checks the package global C<%options> to see if there's a C specified. If not, -1 is assumed; if so, the supplied value gets passed on to C. This tells C where to leave off when dumping a structure: -1 means dump everything. C is then called if possible; if not, Cjust prints a warning. In either case, C<$single>, C<$trace>, C<$frame>, and C<$doret> are restored and we then return to the caller. =cut sub dumpit { # Save the current output filehandle and switch to the one # passed in as the first parameter. local ($savout) = select(shift); # Save current settings of $single and $trace, and then turn them off. my $osingle = $single; my $otrace = $trace; $single = $trace = 0; # XXX Okay, what do $frame and $doret do, again? local $frame = 0; local $doret = -2; # Load dumpvar.pl unless we've already got the sub we need from it. unless ( defined &main::dumpValue ) { do 'dumpvar.pl' or die $@; } # If the load succeeded (or we already had dumpvalue()), go ahead # and dump things. if ( defined &main::dumpValue ) { local $\ = ''; local $, = ''; local $" = ' '; my $v = shift; my $maxdepth = shift || $option{dumpDepth}; $maxdepth = -1 unless defined $maxdepth; # -1 means infinite depth &main::dumpValue( $v, $maxdepth ); } ## end if (defined &main::dumpValue) # Oops, couldn't load dumpvar.pl. else { local $\ = ''; print $OUT "dumpvar.pl not available.\n"; } # Reset $single and $trace to their old values. $single = $osingle; $trace = $otrace; # Restore the old filehandle. select($savout); } ## end sub dumpit =head2 C C's job is to print a stack trace. It does this via the C routine, which actually does all the ferreting-out of the stack trace data. C takes care of formatting it nicely and printing it to the proper filehandle. Parameters: =over 4 =item * The filehandle to print to. =item * How many frames to skip before starting trace. =item * How many frames to print. =item * A flag: if true, print a I trace without filenames, line numbers, or arguments =back The original comment below seems to be noting that the traceback may not be correct if this routine is called in a tied method. =cut # Tied method do not create a context, so may get wrong message: sub print_trace { local $\ = ''; my $fh = shift; # If this is going to a slave editor, but we're not the primary # debugger, reset it first. resetterm(1) if $fh eq $LINEINFO # slave editor and $LINEINFO eq $OUT # normal output and $term_pid != $$; # not the primary # Collect the actual trace information to be formatted. # This is an array of hashes of subroutine call info. my @sub = dump_trace( $_[0] + 1, $_[1] ); # Grab the "short report" flag from @_. my $short = $_[2]; # Print short report, next one for sub name # Run through the traceback info, format it, and print it. my $s; for ( $i = 0 ; $i <= $#sub ; $i++ ) { # Drop out if the user has lost interest and hit control-C. last if $signal; # Set the separator so arrys print nice. local $" = ', '; # Grab and stringify the arguments if they are there. my $args = defined $sub[$i]{args} ? "(@{ $sub[$i]{args} })" : ''; # Shorten them up if $maxtrace says they're too long. $args = ( substr $args, 0, $maxtrace - 3 ) . '...' if length $args > $maxtrace; # Get the file name. my $file = $sub[$i]{file}; # Put in a filename header if short is off. $file = $file eq '-e' ? $file : "file `$file'" unless $short; # Get the actual sub's name, and shorten to $maxtrace's requirement. $s = $sub[$i]{sub}; $s = ( substr $s, 0, $maxtrace - 3 ) . '...' if length $s > $maxtrace; # Short report uses trimmed file and sub names. if ($short) { my $sub = @_ >= 4 ? $_[3] : $s; print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n"; } ## end if ($short) # Non-short report includes full names. else { print $fh "$sub[$i]{context} = $s$args" . " called from $file" . " line $sub[$i]{line}\n"; } } ## end for ($i = 0 ; $i <= $#sub... } ## end sub print_trace =head2 dump_trace(skip[,count]) Actually collect the traceback information available via C. It does some filtering and cleanup of the data, but mostly it just collects it to make C's job easier. C defines the number of stack frames to be skipped, working backwards from the most current. C determines the total number of frames to be returned; all of them (well, the first 10^9) are returned if C is omitted. This routine returns a list of hashes, from most-recent to least-recent stack frame. Each has the following keys and values: =over 4 =item * C - C<.> (null), C<$> (scalar), or C<@> (array) =item * C - subroutine name, or C information =item * C - undef, or a reference to an array of arguments =item * C - the file in which this item was defined (if any) =item * C - the line on which it was defined =back =cut sub dump_trace { # How many levels to skip. my $skip = shift; # How many levels to show. (1e9 is a cheap way of saying "all of them"; # it's unlikely that we'll have more than a billion stack frames. If you # do, you've got an awfully big machine...) my $count = shift || 1e9; # We increment skip because caller(1) is the first level *back* from # the current one. Add $skip to the count of frames so we have a # simple stop criterion, counting from $skip to $count+$skip. $skip++; $count += $skip; # These variables are used to capture output from caller(); my ( $p, $file, $line, $sub, $h, $context ); my ( $e, $r, @a, @sub, $args ); # XXX Okay... why'd we do that? my $nothard = not $frame & 8; local $frame = 0; # Do not want to trace this. my $otrace = $trace; $trace = 0; # Start out at the skip count. # If we haven't reached the number of frames requested, and caller() is # still returning something, stay in the loop. (If we pass the requested # number of stack frames, or we run out - caller() returns nothing - we # quit. # Up the stack frame index to go back one more level each time. for ( $i = $skip ; $i < $count and ( $p, $file, $line, $sub, $h, $context, $e, $r ) = caller($i) ; $i++ ) { # Go through the arguments and save them for later. @a = (); for $arg (@args) { my $type; if ( not defined $arg ) { # undefined parameter push @a, "undef"; } elsif ( $nothard and tied $arg ) { # tied parameter push @a, "tied"; } elsif ( $nothard and $type = ref $arg ) { # reference push @a, "ref($type)"; } else { # can be stringified local $_ = "$arg"; # Safe to stringify now - should not call f(). # Backslash any single-quotes or backslashes. s/([\'\\])/\\$1/g; # Single-quote it unless it's a number or a colon-separated # name. s/(.*)/'$1'/s unless /^(?: -?[\d.]+ | \*[\w:]* )$/x; # Turn high-bit characters into meta-whatever. s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; # Turn control characters into ^-whatever. s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; push( @a, $_ ); } ## end else [ if (not defined $arg) } ## end for $arg (@args) # If context is true, this is array (@)context. # If context is false, this is scalar ($) context. # If neither, context isn't defined. (This is apparently a 'can't # happen' trap.) $context = $context ? '@' : ( defined $context ? "\$" : '.' ); # if the sub has args ($h true), make an anonymous array of the # dumped args. $args = $h ? [@a] : undef; # remove trailing newline-whitespace-semicolon-end of line sequence # from the eval text, if any. $e =~ s/\n\s*\;\s*\Z// if $e; # Escape backslashed single-quotes again if necessary. $e =~ s/([\\\'])/\\$1/g if $e; # if the require flag is true, the eval text is from a require. if ($r) { $sub = "require '$e'"; } # if it's false, the eval text is really from an eval. elsif ( defined $r ) { $sub = "eval '$e'"; } # If the sub is '(eval)', this is a block eval, meaning we don't # know what the eval'ed text actually was. elsif ( $sub eq '(eval)' ) { $sub = "eval {...}"; } # Stick the collected information into @sub as an anonymous hash. push( @sub, { context => $context, sub => $sub, args => $args, file => $file, line => $line } ); # Stop processing frames if the user hit control-C. last if $signal; } ## end for ($i = $skip ; $i < ... # Restore the trace value again. $trace = $otrace; @sub; } ## end sub dump_trace =head2 C C takes input provided as the argument to an add-action command, either pre- or post-, and makes sure it's a complete command. It doesn't do any fancy parsing; it just keeps reading input until it gets a string without a trailing backslash. =cut sub action { my $action = shift; while ( $action =~ s/\\$// ) { # We have a backslash on the end. Read more. $action .= &gets; } ## end while ($action =~ s/\\$//) # Return the assembled action. $action; } ## end sub action =head2 unbalanced This routine mostly just packages up a regular expression to be used to check that the thing it's being matched against has properly-matched curly braces. Of note is the definition of the C<$balanced_brace_re> global via C<||=>, which speeds things up by only creating the qr//'ed expression once; if it's already defined, we don't try to define it again. A speed hack. =cut sub unbalanced { # I hate using globals! $balanced_brace_re ||= qr{ ^ \{ (?: (?> [^{}] + ) # Non-parens without backtracking | (??{ $balanced_brace_re }) # Group with matching parens ) * \} $ }x; return $_[0] !~ m/$balanced_brace_re/; } ## end sub unbalanced =head2 C C is a primitive (very primitive) routine to read continuations. It was devised for reading continuations for actions. it just reads more input with C and returns it. =cut sub gets { &readline("cont: "); } =head2 C - handle calls to without messing up the debugger The C function assumes that it can just go ahead and use STDIN and STDOUT, but under the debugger, we want it to use the debugger's input and outout filehandles. C socks away the program's STDIN and STDOUT, and then substitutes the debugger's IN and OUT filehandles for them. It does the C call, and then puts everything back again. =cut sub system { # We save, change, then restore STDIN and STDOUT to avoid fork() since # some non-Unix systems can do system() but have problems with fork(). open( SAVEIN, "<&STDIN" ) || &warn("Can't save STDIN"); open( SAVEOUT, ">&STDOUT" ) || &warn("Can't save STDOUT"); open( STDIN, "<&IN" ) || &warn("Can't redirect STDIN"); open( STDOUT, ">&OUT" ) || &warn("Can't redirect STDOUT"); # XXX: using csh or tcsh destroys sigint retvals! system(@_); open( STDIN, "<&SAVEIN" ) || &warn("Can't restore STDIN"); open( STDOUT, ">&SAVEOUT" ) || &warn("Can't restore STDOUT"); close(SAVEIN); close(SAVEOUT); # most of the $? crud was coping with broken cshisms if ( $? >> 8 ) { &warn( "(Command exited ", ( $? >> 8 ), ")\n" ); } elsif ($?) { &warn( "(Command died of SIG#", ( $? & 127 ), ( ( $? & 128 ) ? " -- core dumped" : "" ), ")", "\n" ); } ## end elsif ($?) return $?; } ## end sub system =head1 TTY MANAGEMENT The subs here do some of the terminal management for multiple debuggers. =head2 setterm Top-level function called when we want to set up a new terminal for use by the debugger. If the C debugger option was set, we'll either use the terminal supplied (the value of the C option), or we'll use C to find one. If we're a forked debugger, we call C to try to get a whole new terminal if we can. In either case, we set up the terminal next. If the C option was true, we'll get a C object for the current terminal and save the appropriate attributes. We then =cut sub setterm { # Load Term::Readline, but quietly; don't debug it and don't trace it. local $frame = 0; local $doret = -2; eval { require Term::ReadLine } or die $@; # If noTTY is set, but we have a TTY name, go ahead and hook up to it. if ($notty) { if ($tty) { my ( $i, $o ) = split $tty, /,/; $o = $i unless defined $o; open( IN, "<$i" ) or die "Cannot open TTY `$i' for read: $!"; open( OUT, ">$o" ) or die "Cannot open TTY `$o' for write: $!"; $IN = \*IN; $OUT = \*OUT; my $sel = select($OUT); $| = 1; select($sel); } ## end if ($tty) # We don't have a TTY - try to find one via Term::Rendezvous. else { eval "require Term::Rendezvous;" or die; # See if we have anything to pass to Term::Rendezvous. # Use $HOME/.perldbtty$$ if not. my $rv = $ENV{PERLDB_NOTTY} || "$ENV{HOME}/.perldbtty$$"; # Rendezvous and get the filehandles. my $term_rv = new Term::Rendezvous $rv; $IN = $term_rv->IN; $OUT = $term_rv->OUT; } ## end else [ if ($tty) } ## end if ($notty) # We're a daughter debugger. Try to fork off another TTY. if ( $term_pid eq '-1' ) { # In a TTY with another debugger resetterm(2); } # If we shouldn't use Term::ReadLine, don't. if ( !$rl ) { $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT; } # We're using Term::ReadLine. Get all the attributes for this terminal. else { $term = new Term::ReadLine 'perldb', $IN, $OUT; $rl_attribs = $term->Attribs; $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}' if defined $rl_attribs->{basic_word_break_characters} and index( $rl_attribs->{basic_word_break_characters}, ":" ) == -1; $rl_attribs->{special_prefixes} = '$@&%'; $rl_attribs->{completer_word_break_characters} .= '$@&%'; $rl_attribs->{completion_function} = \&db_complete; } ## end else [ if (!$rl) # Set up the LINEINFO filehandle. $LINEINFO = $OUT unless defined $LINEINFO; $lineinfo = $console unless defined $lineinfo; $term->MinLine(2); &load_hist(); if ( $term->Features->{setHistory} and "@hist" ne "?" ) { $term->SetHistory(@hist); } # XXX Ornaments are turned on unconditionally, which is not # always a good thing. ornaments($ornaments) if defined $ornaments; $term_pid = $$; } ## end sub setterm sub load_hist { $histfile //= option_val("HistFile", undef); return unless defined $histfile; open my $fh, "<", $histfile or return; local $/ = "\n"; @hist = (); while (<$fh>) { chomp; push @hist, $_; } close $fh; } sub save_hist { return unless defined $histfile; eval { require File::Path } or return; eval { require File::Basename } or return; File::Path::mkpath(File::Basename::dirname($histfile)); open my $fh, ">", $histfile or die "Could not open '$histfile': $!"; $histsize //= option_val("HistSize",100); my @copy = grep { $_ ne '?' } @hist; my $start = scalar(@copy) > $histsize ? scalar(@copy)-$histsize : 0; for ($start .. $#copy) { print $fh "$copy[$_]\n"; } close $fh or die "Could not write '$histfile': $!"; } =head1 GET_FORK_TTY EXAMPLE FUNCTIONS When the process being debugged forks, or the process invokes a command via C which starts a new debugger, we need to be able to get a new C and C filehandle for the new debugger. Otherwise, the two processes fight over the terminal, and you can never quite be sure who's going to get the input you're typing. C is a glob-aliased function which calls the real function that is tasked with doing all the necessary operating system mojo to get a new TTY (and probably another window) and to direct the new debugger to read and write there. The debugger provides C functions which work for X Windows, OS/2, and Mac OS X. Other systems are not supported. You are encouraged to write C functions which work for I platform and contribute them. =head3 C This function provides the C function for X windows. If a program running under the debugger forks, a new window is opened and the subsidiary debugger is directed there. The C call is of particular note here. We have the new C we're spawning route file number 3 to STDOUT, and then execute the C command (which prints the device name of the TTY we'll want to use for input and output to STDOUT, then C for a very long time, routing this output to file number 3. This way we can simply read from the filehandle (which is STDOUT from the I we ran) to get the TTY we want to use. Only works if C is in your path and C<$ENV{DISPLAY}>, etc. are properly set up. =cut sub xterm_get_fork_TTY { ( my $name = $0 ) =~ s,^.*[/\\],,s; open XT, qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\ sleep 10000000' |]; # Get the output from 'tty' and clean it up a little. my $tty = ; chomp $tty; $pidprompt = ''; # Shown anyway in titlebar # We need $term defined or we can not switch to the newly created xterm if ($tty ne '' && !defined $term) { eval { require Term::ReadLine } or die $@; if ( !$rl ) { $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT; } else { $term = new Term::ReadLine 'perldb', $IN, $OUT; } } # There's our new TTY. return $tty; } ## end sub xterm_get_fork_TTY =head3 C XXX It behooves an OS/2 expert to write the necessary documentation for this! =cut # This example function resets $IN, $OUT itself my $c_pipe = 0; sub os2_get_fork_TTY { # A simplification of the following (and works without): local $\ = ''; ( my $name = $0 ) =~ s,^.*[/\\],,s; my %opt = ( title => "Daughter Perl debugger $pids $name", ($rl ? (read_by_key => 1) : ()) ); require OS2::Process; my ($in, $out, $pid) = eval { OS2::Process::io_term(related => 0, %opt) } or return; $pidprompt = ''; # Shown anyway in titlebar reset_IN_OUT($in, $out); $tty = '*reset*'; return ''; # Indicate that reset_IN_OUT is called } ## end sub os2_get_fork_TTY =head3 C The Mac OS X version uses AppleScript to tell Terminal.app to create a new window. =cut # Notes about Terminal.app's AppleScript support, # (aka things that might break in future OS versions). # # The "do script" command doesn't return a reference to the new window # it creates, but since it appears frontmost and windows are enumerated # front to back, we can use "first window" === "window 1". # # Since "do script" is implemented by supplying the argument (plus a # return character) as terminal input, there's a potential race condition # where the debugger could beat the shell to reading the command. # To prevent this, we wait for the screen to clear before proceeding. # # 10.3 and 10.4: # There's no direct accessor for the tty device name, so we fiddle # with the window title options until it says what we want. # # 10.5: # There _is_ a direct accessor for the tty device name, _and_ there's # a new possible component of the window title (the name of the settings # set). A separate version is needed. my @script_versions= ([237, <<'__LEOPARD__'], tell application "Terminal" do script "clear;exec sleep 100000" tell first tab of first window copy tty to thetty set custom title to "forked perl debugger" set title displays custom title to true repeat while (length of first paragraph of (get contents)) > 0 delay 0.1 end repeat end tell end tell thetty __LEOPARD__ [100, <<'__JAGUAR_TIGER__'], tell application "Terminal" do script "clear;exec sleep 100000" tell first window set title displays shell path to false set title displays window size to false set title displays file name to false set title displays device name to true set title displays custom title to true set custom title to "" copy "/dev/" & name to thetty set custom title to "forked perl debugger" repeat while (length of first paragraph of (get contents)) > 0 delay 0.1 end repeat end tell end tell thetty __JAGUAR_TIGER__ ); sub macosx_get_fork_TTY { my($version,$script,$pipe,$tty); return unless $version=$ENV{TERM_PROGRAM_VERSION}; foreach my $entry (@script_versions) { if ($version>=$entry->[0]) { $script=$entry->[1]; last; } } return unless defined($script); return unless open($pipe,'-|','/usr/bin/osascript','-e',$script); $tty=readline($pipe); close($pipe); return unless defined($tty) && $tty =~ m(^/dev/); chomp $tty; return $tty; } =head2 C Create a new pair of filehandles, pointing to a new TTY. If impossible, try to diagnose why. Flags are: =over 4 =item * 1 - Don't know how to create a new TTY. =item * 2 - Debugger has forked, but we can't get a new TTY. =item * 4 - standard debugger startup is happening. =back =cut sub create_IN_OUT { # Create a window with IN/OUT handles redirected there # If we know how to get a new TTY, do it! $in will have # the TTY name if get_fork_TTY works. my $in = &get_fork_TTY if defined &get_fork_TTY; # It used to be that $in = $fork_TTY if defined $fork_TTY; # Backward compatibility if ( not defined $in ) { my $why = shift; # We don't know how. print_help(< Forked, but do not know how to create a new B. I<#########> EOP # Forked debugger. print_help(< Daughter session, do not know how to change a B. I<#########> This may be an asynchronous session, so the parent debugger may be active. EOP # Note that both debuggers are fighting over the same input. print_help(< in B<\$DB::fork_TTY>, or define a function B returning this. On I-like systems one can get the name of a I for the given window by typing B, and disconnect the I from I by B. EOP } ## end if (not defined $in) elsif ( $in ne '' ) { TTY($in); } else { $console = ''; # Indicate no need to open-from-the-console } undef $fork_TTY; } ## end sub create_IN_OUT =head2 C Handles rejiggering the prompt when we've forked off a new debugger. If the new debugger happened because of a C that invoked a program under the debugger, the arrow between the old pid and the new in the prompt has I dashes instead of one. We take the current list of pids and add this one to the end. If there isn't any list yet, we make one up out of the initial pid associated with the terminal and our new pid, sticking an arrow (either one-dashed or two dashed) in between them. If C is off, or C was called with no arguments, we don't try to create a new IN and OUT filehandle. Otherwise, we go ahead and try to do that. =cut sub resetterm { # We forked, so we need a different TTY # Needs to be passed to create_IN_OUT() as well. my $in = shift; # resetterm(2): got in here because of a system() starting a debugger. # resetterm(1): just forked. my $systemed = $in > 1 ? '-' : ''; # If there's already a list of pids, add this to the end. if ($pids) { $pids =~ s/\]/$systemed->$$]/; } # No pid list. Time to make one. else { $pids = "[$term_pid->$$]"; } # The prompt we're going to be using for this debugger. $pidprompt = $pids; # We now 0wnz this terminal. $term_pid = $$; # Just return if we're not supposed to try to create a new TTY. return unless $CreateTTY & $in; # Try to create a new IN/OUT pair. create_IN_OUT($in); } ## end sub resetterm =head2 C First, we handle stuff in the typeahead buffer. If there is any, we shift off the next line, print a message saying we got it, add it to the terminal history (if possible), and return it. If there's nothing in the typeahead buffer, check the command filehandle stack. If there are any filehandles there, read from the last one, and return the line if we got one. If not, we pop the filehandle off and close it, and try the next one up the stack. If we've emptied the filehandle stack, we check to see if we've got a socket open, and we read that and return it if we do. If we don't, we just call the core C and return its value. =cut sub readline { # Localize to prevent it from being smashed in the program being debugged. local $.; # Pull a line out of the typeahead if there's stuff there. if (@typeahead) { # How many lines left. my $left = @typeahead; # Get the next line. my $got = shift @typeahead; # Print a message saying we got input from the typeahead. local $\ = ''; print $OUT "auto(-$left)", shift, $got, "\n"; # Add it to the terminal history (if possible). $term->AddHistory($got) if length($got) > 1 and defined $term->Features->{addHistory}; return $got; } ## end if (@typeahead) # We really need to read some input. Turn off entry/exit trace and # return value printing. local $frame = 0; local $doret = -2; # If there are stacked filehandles to read from ... while (@cmdfhs) { # Read from the last one in the stack. my $line = CORE::readline( $cmdfhs[-1] ); # If we got a line ... defined $line ? ( print $OUT ">> $line" and return $line ) # Echo and return : close pop @cmdfhs; # Pop and close } ## end while (@cmdfhs) # Nothing on the filehandle stack. Socket? if ( ref $OUT and UNIVERSAL::isa( $OUT, 'IO::Socket::INET' ) ) { # Send anyting we have to send. $OUT->write( join( '', @_ ) ); # Receive anything there is to receive. $stuff; my $stuff = ''; my $buf; do { $IN->recv( $buf = '', 2048 ); # XXX "what's wrong with sysread?" # XXX Don't know. You tell me. } while length $buf and ($stuff .= $buf) !~ /\n/; # What we got. $stuff; } ## end if (ref $OUT and UNIVERSAL::isa... # No socket. Just read from the terminal. else { $term->readline(@_); } } ## end sub readline =head1 OPTIONS SUPPORT ROUTINES These routines handle listing and setting option values. =head2 C - list the current value of an option setting This routine uses C to look up the value for an option. It cleans up escaped single-quotes and then displays the option and its value. =cut sub dump_option { my ( $opt, $val ) = @_; $val = option_val( $opt, 'N/A' ); $val =~ s/([\\\'])/\\$1/g; printf $OUT "%20s = '%s'\n", $opt, $val; } ## end sub dump_option sub options2remember { foreach my $k (@RememberOnROptions) { $option{$k} = option_val( $k, 'N/A' ); } return %option; } =head2 C - find the current value of an option This can't just be a simple hash lookup because of the indirect way that the option values are stored. Some are retrieved by calling a subroutine, some are just variables. You must supply a default value to be used in case the option isn't set. =cut sub option_val { my ( $opt, $default ) = @_; my $val; # Does this option exist, and is it a variable? # If so, retrieve the value via the value in %optionVars. if ( defined $optionVars{$opt} and defined ${ $optionVars{$opt} } ) { $val = ${ $optionVars{$opt} }; } # Does this option exist, and it's a subroutine? # If so, call the subroutine via the ref in %optionAction # and capture the value. elsif ( defined $optionAction{$opt} and defined &{ $optionAction{$opt} } ) { $val = &{ $optionAction{$opt} }(); } # If there's an action or variable for the supplied option, # but no value was set, use the default. elsif (defined $optionAction{$opt} and not defined $option{$opt} or defined $optionVars{$opt} and not defined ${ $optionVars{$opt} } ) { $val = $default; } # Otherwise, do the simple hash lookup. else { $val = $option{$opt}; } # If the value isn't defined, use the default. # Then return whatever the value is. $val = $default unless defined $val; $val; } ## end sub option_val =head2 C Handles the parsing and execution of option setting/displaying commands. An option entered by itself is assumed to be I (the default value) if the option is a boolean one. If not, the user is prompted to enter a valid value or to query the current value (via C). If C is entered, we try to extract a quoted string from the value (if it is quoted). If it's not, we just use the whole value as-is. We load any modules required to service this option, and then we set it: if it just gets stuck in a variable, we do that; if there's a subroutine to handle setting the option, we call that. Finally, if we're running in interactive mode, we display the effect of the user's command back to the terminal, skipping this if we're setting things during initialization. =cut sub parse_options { local ($_) = @_; local $\ = ''; # These options need a value. Don't allow them to be clobbered by accident. my %opt_needs_val = map { ( $_ => 1 ) } qw{ dumpDepth arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize pager quote ReadLine recallCommand RemotePort ShellBang TTY CommandSet }; while (length) { my $val_defaulted; # Clean off excess leading whitespace. s/^\s+// && next; # Options are always all word characters, followed by a non-word # separator. s/^(\w+)(\W?)// or print( $OUT "Invalid option `$_'\n" ), last; my ( $opt, $sep ) = ( $1, $2 ); # Make sure that such an option exists. my $matches = grep( /^\Q$opt/ && ( $option = $_ ), @options ) || grep( /^\Q$opt/i && ( $option = $_ ), @options ); print( $OUT "Unknown option `$opt'\n" ), next unless $matches; print( $OUT "Ambiguous option `$opt'\n" ), next if $matches > 1; my $val; # '?' as separator means query, but must have whitespace after it. if ( "?" eq $sep ) { print( $OUT "Option query `$opt?' followed by non-space `$_'\n" ), last if /^\S/; #&dump_option($opt); } ## end if ("?" eq $sep) # Separator is whitespace (or just a carriage return). # They're going for a default, which we assume is 1. elsif ( $sep !~ /\S/ ) { $val_defaulted = 1; $val = "1"; # this is an evil default; make 'em set it! } # Separator is =. Trying to set a value. elsif ( $sep eq "=" ) { # If quoted, extract a quoted string. if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) { my $quote = $1; ( $val = $2 ) =~ s/\\([$quote\\])/$1/g; } # Not quoted. Use the whole thing. Warn about 'option='. else { s/^(\S*)//; $val = $1; print OUT qq(Option better cleared using $opt=""\n) unless length $val; } ## end else [ if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) } ## end elsif ($sep eq "=") # "Quoted" with [], <>, or {}. else { #{ to "let some poor schmuck bounce on the % key in B." my ($end) = "\\" . substr( ")]>}$sep", index( "([<{", $sep ), 1 ); #} s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or print( $OUT "Unclosed option value `$opt$sep$_'\n" ), last; ( $val = $1 ) =~ s/\\([\\$end])/$1/g; } ## end else [ if ("?" eq $sep) # Exclude non-booleans from getting set to 1 by default. if ( $opt_needs_val{$option} && $val_defaulted ) { my $cmd = ( $CommandSet eq '580' ) ? 'o' : 'O'; print $OUT "Option `$opt' is non-boolean. Use `$cmd $option=VAL' to set, `$cmd $option?' to query\n"; next; } ## end if ($opt_needs_val{$option... # Save the option value. $option{$option} = $val if defined $val; # Load any module that this option requires. eval qq{ local \$frame = 0; local \$doret = -2; require '$optionRequire{$option}'; 1; } || die # XXX: shouldn't happen if defined $optionRequire{$option} && defined $val; # Set it. # Stick it in the proper variable if it goes in a variable. ${ $optionVars{$option} } = $val if defined $optionVars{$option} && defined $val; # Call the appropriate sub if it gets set via sub. &{ $optionAction{$option} }($val) if defined $optionAction{$option} && defined &{ $optionAction{$option} } && defined $val; # Not initialization - echo the value we set it to. dump_option($option) unless $OUT eq \*STDERR; } ## end while (length) } ## end sub parse_options =head1 RESTART SUPPORT These routines are used to store (and restore) lists of items in environment variables during a restart. =head2 set_list Set_list packages up items to be stored in a set of environment variables (VAR_n, containing the number of items, and VAR_0, VAR_1, etc., containing the values). Values outside the standard ASCII charset are stored by encoding then as hexadecimal values. =cut sub set_list { my ( $stem, @list ) = @_; my $val; # VAR_n: how many we have. Scalar assignment gets the number of items. $ENV{"${stem}_n"} = @list; # Grab each item in the list, escape the backslashes, encode the non-ASCII # as hex, and then save in the appropriate VAR_0, VAR_1, etc. for $i ( 0 .. $#list ) { $val = $list[$i]; $val =~ s/\\/\\\\/g; $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg; $ENV{"${stem}_$i"} = $val; } ## end for $i (0 .. $#list) } ## end sub set_list =head2 get_list Reverse the set_list operation: grab VAR_n to see how many we should be getting back, and then pull VAR_0, VAR_1. etc. back out. =cut sub get_list { my $stem = shift; my @list; my $n = delete $ENV{"${stem}_n"}; my $val; for $i ( 0 .. $n - 1 ) { $val = delete $ENV{"${stem}_$i"}; $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge; push @list, $val; } @list; } ## end sub get_list =head1 MISCELLANEOUS SIGNAL AND I/O MANAGEMENT =head2 catch() The C subroutine is the essence of fast and low-impact. We simply set an already-existing global scalar variable to a constant value. This avoids allocating any memory possibly in the middle of something that will get all confused if we do, particularly under I. =cut sub catch { $signal = 1; return; # Put nothing on the stack - malloc/free land! } =head2 C C emits a warning, by joining together its arguments and printing them, with couple of fillips. If the composited message I end with a newline, we automatically add C<$!> and a newline to the end of the message. The subroutine expects $OUT to be set to the filehandle to be used to output warnings; it makes no assumptions about what filehandles are available. =cut sub warn { my ($msg) = join( "", @_ ); $msg .= ": $!\n" unless $msg =~ /\n$/; local $\ = ''; print $OUT $msg; } ## end sub warn =head1 INITIALIZATION TTY SUPPORT =head2 C This routine handles restoring the debugger's input and output filehandles after we've tried and failed to move them elsewhere. In addition, it assigns the debugger's output filehandle to $LINEINFO if it was already open there. =cut sub reset_IN_OUT { my $switch_li = $LINEINFO eq $OUT; # If there's a term and it's able to get a new tty, try to get one. if ( $term and $term->Features->{newTTY} ) { ( $IN, $OUT ) = ( shift, shift ); $term->newTTY( $IN, $OUT ); } # This term can't get a new tty now. Better luck later. elsif ($term) { &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n"); } # Set the filehndles up as they were. else { ( $IN, $OUT ) = ( shift, shift ); } # Unbuffer the output filehandle. my $o = select $OUT; $| = 1; select $o; # Point LINEINFO to the same output filehandle if it was there before. $LINEINFO = $OUT if $switch_li; } ## end sub reset_IN_OUT =head1 OPTION SUPPORT ROUTINES The following routines are used to process some of the more complicated debugger options. =head2 C Sets the input and output filehandles to the specified files or pipes. If the terminal supports switching, we go ahead and do it. If not, and there's already a terminal in place, we save the information to take effect on restart. If there's no terminal yet (for instance, during debugger initialization), we go ahead and set C<$console> and C<$tty> to the file indicated. =cut sub TTY { if ( @_ and $term and $term->Features->{newTTY} ) { # This terminal supports switching to a new TTY. # Can be a list of two files, or on string containing both names, # comma-separated. # XXX Should this perhaps be an assignment from @_? my ( $in, $out ) = shift; if ( $in =~ /,/ ) { # Split list apart if supplied. ( $in, $out ) = split /,/, $in, 2; } else { # Use the same file for both input and output. $out = $in; } # Open file onto the debugger's filehandles, if you can. open IN, $in or die "cannot open `$in' for read: $!"; open OUT, ">$out" or die "cannot open `$out' for write: $!"; # Swap to the new filehandles. reset_IN_OUT( \*IN, \*OUT ); # Save the setting for later. return $tty = $in; } ## end if (@_ and $term and $term... # Terminal doesn't support new TTY, or doesn't support readline. # Can't do it now, try restarting. &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_; # Useful if done through PERLDB_OPTS: $console = $tty = shift if @_; # Return whatever the TTY is. $tty or $console; } ## end sub TTY =head2 C Sets the C<$notty> global, controlling whether or not the debugger tries to get a terminal to read from. If called after a terminal is already in place, we save the value to use it if we're restarted. =cut sub noTTY { if ($term) { &warn("Too late to set noTTY, enabled on next `R'!\n") if @_; } $notty = shift if @_; $notty; } ## end sub noTTY =head2 C Sets the C<$rl> option variable. If 0, we use C (essentially, no C processing on this I). Otherwise, we use C. Can't be changed after a terminal's in place; we save the value in case a restart is done so we can change it then. =cut sub ReadLine { if ($term) { &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_; } $rl = shift if @_; $rl; } ## end sub ReadLine =head2 C Sets the port that the debugger will try to connect to when starting up. If the terminal's already been set up, we can't do it, but we remember the setting in case the user does a restart. =cut sub RemotePort { if ($term) { &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_; } $remoteport = shift if @_; $remoteport; } ## end sub RemotePort =head2 C Checks with the terminal to see if C is running, and returns true or false. Returns false if the current terminal doesn't support C. =cut sub tkRunning { if ( ${ $term->Features }{tkRunning} ) { return $term->tkRunning(@_); } else { local $\ = ''; print $OUT "tkRunning not supported by current ReadLine package.\n"; 0; } } ## end sub tkRunning =head2 C Sets nonstop mode. If a terminal's already been set up, it's too late; the debugger remembers the setting in case you restart, though. =cut sub NonStop { if ($term) { &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_; } $runnonstop = shift if @_; $runnonstop; } ## end sub NonStop sub DollarCaretP { if ($term) { &warn("Some flag changes could not take effect until next 'R'!\n") if @_; } $^P = parse_DollarCaretP_flags(shift) if @_; expand_DollarCaretP_flags($^P); } =head2 C Set up the C<$pager> variable. Adds a pipe to the front unless there's one there already. =cut sub pager { if (@_) { $pager = shift; $pager = "|" . $pager unless $pager =~ /^(\+?\>|\|)/; } $pager; } ## end sub pager =head2 C Sets the shell escape command, and generates a printable copy to be used in the help. =cut sub shellBang { # If we got an argument, meta-quote it, and add '\b' if it # ends in a word character. if (@_) { $sh = quotemeta shift; $sh .= "\\b" if $sh =~ /\w$/; } # Generate the printable version for the help: $psh = $sh; # copy it $psh =~ s/\\b$//; # Take off trailing \b if any $psh =~ s/\\(.)/$1/g; # De-escape $psh; # return the printable version } ## end sub shellBang =head2 C If the terminal has its own ornaments, fetch them. Otherwise accept whatever was passed as the argument. (This means you can't override the terminal's ornaments.) =cut sub ornaments { if ( defined $term ) { # We don't want to show warning backtraces, but we do want die() ones. local ( $warnLevel, $dieLevel ) = ( 0, 1 ); # No ornaments if the terminal doesn't support them. return '' unless $term->Features->{ornaments}; eval { $term->ornaments(@_) } || ''; } # Use what was passed in if we can't determine it ourselves. else { $ornaments = shift; } } ## end sub ornaments =head2 C Sets the recall command, and builds a printable version which will appear in the help text. =cut sub recallCommand { # If there is input, metaquote it. Add '\b' if it ends with a word # character. if (@_) { $rc = quotemeta shift; $rc .= "\\b" if $rc =~ /\w$/; } # Build it into a printable version. $prc = $rc; # Copy it $prc =~ s/\\b$//; # Remove trailing \b $prc =~ s/\\(.)/$1/g; # Remove escapes $prc; # Return the printable version } ## end sub recallCommand =head2 C - where the line number information goes Called with no arguments, returns the file or pipe that line info should go to. Called with an argument (a file or a pipe), it opens that onto the C filehandle, unbuffers the filehandle, and then returns the file or pipe again to the caller. =cut sub LineInfo { return $lineinfo unless @_; $lineinfo = shift; # If this is a valid "thing to be opened for output", tack a # '>' onto the front. my $stream = ( $lineinfo =~ /^(\+?\>|\|)/ ) ? $lineinfo : ">$lineinfo"; # If this is a pipe, the stream points to a slave editor. $slave_editor = ( $stream =~ /^\|/ ); # Open it up and unbuffer it. open( LINEINFO, "$stream" ) || &warn("Cannot open `$stream' for write"); $LINEINFO = \*LINEINFO; my $save = select($LINEINFO); $| = 1; select($save); # Hand the file or pipe back again. $lineinfo; } ## end sub LineInfo =head1 COMMAND SUPPORT ROUTINES These subroutines provide functionality for various commands. =head2 C For the C command: list modules loaded and their versions. Essentially just runs through the keys in %INC, picks each package's C<$VERSION> variable, gets the file name, and formats the information for output. =cut sub list_modules { # versions my %version; my $file; # keys are the "as-loaded" name, values are the fully-qualified path # to the file itself. for ( keys %INC ) { $file = $_; # get the module name s,\.p[lm]$,,i; # remove '.pl' or '.pm' s,/,::,g; # change '/' to '::' s/^perl5db$/DB/; # Special case: debugger # moves to package DB s/^Term::ReadLine::readline$/readline/; # simplify readline # If the package has a $VERSION package global (as all good packages # should!) decode it and save as partial message. if ( defined ${ $_ . '::VERSION' } ) { $version{$file} = "${ $_ . '::VERSION' } from "; } # Finish up the message with the file the package came from. $version{$file} .= $INC{$file}; } ## end for (keys %INC) # Hey, dumpit() formats a hash nicely, so why not use it? dumpit( $OUT, \%version ); } ## end sub list_modules =head2 C Sets up the monster string used to format and print the help. =head3 HELP MESSAGE FORMAT The help message is a peculiar format unto itself; it mixes C I (C<< B<> >> C<< I<> >>) with tabs to come up with a format that's fairly easy to parse and portable, but which still allows the help to be a little nicer than just plain text. Essentially, you define the command name (usually marked up with C<< B<> >> and C<< I<> >>), followed by a tab, and then the descriptive text, ending in a newline. The descriptive text can also be marked up in the same way. If you need to continue the descriptive text to another line, start that line with just tabs and then enter the marked-up text. If you are modifying the help text, I. The help-string parser is not very sophisticated, and if you don't follow these rules it will mangle the help beyond hope until you fix the string. =cut sub sethelp { # XXX: make sure there are tabs between the command and explanation, # or print_help will screw up your formatting if you have # eeevil ornaments enabled. This is an insane mess. $help = " Help is currently only available for the new 5.8 command set. No help is available for the old command set. We assume you know what you're doing if you switch to it. B Stack trace. B [I] Single step [in I]. B [I] Next, steps over subroutine calls [in I]. > Repeat last B or B command. B Return from current subroutine. B [I|I] Continue; optionally inserts a one-time-only breakpoint at the specified position. B IB<+>I List I+1 lines starting at I. B IB<->I List lines I through I. B I List single I. B I List first window of lines from subroutine. B I<\$var> List first window of lines from subroutine referenced by I<\$var>. B List next window of lines. B<-> List previous window of lines. B [I] View window around I. B<.> Return to the executed line. B I Switch to viewing I. File must be already loaded. I may be either the full name of the file, or a regular expression matching the full file name: B I and B I may access the same file. Evals (with saved bodies) are considered to be filenames: B I<(eval 7)> and B I access the body of the 7th eval (in the order of execution). BIB Search forwards for I; final B is optional. BIB Search backwards for I; final B is optional. B [I] List actions and or breakpoints and or watch-expressions. B [[B]I] List subroutine names [not] matching I. B Toggle trace mode. B I Trace through execution of I. B Sets breakpoint on current line) B [I] [I] Set breakpoint; I defaults to the current execution line; I breaks if it evaluates to true, defaults to '1'. B I [I] Set breakpoint at first line of subroutine. B I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>. B B I Set breakpoint on 'require'ing the given file. B B I [I] Set breakpoint at first line of subroutine after it is compiled. B B I Stop after the subroutine is compiled. B [I] Delete the breakpoint for I. B I<*> Delete all breakpoints. B [I] I Set an action to be done before the I is executed; I defaults to the current execution line. Sequence is: check for breakpoint/watchpoint, print line if necessary, do action, prompt user if necessary, execute line. B Does nothing B [I] Delete the action for I. B I<*> Delete all actions. B I Add a global watch-expression. B Does nothing B I Delete a global watch-expression. B I<*> Delete all watch-expressions. B [I [I]] List some (default all) variables in package (default current). Use B<~>I and BI for positive and negative regexps. B [I] Same as \"B I [I]\". B I Evals expression in list context, dumps the result. B I Evals expression in list context, prints methods callable on the first element of the result. B I Prints methods callable via the given class. B Show versions of loaded modules. B I Prints nested parents of given class. B Display current thread id. B Display all thread ids the current one will be identified: . B [I [I]] List lexicals in higher scope . Vars same as B. B<<> ? List Perl commands to run before each prompt. B<<> I Define Perl command to run before each prompt. B<<<> I Add to the list of Perl commands to run before each prompt. B<< *> Delete the list of perl commands to run before each prompt. B<>> ? List Perl commands to run after each prompt. B<>> I Define Perl command to run after each prompt. B<>>B<>> I Add to the list of Perl commands to run after each prompt. B<>>B< *> Delete the list of Perl commands to run after each prompt. B<{> I Define debugger command to run before each prompt. B<{> ? List debugger commands to run before each prompt. B<{{> I Add to the list of debugger commands to run before each prompt. B<{ *> Delete the list of debugger commands to run before each prompt. B<$prc> I Redo a previous command (default previous command). B<$prc> I<-number> Redo number'th-to-last command. B<$prc> I Redo last command that started with I. See 'B I' too. B<$psh$psh> I Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)" . ( $rc eq $sh ? "" : " B<$psh> [I] Run I in subshell (forces \"\$SHELL -c 'cmd'\")." ) . " See 'B I' too. B I Execute I containing debugger commands (may nest). B I Save current debugger session (actual history) to I. B Rerun session to current position. B I Rerun session to numbered command. B I<-n> Rerun session to number'th-to-last command. B I<-number> Display last number commands (default all). B I<*> Delete complete history. B

: Scilab: --> a = 12 a = 12. --> b = 23; // Suppress output. --> PerlDL: pdl> $x = 12 # No output. pdl> print $x # Print object. 12 pdl> p $x # "p" is a shorthand for "print" in the shell. 12 =back =head2 Creating ndarrays =over 5 =item Variables in PDL Variables always start with the '$' sign. Scilab: value = 42 PerlDL: $value = 42 =item Basic syntax Use the "pdl" constructor to create a new I. Scilab: v = [1,2,3,4] PerlDL: $v = pdl [1,2,3,4] Scilab: A = [ 1,2,3 ; 3,4,5 ] PerlDL: $A = pdl [ [1,2,3] , [3,4,5] ] =item Simple matrices Scilab PDL ------ ------ Matrix of ones ones(5,5) ones 5,5 Matrix of zeros zeros(5,5) zeros 5,5 Random matrix rand(5,5) random 5,5 Linear vector 1:5 sequence 5 Notice that in PDL the parenthesis in a function call are often optional. It is important to keep an eye out for possible ambiguities. For example: pdl> p zeros 2, 2 + 2 Should this be interpreted as C or as C? Both are valid statements: pdl> p zeros(2,2) + 2 [ [2 2] [2 2] ] pdl> p zeros 2, (2+2) [ [0 0] [0 0] [0 0] [0 0] ] Rather than trying to memorize Perl's order of precedence, it is best to use parentheses to make your code unambiguous. =item Linearly spaced sequences Scilab: --> linspace(2,10,5) ans = 2. 4. 6. 8. 10. PerlDL: pdl> p zeroes(5)->xlinvals(2,10) [2 4 6 8 10] B: Start with a 1-dimensional ndarray of 5 elements and give it equally spaced values from 2 to 10. Scilab has a single function call for this. On the other hand, PDL's method is more flexible: pdl> p zeros(5,5)->xlinvals(2,10) [ [ 2 4 6 8 10] [ 2 4 6 8 10] [ 2 4 6 8 10] [ 2 4 6 8 10] [ 2 4 6 8 10] ] pdl> p zeros(5,5)->ylinvals(2,10) [ [ 2 2 2 2 2] [ 4 4 4 4 4] [ 6 6 6 6 6] [ 8 8 8 8 8] [10 10 10 10 10] ] pdl> p zeros(3,3,3)->zlinvals(2,6) [ [ [2 2 2] [2 2 2] [2 2 2] ] [ [4 4 4] [4 4 4] [4 4 4] ] [ [6 6 6] [6 6 6] [6 6 6] ] ] =item Slicing and indices Extracting a subset from a collection of data is known as I. The PDL shell and Scilab have a similar syntax for slicing, but there are two important differences: 1) PDL indices start at 0, as in C and Java. Scilab starts indices at 1. 2) In Scilab you think "rows and columns". In PDL, think "x and y". Scilab PerlDL ------ ------ --> A pdl> p $A A = [ 1. 2. 3. [1 2 3] 4. 5. 6. [4 5 6] 7. 8. 9. [7 8 9] ] ------------------------------------------------------- (row = 2, col = 1) (x = 0, y = 1) --> A(2,1) pdl> p $A(0,1) ans = [ 4. [4] ] ------------------------------------------------------- (row = 2 to 3, col = 1 to 2) (x = 0 to 1, y = 1 to 2) --> A(2:3,1:2) pdl> p $A(0:1,1:2) ans = [ 4. 5. [4 5] 7. 8. [7 8] ] =over 5 =item B When you write a stand-alone PDL program you have to include the L module. See the previous section "B" for more information. use PDL; # Import main PDL module. use PDL::NiceSlice; # Nice syntax for slicing. $A = random 4,4; print $A(0,1); =back =back =head2 Matrix Operations =over 10 =item Matrix multiplication Scilab: A * B PerlDL: $A x $B =item Element-wise multiplication Scilab: A .* B PerlDL: $A * $B =item Transpose Scilab: A' PerlDL: $A->transpose =back =head2 Functions that aggregate data Some functions (like C, C and C) aggregate data for an N-dimensional data set. Scilab and PDL both give you the option to apply these functions to the entire data set or to just one dimension. =over 10 =item Scilab In Scilab, these functions work along the entire data set by default, and an optional parameter "r" or "c" makes them act over rows or columns. --> A = [ 1,5,4 ; 4,2,1 ] A = 1. 5. 4. 4. 2. 1. --> max(A) ans = 5 --> max(A, "r") ans = 4. 5. 4. --> max(A, "c") ans = 5. 4. =item PDL PDL offers two functions for each feature. sum vs sumover avg vs average max vs maximum min vs minimum The B works over a dimension, while the B works over the entire ndarray. pdl> p $A = pdl [ [1,5,4] , [4,2,1] ] [ [1 5 4] [4 2 1] ] pdl> p $A->maximum [5 4] pdl> p $A->transpose->maximum [4 5 4] pdl> p $A->max 5 =back =head2 Higher dimensional data sets A related issue is how Scilab and PDL understand data sets of higher dimension. Scilab was designed for 1D vectors and 2D matrices with higher dimensional objects added on top. In contrast, PDL was designed for N-dimensional ndarrays from the start. This leads to a few surprises in Scilab that don't occur in PDL: =over 5 =item Scilab sees a vector as a 2D matrix. Scilab PerlDL ------ ------ --> vector = [1,2,3,4]; pdl> $vector = pdl [1,2,3,4] --> size(vector) pdl> p $vector->dims ans = 1 4 4 Scilab sees C<[1,2,3,4]> as a 2D matrix (1x4 matrix). PDL sees it as a 1D vector: A single dimension of size 4. =item But Scilab ignores the last dimension of a 4x1x1 matrix. Scilab PerlDL ------ ------ --> A = ones(4,1,1); pdl> $A = ones 4,1,1 --> size(A) pdl> p $A->dims ans = 4 1 4 1 1 =item And Scilab treats a 4x1x1 matrix differently from a 1x1x4 matrix. Scilab PerlDL ------ ------ --> A = ones(1,1,4); pdl> $A = ones 1,1,4 --> size(A) pdl> p $A->dims ans = 1 1 4 1 1 4 =item Scilab has no direct syntax for N-D arrays. pdl> $A = pdl [ [[1,2,3],[4,5,6]], [[2,3,4],[5,6,7]] ] pdl> p $A->dims 3 2 2 =item Feature support. In Scilab, several features are not available for N-D arrays. In PDL, just about any feature supported by 1D and 2D ndarrays, is equally supported by N-dimensional ndarrays. There is usually no distinction: Scilab PerlDL ------ ------ --> A = ones(3,3,3); pdl> $A = ones(3,3,3); --> A' pdl> transpose $A => ERROR => OK =back =head2 Loop Structures Perl has many loop structures, but we will only show the one that is most familiar to Scilab users: Scilab PerlDL ------ ------ for i = 1:10 for $i (1..10) { disp(i) print $i end } =over 5 =item B Never use for-loops for numerical work. Perl's for-loops are faster than Scilab's, but they both pale against a "vectorized" operation. PDL has many tools that facilitate writing vectorized programs. These are beyond the scope of this guide. To learn more, see: L, L, and L. Likewise, never use C<1..10> for numerical work, even outside a for-loop. C<1..10> is a Perl array. Perl arrays are designed for flexibility, not speed. Use I instead. To learn more, see the next section. =back =head2 ndarrays vs Perl Arrays It is important to note the difference between an I and a Perl array. Perl has a general-purpose array object that can hold any type of element: @perl_array = 1..10; @perl_array = ( 12, "Hello" ); @perl_array = ( 1, 2, 3, \@another_perl_array, sequence(5) ); Perl arrays allow you to create powerful data structures (see B below), B. For that, use I: $pdl = pdl [ 1, 2, 3, 4 ]; $pdl = sequence 10_000_000; $pdl = ones 600, 600; For example: $points = pdl 1..10_000_000 # 4.7 seconds $points = sequence 10_000_000 # milliseconds B: You can use underscores in numbers (C<10_000_000> reads better than C<10000000>). =head2 Conditionals Perl has many conditionals, but we will only show the one that is most familiar to Scilab users: Scilab PerlDL ------ ------ if value > MAX if ($value > $MAX) { disp("Too large") print "Too large\n"; elseif value < MIN } elsif ($value < $MIN) { disp("Too small") print "Too small\n"; else } else { disp("Perfect!") print "Perfect!\n"; end } =over 5 =item B Here is a "gotcha": Scilab: elseif PerlDL: elsif If your conditional gives a syntax error, check that you wrote your C's correctly. =back =head2 TIMTOWDI (There Is More Than One Way To Do It) One of the most interesting differences between PDL and other tools is the expressiveness of the Perl language. TIMTOWDI, or "There Is More Than One Way To Do It", is Perl's motto. Perl was written by a linguist, and one of its defining properties is that statements can be formulated in different ways to give the language a more natural feel. For example, you are unlikely to say to a friend: "While I am not finished, I will keep working." Human language is more flexible than that. Instead, you are more likely to say: "I will keep working until I am finished." Owing to its linguistic roots, Perl is the only programming language with this sort of flexibility. For example, Perl has traditional while-loops and if-statements: while ( ! finished() ) { keep_working(); } if ( ! wife_angry() ) { kiss_wife(); } But it also offers the alternative B and B statements: until ( finished() ) { keep_working(); } unless ( wife_angry() ) { kiss_wife(); } And Perl allows you to write loops and conditionals in "postfix" form: keep_working() until finished(); kiss_wife() unless wife_angry(); In this way, Perl often allows you to write more natural, easy to understand code than is possible in more restrictive programming languages. =head2 Functions PDL's syntax for declaring functions differs significantly from Scilab's. Scilab PerlDL ------ ------ function retval = foo(x,y) sub foo { retval = x.**2 + x.*y my ($x, $y) = @_; endfunction return $x**2 + $x*$y; } Don't be intimidated by all the new syntax. Here is a quick run through a function declaration in PDL: 1) "B" stands for "subroutine". 2) "B" declares variables to be local to the function. 3) "B<@_>" is a special Perl array that holds all the function parameters. This might seem like a strange way to do functions, but it allows you to make functions that take a variable number of parameters. For example, the following function takes any number of parameters and adds them together: sub mysum { my ($i, $total) = (0, 0); for $i (@_) { $total += $i; } return $total; } 4) You can assign values to several variables at once using the syntax: ($x, $y, $z) = (1, 2, 3); So, in the previous examples: # This declares two local variables and initializes them to 0. my ($i, $total) = (0, 0); # This takes the first two elements of @_ and puts them in $x and $y. my ($x, $y) = @_; 5) The "B" statement gives the return value of the function, if any. =head1 ADDITIONAL FEATURES =head2 Data structures To create complex data structures, Scilab uses "I" and "I". Perl's arrays and hashes offer similar functionality. This section is only a quick overview of what Perl has to offer. To learn more about this, please go to L or run the command C. =over 5 =item Arrays Perl arrays are similar to Scilab's lists. They are both a sequential data structure that can contain any data type. Scilab ------ list( 1, 12, "hello", zeros(3,3) , list( 1, 2) ); PerlDL ------ @array = ( 1, 12, "hello" , zeros(3,3), [ 1, 2 ] ) Notice that Perl array's start with the "@" prefix instead of the "$" used by ndarrays. I or run the command C.> =item Hashes Perl hashes are similar to Scilab's structure arrays: Scilab ------ --> drink = struct('type', 'coke', 'size', 'large', 'myarray', ones(3,3,3)) --> drink.type = 'sprite' --> drink.price = 12 // Add new field to structure array. PerlDL ------ pdl> %drink = ( type => 'coke' , size => 'large', myndarray => ones(3,3,3) ) pdl> $drink{type} = 'sprite' pdl> $drink{price} = 12 # Add new field to hash. Notice that Perl hashes start with the "%" prefix instead of the "@" for arrays and "$" used by ndarrays. I or run the command C.> =back =head2 Performance PDL has powerful performance features, some of which are not normally available in numerical computation tools. The following pages will guide you through these features: =over 5 =item L B: Beginner This beginner tutorial covers the standard "vectorization" feature that you already know from Scilab. Use this page to learn how to avoid for-loops to make your program more efficient. =item L B: Intermediate PDL's "vectorization" feature goes beyond what most numerical software can do. In this tutorial you'll learn how to "thread" over higher dimensions, allowing you to vectorize your program further than is possible in Scilab. =item Benchmarks B: Intermediate Perl comes with an easy to use benchmarks module to help you find how long it takes to execute different parts of your code. It is a great tool to help you focus your optimization efforts. You can read about it online (L) or through the command C. =item L B: Advanced PDL's Pre-Processor is one of PDL's most powerful features. You write a function definition in special markup and the pre-processor generates real C code which can be compiled. With PDL:PP you get the full speed of native C code without having to deal with the full complexity of the C language. =back =head2 Plotting PDL has full-featured plotting abilities. Unlike Scilab, PDL relies more on third-party libraries (pgplot and PLplot) for its 2D plotting features. Its 3D plotting and graphics uses OpenGL for performance and portability. PDL has three main plotting modules: =over 5 =item L B: Plotting 2D functions and data sets. This is an interface to the venerable PGPLOT library. PGPLOT has been widely used in the academic and scientific communities for many years. In part because of its age, PGPLOT has some limitations compared to newer packages such as PLplot (e.g. no RGB graphics). But it has many features that still make it popular in the scientific community. =item L B: Plotting 2D functions as well as 2D and 3D data sets. This is an interface to the PLplot plotting library. PLplot is a modern, open source library for making scientific plots. It supports plots of both 2D and 3D data sets. PLplot is best supported for unix/linux/macosx platforms. It has an active developers community and support for win32 platforms is improving. =item L B: Plotting 3D functions. The native PDL 3D graphics library using OpenGL as a backend for 3D plots and data visualization. With OpenGL, it is easy to manipulate the resulting 3D objects with the mouse in real time. =back =head2 Writing GUIs Through Perl, PDL has access to all the major toolkits for creating a cross platform graphical user interface. One popular option is wxPerl (L). These are the Perl bindings for wxWidgets, a powerful GUI toolkit for writing cross-platform applications. wxWidgets is designed to make your application look and feel like a native application in every platform. For example, the Perl IDE B is written with wxPerl. =head2 Xcos / Scicos Xcos (formerly Scicos) is a graphical dynamical system modeler and simulator. It is part of the standard Scilab distribution. PDL and Perl do not have a direct equivalent to Scilab's Xcos. If this feature is important to you, you should probably keep a copy of Scilab around for that. =head1 COPYRIGHT Copyright 2010 Daniel Carrera (dcarrera@gmail.com). You can distribute and/or modify this document under the same terms as the current Perl license. See: http://dev.perl.org/licenses/ PDL-2.074/Basic/Pod/Philosophy.pod0000644000175000017500000001630014014062163016475 0ustar osboxesosboxes=head1 NAME PDL::Philosophy -- Why did we write PDL? =head1 DESCRIPTION Some history from the creator of PDL, leading into the philosophy and motivation behind this data language. This is an attempt to summarize some of the common spirit between pdl developers in order to answer the question "Why PDL"? =head2 The Start of PDL B<"Why is it that we entertain the belief that for every purpose odd numbers are the most effectual?"> - I The PDL project began in February 1996, when I decided to experiment with writing my own `Data Language'. I am an astronomer. My day job involves a lot of analysis of digital data accumulated on many nights observing on telescopes around the world. Such data might for example be images containing millions of pixels and thousands of images of distant stars and galaxies. Or more abstrusely, many hundreds of digital spectra revealing the secrets of the composition and properties of these distant objects. Obviously many astronomers have dealt with these problems before, and a large amount of software has been constructed to facilitate their analysis. However, like many of my colleagues, I was constantly frustrated by the lack of generality and flexibility of these programs and the difficulty of doing anything out of the ordinary quickly and easily. What I wanted had a name: "Data Language", i.e. a language which allowed the manipulation of large amounts of data with simple arithmetic expressions. In fact some commercial software worked like this, and I was impressed with the capabilities but not with the price tag. And I thought I could do better. As a fairly computer literate astronomer (read "nerd" or "geek" according to your local argot) I was very familiar with "Perl", a computer language which now seems to fill the shelves of many bookstores around the world. I was impressed by its power and flexibility, and especially its ease of use. I had even explored the depths of its internals and written an interface to allow graphics, the ease with which I could then create charts and graphs, for my papers, was refreshing. Version 5 of Perl had just been released, and I was fascinated by the new features available. Especially the support of arbitrary data structures (or "objects" in modern parlance) and the ability to "overload" operators - i.e. make mathematical symbols like C<+-*/> do whatever you felt like. It seemed to me it ought to be possible to write an extension to Perl where I could play with my data in a general way: for example using the maths operators manipulate whole images at once. Well one slow night at an observatory I just thought I would try a little experiment. In a bored moment I fired up a text editor and started to create a file called `PDL.xs' - a Perl extension module to manipulate data vectors. A few hours later I actually had something half decent working, where I could add two images in the Perl language, B This was something I could not let rest, and it probably cost me one or two scientific papers worth of productivity. A few weeks later the Perl Data Language version 1.0 was born. It was a pretty bare infant: very little was there apart from the basic arithmetic operators. But encouraged I made it available on the Internet to see what people thought. Well people were fairly critical - among the most vocal were Tuomas Lukka and Christian Soeller. Unfortunately for them they were both Perl enthusiasts too and soon found themselves improving my code to implement all the features they thought PDL ought to have and I had heinously neglected. PDL is a prime example of that modern phenomenon of authoring large free software packages via the Internet. Large numbers of people, most of whom have never met, have made contributions ranging for core functionality to large modules to the smallest of bug patches. PDL version 2.0 is now here (though it should perhaps have been called version 10 to reflect the amount of growth in size and functionality) and the phenomenon continues. I firmly believe that PDL is a great tool for tackling general problems of data analysis. It is powerful, fast, easy to add too and freely available to anyone. I wish I had had it when I was a graduate student! I hope you too will find it of immense value, I hope it will save you from heaps of time and frustration in solving complex problems. Of course it can't do everything, but it provides the framework, the hammers and the nails for building solutions without having to reinvent wheels or levers. --- Karl Glazebook, the creator of PDL =head2 Major ideas The first tenet of our philosophy is the "free software" idea: software being free has several advantages (less bugs because more people see the code, you can have the source and port it to your own working environment with you, ... and of course, that you don't need to pay anything). The second idea is a pet peeve of many: many languages like Matlab are pretty well suited for their specific tasks but for a different application, you need to change to an entirely different tool and regear yourself mentally. Not to speak about doing an application that does two things at once... Because we use Perl, we have the power and ease of Perl syntax, regular expressions, hash tables, etc. at our fingertips at all times. By extending an existing language, we start from a much healthier base than languages like Matlab which have grown into existence from a very small functionality at first and expanded little by little, making things look badly planned. We stand by the Perl sayings: "simple things should be simple but complicated things should be possible" and "There is more than one way to do it" (TIMTOWTDI). The third idea is interoperability: we want to be able to use PDL to drive as many tools as possible, we can connect to OpenGL or Mesa for graphics or whatever. There isn't anything out there that's really satisfactory as a tool and can do everything we want easily. And be portable. The fourth idea is related to C and is Tuomas's personal favorite: code should only specify as little as possible redundant info. If you find yourself writing very similar-looking code much of the time, all that code could probably be generated by a simple Perl script. The PDL C preprocessor takes this to an extreme. =head2 Minor goals and purposes We want speed. Optimally, it should ultimately (e.g. with the Perl compiler) be possible to compile C subs to C and obtain the top vectorized speeds on supercomputers. Also, we want to be able to calculate things at near top speed from inside Perl, by using dataflow to avoid memory allocation and deallocation (the overhead should ultimately be only a little over one indirect function call plus couple of ifs per function in the pipe). =head2 Go on, try it! Well, that's the philosophy behind PDL - speed, conciseness, free, expandable, and integrated with the wide base of modules and libraries that Perl provides. Feel free to download it, install it, run through some of the tutorials and introductions and have a play with it. Enjoy! =head1 AUTHOR Added Karl Glazebrook (2001) contributions by Matthew Kenworthy Copyright(C) 1997 Tuomas J. Lukka (lukka@fas.harvard.edu). Redistribution in the same form is allowed but reprinting requires a permission from the author. PDL-2.074/Basic/Pod/BadValues.pod0000644000175000017500000004462514160015533016221 0ustar osboxesosboxes=head1 NAME PDL::BadValues - Discussion of bad value support in PDL =head1 DESCRIPTION =head2 What are bad values and why should I bother with them? Sometimes it's useful to be able to specify a certain value is 'bad' or 'missing'; for example CCDs used in astronomy produce 2D images which are not perfect since certain areas contain invalid data due to imperfections in the detector. Whilst PDL's powerful index routines and all the complicated business with dataflow, slices, etc etc mean that these regions can be ignored in processing, it's awkward to do. It would be much easier to be able to say C<$c = $x + $y> and leave all the hassle to the computer. If you're not interested in this, then you may (rightly) be concerned with how this affects the speed of PDL, since the overhead of checking for a bad value at each operation can be large. Because of this, the code has been written to be as fast as possible - particularly when operating on ndarrays which do not contain bad values. In fact, you should notice essentially no speed difference when working with ndarrays which do not contain bad values. You may also ask 'well, my computer supports IEEE NaN, so I already have this'. Well, yes and no - many routines, such as C, will propagate NaN's without the user having to code differently, but routines such as C, or finding the median of an array, need to be re-coded to handle bad values. For floating-point datatypes, C and C can be used to flag bad values, but by default special values are used (L). I do not have any benchmarks to see which option is faster. As of PDL 2.040, you can have different bad values for separate ndarrays of the same type. =head2 A quick overview pdl> $x = sequence(4,3); pdl> p $x [ [ 0 1 2 3] [ 4 5 6 7] [ 8 9 10 11] ] pdl> $x = $x->setbadif( $x % 3 == 2 ) pdl> p $x [ [ 0 1 BAD 3] [ 4 BAD 6 7] [BAD 9 10 BAD] ] pdl> $x *= 3 pdl> p $x [ [ 0 3 BAD 9] [ 12 BAD 18 21] [BAD 27 30 BAD] ] pdl> p $x->sum 120 C and C within L or L gives a demonstration of some of the things possible with bad values. These are also available on PDL's web-site, at F. See L for useful routines for working with bad values and F to see them in action. To find out if a routine supports bad values, use the C command in L or L or the C<-b> option to L. This facility is currently a 'proof of concept' (or, more realistically, a quick hack) so expect it to be rough around the edges. Each ndarray contains a flag - accessible via C<< $pdl->badflag >> - to say whether there's any bad data present: =over 4 =item * If B, which means there's no bad data here, the code supplied by the C option to C is executed. =item * If B, then this says there I be bad data in the ndarray, so use the code in the C option (assuming that the C for this routine has been updated to have a BadCode key). You get all the advantages of threading, as with the C option, but it will run slower since you are going to have to handle the presence of bad values. =back If you create an ndarray, it will have its bad-value flag set to 0. To change this, use C<< $pdl->badflag($new_bad_status) >>, where C<$new_bad_status> can be 0 or 1. When a routine creates an ndarray, its bad-value flag will depend on the input ndarrays: unless over-ridden (see the C option to C), the bad-value flag will be set true if any of the input ndarrays contain bad values. To check that an ndarray really contains bad data, use the C method. I: propagation of the badflag If you change the badflag of an ndarray, this change is propagated to all the I of an ndarray, so pdl> $x = zeroes(20,30); pdl> $y = $x->slice('0:10,0:10'); pdl> $c = $y->slice(',(2)'); pdl> print ">>c: ", $c->badflag, "\n"; >>c: 0 pdl> $x->badflag(1); pdl> print ">>c: ", $c->badflag, "\n"; >>c: 1 I change is made to the parents of an ndarray, so pdl> print ">>a: ", $x->badflag, "\n"; >>a: 1 pdl> $c->badflag(0); pdl> print ">>a: ", $x->badflag, "\n"; >>a: 1 Thoughts: =over 4 =item * the badflag can ONLY be cleared IF an ndarray has NO parents, and that this change will propagate to all the children of that ndarray. I am not so keen on this anymore (too awkward to code, for one). =item * C<< $x->badflag(1) >> should propagate the badflag to BOTH parents and children. =back This shouldn't be hard to implement (although an initial attempt failed!). Does it make sense though? There's also the issue of what happens if you change the badvalue of an ndarray - should these propagate to children/parents (yes) or whether you should only be able to change the badvalue at the 'top' level - i.e. those ndarrays which do not have parents. The C method returns the compile-time value for a given datatype. It works on ndarrays, PDL::Type objects, and numbers - eg $pdl->orig_badvalue(), byte->orig_badvalue(), and orig_badvalue(4). It also has a horrible name... To get the current bad value, use the C method - it has the same syntax as C. To change the current bad value, supply the new number to badvalue - eg $pdl->badvalue(2.3), byte->badvalue(2), badvalue(5,-3e34). I: the value is silently converted to the correct C type, and returned - i.e. C<< byte->badvalue(-26) >> returns 230 on my Linux machine. Note that changes to the bad value are I propagated to previously-created ndarrays - they will still have the bad value set, but suddenly the elements that were bad will become 'good', but containing the old bad value. See discussion below. It's not a problem for floating-point types which use NaN, since you can not change their badvalue. =head2 Bad values and boolean operators For those boolean operators in L, evaluation on a bad value returns the bad value. Whilst this means that $mask = $img > $thresh; correctly propagates bad values, it I cause problems for checks such as do_something() if any( $img > $thresh ); which need to be re-written as something like do_something() if any( setbadtoval( ($img > $thresh), 0 ) ); When using one of the 'projection' functions in L - such as L - bad values are skipped over (see the documentation of these functions for the current (poor) handling of the case when all elements are bad). =head2 A bad value for each ndarray, and related issues There is one default bad value for each datatype, but you can have a separate bad value for each ndarray as of PDL 2.040. =head1 IMPLEMENTATION DETAILS PDL code just needs to access the C<%PDL::Config> array (e.g. F) to find out whether bad-value support is required. A new flag has been added to the state of an ndarray - C. If unset, then the ndarray does not contain bad values, and so all the support code can be ignored. If set, it does not guarantee that bad values are present, just that they should be checked for. Thanks to Christian, C - which sets/clears this flag (see F) - will update I the children/grandchildren/etc of an ndarray if its state changes (see C in F and C in F). It's not clear what to do with parents: I can see the reason for propagating a 'set badflag' request to parents, but I think a child should NOT be able to clear the badflag of a parent. There's also the issue of what happens when you change the bad value for an ndarray. The C structure has been extended to include an integer value, C, which acts as a switch to tell the code whether to handle bad values or not. This value is set if any of the input ndarrays have their C flag set (although this code can be replaced by setting C in pp_def). The logic of the check is going to get a tad more complicated if I allow routines to fall back to using the C section for floating-point types. The default bad values are now stored in a structure within the Core PDL structure - C (eg F); see also C in F and the BOOT code of F where the values are initialised to (hopefully) sensible values. See F for read/write routines to the values. =head2 Why not make a PDL subclass? The support for bad values could have been done as a PDL sub-class. The advantage of this approach would be that you only load in the code to handle bad values if you actually want to use them. The downside is that the code then gets separated: any bug fixes/improvements have to be done to the code in two different files. With the present approach the code is in the same C function (although there is still the problem that both C and C sections need updating). =head2 Default bad values The default/original bad values are set to (taken from the Starlink distribution): #include PDL_Byte == UCHAR_MAX PDL_Short == SHRT_MIN PDL_Ushort == USHRT_MAX PDL_Long == INT_MIN PDL_Float == -FLT_MAX PDL_Double == -DBL_MAX =head2 How do I change a routine to handle bad values? Examples can be found in most of the F<*.pd> files in F (and hopefully many more places soon!). Some of the logic might appear a bit unclear - that's probably because it is! Comments appreciated. All routines should automatically propagate the bad status flag to output ndarrays, unless you declare otherwise. If a routine explicitly deals with bad values, you must provide this option to pp_def: HandleBad => 1 This ensures that the correct variables are initialised for the C<$ISBAD> etc macros. It is also used by the automatic document-creation routines to provide default information on the bad value support of a routine without the user having to type it themselves (this is in its early stages). To flag a routine as NOT handling bad values, use HandleBad => 0 This I cause the routine to print a warning if it's sent any ndarrays with the bad flag set. Primitive's C has had this set - since it would be awkward to convert - but I've not tried it out to see if it works. If you want to handle bad values but not set the state of all the output ndarrays, or if it's only one input ndarray that's important, then look at the PP rules C and C and the corresponding C options: =over 4 =item FindBadStatusCode By default, C creates code which sets C<$PRIV(bvalflag)> depending on the state of the bad flag of the input ndarrays: see C in F. User-defined code should also store the value of C in the C<$BADFLAGCACHE()> variable. =item CopyBadStatusCode The default code here is a bit simpler than for C: the bad flag of the output ndarrays are set if C<$BADFLAGCACHE()> is true after the code has been evaluated. Sometimes C is set to an empty string, with the responsibility of setting the badflag of the output ndarray left to the C section (e.g. the C routines in F). Prior to PDL 2.4.3 we used C<$PRIV(bvalflag)> instead of C<$BADFLAGCACHE()>. This is dangerous since the C<$PRIV()> structure is not guaranteed to be valid at this point in the code. =back If you have a routine that you want to be able to use as in-place, look at the routines in F (or F) which use the C option to see how the bad flag is propagated to children using the C options. I decided not to automate this as rules would be a little complex, since not every in-place op will need to propagate the badflag (eg unary functions). If the option HandleBad => 1 is given, then many things happen. For integer types, the readdata code automatically creates a variable called C<(pdl name)_badval>, which contains the bad value for that ndarray (see C in F). However, do not hard code this name into your code! Instead use macros (thanks to Tuomas for the suggestion): '$ISBAD(a(n=>1))' expands to '$a(n=>1) == a_badval' '$ISGOOD(a())' '$a() != a_badval' '$SETBAD(bob())' '$bob() = bob_badval' well, the C<$a(...)> is expanded as well. Also, you can use a C<$> before the pdl name, if you so wish, but it begins to look like line noise - eg C<$ISGOOD($a())>. If you cache an ndarray value in a variable -- eg C in F -- the following routines are useful: '$ISBADVAR(c_var,pdl)' 'c_var == pdl_badval' '$ISGOODVAR(c_var,pdl)' 'c_var != pdl_badval' '$SETBADVAR(c_var,pdl)' 'c_var = pdl_badval' The following have been introduced, They may need playing around with to improve their use. '$PPISBAD(CHILD,[i]) 'CHILD_physdatap[i] == CHILD_badval' '$PPISGOOD(CHILD,[i]) 'CHILD_physdatap[i] != CHILD_badval' '$PPSETBAD(CHILD,[i]) 'CHILD_physdatap[i] = CHILD_badval' You can use C as the bad value for any floating-point type, including complex. This all means that you can change Code => '$a() = $b() + $c();' to BadCode => 'if ( $ISBAD(b()) || $ISBAD(c()) ) { $SETBAD(a()); } else { $a() = $b() + $c(); }' leaving Code as it is. PP::PDLCode will then create a loop something like if ( __trans->bvalflag ) { threadloop over BadCode } else { threadloop over Code } (it's probably easier to just look at the F<.xs> file to see what goes on). =head2 Going beyond the Code section Similar to C, there's C, and C. Handling C is a bit different: under the assumption that the only access to data is via the C<$EQUIVCPOFFS(i,j)> macro, then we can automatically create the 'bad' version of it; see the C<[EquivCPOffsCode]> and C<[Code]> rules in L. =head2 Macro access to the bad flag of an ndarray Macros have been provided to provide access to the bad-flag status of a pdl: '$PDLSTATEISBAD(a)' -> '($PDL(a)->state & PDL_BADVAL) > 0' '$PDLSTATEISGOOD(a)' '($PDL(a)->state & PDL_BADVAL) == 0' '$PDLSTATESETBAD(a)' '$PDL(a)->state |= PDL_BADVAL' '$PDLSTATESETGOOD(a)' '$PDL(a)->state &= ~PDL_BADVAL' For use in C (+ other stuff that goes into the INIT: section) there are: '$SETPDLSTATEBAD(a)' -> 'a->state |= PDL_BADVAL' '$SETPDLSTATEGOOD(a)' -> 'a->state &= ~PDL_BADVAL' '$ISPDLSTATEBAD(a)' -> '((a->state & PDL_BADVAL) > 0)' '$ISPDLSTATEGOOD(a)' -> '((a->state & PDL_BADVAL) == 0)' In PDL 2.4.3 the C<$BADFLAGCACHE()> macro was introduced for use in C and C. =head1 WHAT ABOUT DOCUMENTATION? One of the strengths of PDL is its on-line documentation. The aim is to use this system to provide information on how/if a routine supports bad values: in many cases C contains all the information anyway, so the function-writer doesn't need to do anything at all! For the cases when this is not sufficient, there's the C option. For code written at the Perl level - i.e. in a .pm file - use the C<=for bad> pod directive. This information will be available via man/pod2man/html documentation. It's also accessible from the C or C shells - using the C command - and the C shell command - using the C<-b> option. =head1 CURRENT ISSUES There are a number of areas that need work, user input, or both! They are mentioned elsewhere in this document, but this is just to make sure they don't get lost. =head2 Trapping invalid mathematical operations Should we add exceptions to the functions in C to set the output bad for out-of-range input values? pdl> p log10(pdl(10,100,-1)) I would like the above to produce "[1 2 BAD]", but this would slow down operations on I ndarrays. We could check for C/C values after the operation, but I doubt that would be any faster. =head2 Dataflow of the badflag Currently changes to the bad flag are propagated to the children of an ndarray, but perhaps they should also be passed on to the parents as well. With the advent of per-ndarray bad values we need to consider how to handle changes to the value used to represent bad items too. =head1 EVERYTHING ELSE The build process has been affected. The following files are now created during the build: Basic/Core/pdlcore.h pdlcore.h.PL pdlcore.c pdlcore.c.PL pdlapi.c pdlapi.c.PL Core.xs Core.xs.PL Core.pm Core.pm.PL Several new files have been added: Basic/Pod/BadValues.pod (i.e. this file) t/bad.t Basic/Bad/ Basic/Bad/Makefile.PL bad.pd etc =head1 TODO/SUGGESTIONS =over 4 =item * what to do about C<$y = pdl(-2); $x = log10($y)> - C<$x> should be set bad, but it currently isn't. =item * Allow the operations in PDL::Ops to skip the check for bad values when using NaN as a bad value and processing a floating-point ndarray. Needs a fair bit of work to PDL::PP::PDLCode. =item * C<< $pdl->badflag() >> now updates all the children of this ndarray as well. However, not sure what to do with parents, since: $y = $x->slice(); $y->badflag(0) doesn't mean that C<$x> shouldn't have its badvalue cleared. however, after $y->badflag(1) it's sensible to assume that the parents now get flagged as containing bad values. PERHAPS you can only clear the bad value flag if you are NOT a child of another ndarray, whereas if you set the flag then all children AND parents should be set as well? Similarly, if you change the bad value in an ndarray, should this be propagated to parent & children? Or should you only be able to do this on the 'top-level' ndarray? Nasty... =item * some of the names aren't appealing - I'm thinking of C in F in particular. Any suggestions appreciated. =back =head1 AUTHOR Copyright (C) Doug Burke (djburke@cpan.org), 2000, 2006. The per-ndarray bad value support is by Heiko Klein (2006). Commercial reproduction of this documentation in a different format is forbidden. =cut PDL-2.074/Basic/Pod/Internals.pod0000644000175000017500000005054614170376466016331 0ustar osboxesosboxes=head1 NAME PDL::Internals - description of some aspects of the current internals =head1 SYNOPSIS # let PDL tell you what it's doing use PDL; PDL::Core::set_debugging(1); $pa = sequence(6, 3, 2); $pb = $pa->slice('1:3'); $pc = $pb->matmult($pb); $pd = $pc->dsumover; print "pb=$pb\npc=$pc\npd=$pd"; =head1 DESCRIPTION =head2 Intro This document explains various aspects of the current implementation of PDL. If you just want to use PDL for something, you definitely do not need to read this. Even if you want to interface your C routines to PDL or create new L functions, you do not need to read this man page (though it may be informative). This document is primarily intended for people interested in debugging or changing the internals of PDL. To read this, a good understanding of the C language and programming and data structures in general is required, as well as some Perl understanding. If you read through this document and understand all of it and are able to point what any part of this document refers to in the PDL core sources and additionally struggle to understand L, you will be awarded the title "PDL Guru". B If it seems that this document has gotten out of date, please inform the PDL porters email list (pdl-devel@lists.sourceforge.net). This may well happen. =head2 ndarrays The pdl data object is generally an opaque scalar reference into a pdl structure in memory. Alternatively, it may be a hash reference with the C field containing the scalar reference (this makes overloading ndarrays easy, see L). You can easily find out at the Perl level which type of ndarray you are dealing with. The example code below demonstrates how to do it: # check if this an ndarray die "not an ndarray" unless UNIVERSAL::isa($pdl, 'PDL'); # is it a scalar ref or a hash ref? if (UNIVERSAL::isa($pdl, "HASH")) { die "not a valid PDL" unless exists $pdl->{PDL} && UNIVERSAL::isa($pdl->{PDL},'PDL'); print "This is a hash reference,", " the PDL field contains the scalar ref\n"; } else { print "This is a scalar ref that points to address $$pdl in memory\n"; } The scalar reference points to the numeric address of a C structure of type C which is defined in F. The mapping between the object at the Perl level and the C structure containing the actual data and structural that makes up an ndarray is done by the PDL typemap. The functions used in the PDL typemap are defined pretty much at the top of the file F. So what does the structure look like: struct pdl { unsigned long magicno; /* Always stores PDL_MAGICNO as a sanity check */ /* This is first so most pointer accesses to wrong type are caught */ int state; /* What's in this pdl */ pdl_trans *trans_parent; /* Opaque pointer to internals of transformation from parent */ pdl_vaffine *vafftrans; void* sv; /* (optional) pointer back to original sv. ALWAYS check for non-null before use. We cannot inc refcnt on this one or we'd never get destroyed */ void *datasv; /* Pointer to SV containing data. Refcnt inced */ void *data; /* Null: no data alloced for this one */ PDL_Indx nvals; /* How many values allocated */ int datatype; PDL_Indx *dims; /* Array of data dimensions */ PDL_Indx *dimincs; /* Array of data default increments */ short ndims; /* Number of data dimensions */ unsigned char *threadids; /* Starting index of the thread index set n */ unsigned char nthreadids; pdl_trans_children trans_children; PDL_Indx def_dims[PDL_NDIMS]; /* Preallocated space for efficiency */ PDL_Indx def_dimincs[PDL_NDIMS]; /* Preallocated space for efficiency */ unsigned char def_threadids[PDL_NTHREADIDS]; struct pdl_magic *magic; void *hdrsv; /* "header", settable from outside */ }; This is quite a structure for just storing some data in - what is going on? =head3 Data storage We are going to start with some of the simpler members: first of all, there is the member void *datasv; which is really a pointer to a Perl SV structure (C). The SV is expected to be representing a string, in which the data of the ndarray is stored in a tightly packed form. This pointer counts as a reference to the SV so the reference count has been incremented when the C was placed here (this reference count business has to do with Perl's garbage collection mechanism -- don't worry if this doesn't mean much to you). This pointer is allowed to have the value C which means that there is no actual Perl SV for this data - for instance, the data might be allocated by a C operation. Note the use of an SV* was purely for convenience, it allows easy transformation of packed data from files into ndarrays. Other implementations are not excluded. The actual pointer to data is stored in the member void *data; which contains a pointer to a memory area with space for PDL_Indx nvals; data items of the data type of this ndarray. PDL_Indx is either 'long' or 'long long' depending on whether your perl is 64bit or not. The data type of the data is stored in the variable int datatype; the values for this member are given in the enum C (see F). Currently we have byte, short, unsigned short, long, index (either long or long long), long long, float and double (plus complex equivalents) types, see also L. =head3 Dimensions The number of dimensions in the ndarray is given by the member int ndims; which shows how many entries there are in the arrays PDL_Indx *dims; PDL_Indx *dimincs; These arrays are intimately related: C gives the sizes of the dimensions and C is always calculated by the code PDL_Indx inc = 1; for(i=0; indims; i++) { it->dimincs[i] = inc; inc *= it->dims[i]; } in the routine C in C. What this means is that the dimincs can be used to calculate the offset by code like PDL_Indx offs = 0; for(i=0; indims; i++) { offs += it->dimincs[i] * index[i]; } but this is not always the right thing to do, at least without checking for certain things first. =head3 Default storage Since the vast majority of ndarrays don't have more than 6 dimensions, it is more efficient to have default storage for the dimensions and dimincs inside the PDL struct. PDL_Indx def_dims[PDL_NDIMS]; PDL_Indx def_dimincs[PDL_NDIMS]; The C and C may be set to point to the beginning of these arrays if C is smaller than or equal to the compile-time constant C. This is important to note when freeing an ndarray struct. The same applies for the threadids: unsigned char def_threadids[PDL_NTHREADIDS]; =head3 Magic It is possible to attach magic to ndarrays, much like Perl's own magic mechanism. If the member pointer struct pdl_magic *magic; is nonzero, the PDL has some magic attached to it. The implementation of magic can be gleaned from the file F in the distribution. =head3 State One of the first members of the structure is int state; The possible flags and their meanings are given in C. These are mainly used to implement the lazy evaluation mechanism and keep track of ndarrays in these operations. =head3 Transformations and virtual affine transformations As you should already know, ndarrays often carry information about where they come from. For example, the code $y = $x->slice("2:5"); $y .= 1; will alter $x. So C<$y> and C<$x> I that they are connected via a C-transformation. This information is stored in the members pdl_trans *trans_parent; pdl_vaffine *vafftrans; Both C<$x> (the I) and C<$y> (the child) store this information about the transformation in appropriate slots of the C structure. C and C are structures that we will look at in more detail below. =head3 The Perl SVs When ndarrays are referred to through Perl SVs, we store an additional reference to it in the member void* sv; in order to be able to return a reference to the user when he wants to inspect the transformation structure on the Perl side. Also, we store an opaque void *hdrsv; which is just for use by the user to hook up arbitrary data with this sv. This one is generally manipulated through L and L calls. =head2 Smart references and transformations: slicing and dicing Smart references and most other fundamental functions operating on ndarrays are implemented via I (as mentioned above) which are represented by the type C in PDL. A transformation links input and output ndarrays and contains all the infrastructure that defines how: =over 4 =item * output ndarrays are obtained from input ndarrays; =item * changes in smart-linked output ndarrays (e.g. the I of a sliced I ndarray) are flowed back to the input ndarray in transformations where this is supported (the most often used example being C here); =item * datatype and size of output ndarrays that need to be created are obtained. =back In general, executing a PDL function on a group of ndarrays results in creation of a transformation of the requested type that links all input and output arguments (at least those that are ndarrays). In PDL functions that support data flow between input and output args (e.g. C, C) this transformation links I (input) and I (output) ndarrays permanently until either the link is explicitly broken by user request (C at the Perl level) or all parents and children have been destroyed. In those cases the transformation is lazy-evaluated, e.g. only executed when ndarray values are actually accessed. In I functions, for example addition (C<+>) and inner products (C), the transformation is installed just as in flowing functions but then the transformation is immediately executed and destroyed (breaking the link between input and output args) before the function returns. It should be noted that the close link between input and output args of a flowing function (like L) requires that ndarray objects that are linked in such a way be kept alive beyond the point where they have gone out of scope from the point of view of Perl: $x = zeroes(20); $y = $x->slice('2:4'); undef $x; # last reference to $x is now destroyed Although $x should now be destroyed according to Perl's rules the underlying C structure must actually only be freed when C<$y> also goes out of scope (since it still references internally some of C<$x>'s data). This example demonstrates that such a dataflow paradigm between PDL objects necessitates a special destruction algorithm that takes the links between ndarrays into account and couples the lifespan of those objects. The non-trivial algorithm is implemented in the function C in F. In fact, most of the code in F is concerned with making sure that ndarrays (Cs) are created, updated and freed at the right times depending on interactions with other ndarrays via PDL transformations (remember, C). =head2 Accessing children and parents of an ndarray When ndarrays are dynamically linked via transformations as suggested above input and output ndarrays are referred to as parents and children, respectively. An example of processing the children of an ndarray is provided by the method L. Consider the following situation: pdl> $x = rvals(7,7,{Centre=>[3,4]}); pdl> $y = $x->slice('2:4,3:5'); pdl> ? vars PDL variables in package main:: Name Type Dimension Flow State Mem ---------------------------------------------------------------- $x Double D [7,7] P 0.38Kb $y Double D [3,3] -C 0.00Kb Now, if I suddenly decide that C<$x> should be flagged as possibly containing bad values, using pdl> $x->badflag(1) then I want the state of C<$y> - its I - to be changed as well (since it will either share or inherit some of C<$x>'s data and so be also I), so that I get a 'B' in the I field: pdl> ? vars PDL variables in package main:: Name Type Dimension Flow State Mem ---------------------------------------------------------------- $x Double D [7,7] PB 0.38Kb $y Double D [3,3] -CB 0.00Kb This bit of magic is performed by the C function, which is in F. Given an ndarray (C), the routine loops through each C structure, where access to this structure is provided by the C macro. The I of the ndarray are stored in the C array, after the I, hence the loop from C to C. Once we have the pointer to the child ndarray, we can do what we want to it; here we change the value of the C variable, but the details are unimportant). What B important is that we call C on this ndarray, to ensure we loop through its children. This recursion ensures we get to all the I of a particular ndarray. Access to I is similar, with the C loop replaced by: for( i = 0; i < trans->vtable->nparents; i++ ) { /* do stuff with parent #i: trans->pdls[i] */ } =head2 What's in a transformation (C) All transformations are implemented as structures struct pdl_trans { int magicno; /* to detect memory overwrites */ short flags; /* state of the trans */ pdl_transvtable *vtable; /* the all important vtable */ int __datatype; /* the type of the transformation */ void *params; /* Opaque pointer to "compiled representation" of transformation */ pdl *pdls[]; /* The pdls involved in the transformation */ }; The C member is an opaque pointer, typically to a C struct that holds the "compiled representation" (generated by L), and is the way that information like C etc get communicated from invoking code to the C function - effectively a closure, in Perl/LISP terms. This is necessary because C is called by a PDL-internal function, and therefore must have a fixed parameter list. The transformation identifies all Cs involved in the trans pdl *pdls[]; This is a C99 "incomplete array type", and works because it is at the end of the struct - PDL allocates the correct amount of memory based on the C member of the C. The trans records the state short flags; and the datatype int __datatype; of the trans (to which all ndarrays must be converted unless they are explicitly typed, PDL functions created with L make sure that these conversions are done as necessary). Most important is the pointer to the vtable (virtual table) that contains the actual functionality pdl_transvtable *vtable; The vtable structure in turn looks something like (slightly simplified from F for clarity) typedef struct pdl_transvtable { int flags; int nparents; /* number of parent pdls (input) */ int npdls; /* number of child pdls (output) */ char *per_pdl_flags; /* optimization flags */ pdl_error (*redodims)(pdl_trans *tr); /* figure out dims of children */ pdl_error (*readdata)(pdl_trans *tr); /* flow parents to children */ pdl_error (*writebackdata)(pdl_trans *tr); /* flow backwards */ pdl_error (*freetrans)(pdl_trans *tr, char); int structsize; char *name; /* the function's name */ } pdl_transvtable; The transformation and vtable code is hardly ever written by hand but rather generated by L from concise descriptions. Certain types of transformations can be optimized very efficiently obviating the need for explicit C and C methods. Those transformations are called I. Most dimension manipulating functions (e.g., C, C) belong to this class. The basic trick is that parent and child of such a transformation work on the same (shared) block of data which they just choose to interpret differently (by using different C, C and C on the same data, compare the C structure above). Each operation on an ndarray sharing data with another one in this way is therefore automatically flowed from child to parent and back -- after all they are reading and writing the same block of memory. This is currently not Perl thread safe -- no big loss since the whole PDL core is not reentrant (Perl threading C PDL threading!). =head2 Callback functions =head3 redodims Works out the dimensions of ndarrays that need to be created and is called from within the API function that should be called to ensure that the dimensions of an ndarray are accessible (F): pdl_error pdl_make_physdims(pdl *it) =head3 readdata and writebackdata Responsible for the actual computations of the child data from the parents or parent data from those of the children, respectively (the dataflow aspect). C populates the children from the parents, and C implements updating the parent(s) from the child(ren) if dataflow is part of that transformation. The PDL core makes sure that these are called as needed when ndarray data is accessed (lazy-evaluation). The general API function to ensure that an ndarray is up-to-date is pdl_error pdl_make_physvaffine(pdl *it) which should be called before accessing ndarray data from XS/C (see F for some examples). =head3 freetrans Frees dynamically allocated memory associated with the trans as needed. If C has previously been called, it will free any vaffine-associated memory. If the C parameter is true, it will also free any bespoke C-connected memory - this will not be the case if called before doing another C. Again, functions built with L make sure that freeing via these callbacks happens at the right times. =head2 Signatures: threading over elementary operations Most of that functionality of PDL threading (automatic iteration of elementary operations over multi-dim ndarrays) is implemented in the file F. The L generated functions (in particular the C and C callbacks) use this infrastructure to make sure that the fundamental operation implemented by the trans is performed in agreement with PDL's threading semantics. =head2 Defining new PDL functions -- Glue code generation Please, see L and examples in the PDL distribution. Implementation and syntax are currently far from perfect but it does a good job! =head2 The Core struct As discussed in L, PDL uses a pointer to a structure to allow PDL modules access to its core routines. The definition of this structure (the C struct) is in F (created by F in F) and looks something like /* Structure to hold pointers core PDL routines so as to be used by * many modules */ struct Core { I32 Version; pdl* (*SvPDLV) ( SV* ); void (*SetSV_PDL) ( SV *sv, pdl *it ); pdl* (*pdlnew) ( ); pdl* (*tmp) ( ); pdl* (*create) (int type); pdl_error (*destroy) (pdl *it); ... } typedef struct Core Core; The first field of the structure (C) is used to ensure consistency between modules at run time; the following code is placed in the BOOT section of the generated xs code: if (PDL->Version != PDL_CORE_VERSION) Perl_croak(aTHX_ "Foo needs to be recompiled against the newly installed PDL"); If you add a new field to the F struct you should: =over 5 =item * discuss it on the pdl porters email list (pdl-devel@lists.sourceforge.net) and use the techniques in L 4.11. =item * increase by 1 the value of the C C macro used to populate the Version field, in F. =item * add documentation (e.g. to L) if it's a "useful" function for external module writers (as well as ensuring the code is as well documented as the rest of PDL ;) =back =head1 BUGS This description is far from perfect. If you need more details or something is still unclear please ask on the pdl-devel mailing list (pdl-devel@lists.sourceforge.net). =head1 AUTHOR Copyright(C) 1997 Tuomas J. Lukka (lukka@fas.harvard.edu), 2000 Doug Burke (djburke@cpan.org), 2002 Christian Soeller & Doug Burke, 2013 Chris Marshall. PDL-2.074/Basic/Pod/Indexing.pod0000644000175000017500000017546114146003631016123 0ustar osboxesosboxes=head1 NAME PDL::Indexing - Introduction to indexing and slicing ndarrays. =head1 OVERVIEW This man page should serve as a first tutorial on the indexing and threading features of I. Like all vectorized languages, PDL automates looping over multi-dimensional data structures ("ndarrays") using a variant of mathematical vector notation. The automatic looping is called "threading", in part because ultimately PDL will implement parallel processing to speed up the loops. A lot of the flexibility and power of PDL relies on the indexing and threading features of the Perl extension. Indexing allows access to the data of an ndarray in a very flexible way. Threading provides efficient vectorization of simple operations. The values of an ndarray are stored compactly as typed values in a single block of memory, not (as in a normal Perl list-of-lists) as individual Perl scalars. In the sections that follow many "methods" are called out -- these are Perl operators that apply to ndarrays. From the L (or L) shell, you can find out more about each method by typing "?" followed by the method name. =head2 Dimension lists A ndarray (PDL variable), in general, is an N-dimensional array where N can be 0 (for a scalar), 1 (e.g. for a sound sample), or higher values for images and more complex structures. Each dimension of the ndarray has a positive integer size. The C interpreter treats each ndarray as a special type of Perl scalar (a blessed Perl object, actually -- but you don't have to know that to use them) that can be used anywhere you can put a normal scalar. You can access the dimensions of an ndarray as a Perl list and otherwise determine the size of an ndarray with several methods. The important ones are: =over 3 =item nelem - the total number of elements in an ndarray =item ndims - returns the number of dimensions in an ndarray =item dims - returns the dimension list of an ndarray as a Perl list =item dim - returns the size of a particular dimension of an ndarray =back =head2 Indexing and Dataflow PDL maintains a notion of "dataflow" between an ndarray and indexed subfields of that ndarray. When you produce an indexed subfield or single element of a parent ndarray, the child and parent remain attached until you manually disconnect them. This lets you represent the same data different ways within your code -- for example, you can consider an RGB image simultaneously as a collection of (R,G,B) values in a 3 x 1000 x 1000 image, and as three separate 1000 x 1000 color planes stored in different variables. Modifying any of the variables changes the underlying memory, and the changes are reflected in all representations of the data. There are two important methods that let you control dataflow connections between a child and parent ndarray: =over 3 =item copy - forces an explicit copy of an ndarray =item sever - breaks the dataflow connection between an ndarray and its parents (if any) =back =head2 Threading and Dimension Order Most PDL operations act on the first few dimensions of their ndarray arguments. For example, C sums all elements along the first dimension in the list (dimension 0). If you feed in a three-dimensional ndarray, then the first dimension is considered the "active" dimension and the later dimensions are "thread" dimensions because they are simply looped over. There are several ways to transpose or re-order the dimension list of an ndarray. Those techniques are very fast since they don't touch the underlying data, only change the way that PDL accesses the data. The main dimension ordering functions are: =over 3 =item mv - moves a particular dimension somewhere else in the dimension list =item xchg - exchanges two dimensions in the dimension list, leaving the rest alone =item reorder - allows wholesale mixing of the dimensions =item clump - clumps together two or more small dimensions into one larger one =item squeeze - eliminates any dimensions of size 1 =back =head2 Physical and Dummy Dimensions =over 5 =item * document Perl level threading =item * threadids =item * update and correct description of slice =item * new functions in slice.pd (affine, lag, splitdim) =item * reworking of paragraph on explicit threading =back =head1 Indexing and threading with PDL A lot of the flexibility and power of PDL relies on the indexing and looping features of the Perl extension. Indexing allows access to the data of an ndarray in a very flexible way. Threading provides efficient implicit looping functionality (since the loops are implemented as optimized C code). ndarrays are Perl objects that represent multidimensional arrays and operations on those. In contrast to simple Perl C<@x> style lists the array data is compactly stored in a single block of memory thus taking up a lot less memory and enabling use of fast C code to implement operations (e.g. addition, etc) on ndarrays. =head2 ndarrays can have children Central to many of the indexing capabilities of PDL are the relation of "parent" and "child" between ndarrays. Many of the indexing commands create a new ndarray from an existing ndarray. The new ndarray is the "child" and the old one is the "parent". The data of the new ndarray is defined by a transformation that specifies how to generate (compute) its data from the parent's data. The relation between the child ndarray and its parent are often bidirectional, meaning that changes in the child's data are propagated back to the parent. (Note: You see, we are aiming in our terminology already towards the new dataflow features. The kind of dataflow that is used by the indexing commands (about which you will learn in a minute) is always in operation, not only when you have explicitly switched on dataflow in your ndarray by saying C<$x-Edoflow>. For further information about data flow check the dataflow man page.) Another way to interpret the ndarrays created by our indexing commands is to view them as a kind of intelligent pointer that points back to some portion or all of its parent's data. Therefore, it is not surprising that the parent's data (or a portion of it) changes when manipulated through this "pointer". After these introductory remarks that hopefully prepared you for what is coming (rather than confuse you too much) we are going to dive right in and start with a description of the indexing commands and some typical examples how they might be used in PDL programs. We will further illustrate the pointer/dataflow analogies in the context of some of the examples later on. There are two different implementations of this ``smart pointer'' relationship: the first one, which is a little slower but works for any transformation is simply to do the transformation forwards and backwards as necessary. The other is to consider the child ndarray a ``virtual'' ndarray, which only stores a pointer to the parent and access information so that routines which use the child ndarray actually directly access the data in the parent. If the virtual ndarray is given to a routine which cannot use it, PDL transparently physicalizes the virtual ndarray before letting the routine use it. Currently (1.94_01) all transformations which are ``affine'', i.e. the indices of the data item in the parent ndarray are determined by a linear transformation (+ constant) from the indices of the child ndarray result in virtual ndarrays. All other indexing routines (e.g. C<-Eindex(...)>) result in physical ndarrays. All routines compiled by PP can accept affine ndarrays (except those routines that pass pointers to external library functions). Note that whether something is affine or not does not affect the semantics of what you do in any way: both $x->index(...) .= 5; $x->slice(...) .= 5; change the data in C<$x>. The affinity does, however, have a significant impact on memory usage and performance. =head2 Slicing ndarrays Probably the most important application of the concept of parent/child ndarrays is the representation of rectangular slices of a physical ndarray by a virtual ndarray. Having talked long enough about concepts let's get more specific. Suppose we are working with a 2D ndarray representing a 5x5 image (it's unusually small so that we can print it without filling several screens full of digits). pdl> $im = sequence(5,5) pdl> p $im [ [ 0 1 2 3 4] [ 5 6 7 8 9] [10 11 12 13 14] [15 16 17 18 19] [20 21 22 23 24] ] pdl> help vars PDL variables in package main:: Name Type Dimension Flow State Mem ---------------------------------------------------------------- $im Double D [5,5] P 0.20Kb [ here it might be appropriate to quickly talk about the C command that provides information about ndarrays in the interactive C or C shell that comes with PDL. ] Now suppose we want to create a 1-D ndarray that just references one line of the image, say line 2; or an ndarray that represents all even lines of the image (imagine we have to deal with even and odd frames of an interlaced image due to some peculiar behaviour of our frame grabber). As another frequent application of slices we might want to create an ndarray that represents a rectangular region of the image with top and bottom reversed. All these effects (and many more) can be easily achieved with the powerful slice function: pdl> $line = $im->slice(':,(2)') pdl> $even = $im->slice(':,1:-1:2') pdl> $area = $im->slice('3:4,3:1') pdl> help vars # or just PDL->vars PDL variables in package main:: Name Type Dimension Flow State Mem ---------------------------------------------------------------- $even Double D [5,2] -C 0.00Kb $im Double D [5,5] P 0.20Kb $line Double D [5] -C 0.00Kb $area Double D [2,3] -C 0.00Kb All three "child" ndarrays are children of C<$im> or in the other (largely equivalent) interpretation pointers to data of C<$im>. Operations on those virtual ndarrays access only those portions of the data as specified by the argument to slice. So we can just print line 2: pdl> p $line [10 11 12 13 14] Also note the difference in the "Flow State" of C<$area> above and below: pdl> p $area pdl> help $area This variable is Double D [2,3] VC 0.00Kb The following demonstrates that C<$im> and C<$line> really behave as you would expect from a pointer-like object (or in the dataflow picture: the changes in C<$line>'s data are propagated back to C<$im>): pdl> $im++ pdl> p $line [11 12 13 14 15] pdl> $line += 2 pdl> p $im [ [ 1 2 3 4 5] [ 6 7 8 9 10] [13 14 15 16 17] [16 17 18 19 20] [21 22 23 24 25] ] Note how assignment operations on the child virtual ndarrays change the parent physical ndarray and vice versa (however, the basic "=" assignment doesn't, use ".=" to obtain that effect. See below for the reasons). The virtual child ndarrays are something like "live links" to the "original" parent ndarray. As previously said, they can be thought of to work similar to a C-pointer. But in contrast to a C-pointer they carry a lot more information. Firstly, they specify the structure of the data they represent (the dimensionality of the new ndarray) and secondly, specify how to create this structure from its parents data (the way this works is buried in the internals of PDL and not important for you to know anyway (unless you want to hack the core in the future or would like to become a PDL guru in general (for a definition of this strange creature see L)). The previous examples have demonstrated typical usage of the slice function. Since the slicing functionality is so important here is an explanation of the syntax for the string argument to slice: $vpdl = $x->slice('ind0,ind1...') where C specifies what to do with index No 0 of the ndarray C<$x>, etc. Each element of the comma separated list can have one of the following forms: =over 6 =item ':' Use the whole dimension =item 'n' Use only index C. The dimension of this index in the resulting virtual ndarray is 1. An example involving those first two index formats: pdl> $column = $im->slice('2,:') pdl> $row = $im->slice(':,0') pdl> p $column [ [ 3] [ 8] [15] [18] [23] ] pdl> p $row [ [1 2 3 4 5] ] pdl> help $column This variable is Double D [1,5] VC 0.00Kb pdl> help $row This variable is Double D [5,1] VC 0.00Kb =item '(n)' Use only index C. This dimension is removed from the resulting ndarray (relying on the fact that a dimension of size 1 can always be removed). The distinction between this case and the previous one becomes important in assignments where left and right hand side have to have appropriate dimensions. pdl> $line = $im->slice(':,(0)') pdl> help $line This variable is Double D [5] -C 0.00Kb pdl> p $line [1 2 3 4 5] Spot the difference to the previous example? =item 'n1:n2' or 'n1:n2:n3' Take the range of indices from C to C or (second form) take the range of indices from C to C with step C. An example for the use of this format is the previous definition of the sub-image composed of even lines. pdl> $even = $im->slice(':,1:-1:2') This example also demonstrates that negative indices work like they do for normal Perl style arrays by counting backwards from the end of the dimension. If C is smaller than C (in the example -1 is equivalent to index 4) the elements in the virtual ndarray are effectively reverted with respect to its parent. =item '*[n]' Add a dummy dimension. The size of this dimension will be 1 by default or equal to C if the optional numerical argument is given. Now, this is really something a bit strange on first sight. What is a dummy dimension? A dummy dimension inserts a dimension where there wasn't one before. How is that done ? Well, in the case of the new dimension having size 1 it can be easily explained by the way in which you can identify a vector (with C elements) with an C<(1,m)> or C<(m,1)> matrix. The same holds obviously for higher dimensional objects. More interesting is the case of a dummy dimensions of size greater than one (e.g. C). This works in the same way as a call to the L function creates a new dummy dimension. So read on and check its explanation below. =item '([n1:n2[:n3]]=i)' [Not yet implemented ??????] With an argument like this you make I. The I will be dimension no. C of the new output ndarray and (if optional part in brackets specified) will extend along the range of indices specified of the respective parent ndarray's dimension. In general an argument like this only makes sense if there are other arguments like this in the same call to slice. The part in brackets is optional for this type of argument. All arguments of this type that specify the same target dimension C have to relate to the same number of indices in their parent dimension. The best way to explain it is probably to give an example, here we make an ndarray that refers to the elements along the space diagonal of its parent ndarray (a cube): $cube = zeroes(5,5,5); $sdiag = $cube->slice('(=0),(=0),(=0)'); The above command creates a virtual ndarray that represents the diagonal along the parents' dimension no. 0, 1 and 2 and makes its dimension 0 (the only dimension) of it. You use the extended syntax if the dimension sizes of the parent dimensions you want to build the diagonal from have different sizes or you want to reverse the sequence of elements in the diagonal, e.g. $rect = zeroes(12,3,5,6,2); $vpdl = $rect->slice('2:7,(0:1=1),(4),(5:4=1),(=1)'); So the elements of $vpdl will then be related to those of its parent in way we can express as: vpdl(i,j) = rect(i+2,j,4,5-j,j) 0<=i<5, 0<=j<2 =back [ work in the new index function: C<$y = $x-Eindex($c);> ???? ] =head2 There are different kinds of assignments in PDL The previous examples have already shown that virtual ndarrays can be used to operate on or access portions of data of a parent ndarray. They can also be used as lvalues in assignments (as the use of C<++> in some of the examples above has already demonstrated). For explicit assignments to the data represented by a virtual ndarray you have to use the overloaded C<.=> operator (which in this context we call I). Why can't you use the normal assignment operator C<=>? Well, you definitely still can use the '=' operator but it wouldn't do what you want. This is due to the fact that the '=' operator cannot be overloaded in the same way as other assignment operators. If we tried to use '=' to try to assign data to a portion of a physical ndarray through a virtual ndarray we wouldn't achieve the desired effect (instead the variable representing the virtual ndarray (a reference to a blessed thingy) would after the assignment just contain the reference to another blessed thingy which would behave to future assignments as a "physical" copy of the original rvalue [this is actually not yet clear and subject of discussions in the PDL developers mailing list]. In that sense it would break the connection of the ndarray to the parent [ isn't this behaviour in a sense the opposite of what happens in dataflow, where C<.=> breaks the connection to the parent? ]. E.g. pdl> $line = $im->slice(':,(2)') pdl> $line = zeroes(5); pdl> $line++; pdl> p $im [ [ 1 2 3 4 5] [ 6 7 8 9 10] [13 14 15 16 17] [16 17 18 19 20] [21 22 23 24 25] ] pdl> p $line [1 1 1 1 1] But using C<.=> pdl> $line = $im->slice(':,(2)') pdl> $line .= zeroes(5) pdl> $line++ pdl> p $im [ [ 1 2 3 4 5] [ 6 7 8 9 10] [ 1 1 1 1 1] [16 17 18 19 20] [21 22 23 24 25] ] pdl> print $line [1 1 1 1 1] Also, you can substitute pdl> $line .= 0; for the assignment above (the zero is converted to a scalar ndarray, with no dimensions so it can be assigned to any ndarray). A nice feature in recent perl versions is lvalue subroutines (i.e., versions 5.6.x and higher including all perls currently supported by PDL). That allows one to use the slicing syntax on both sides of the assignment: pdl> $im->slice(':,(2)') .= zeroes(5)->xvals->float Related to the lvalue sub assignment feature is a little trap for the unwary: recent perls introduced a "feature" which breaks PDL's use of lvalue subs for slice assignments when running under the perl debugger, C. Under the debugger, the above usage gives an error like: C< Can't return a temporary from lvalue subroutine... > So you must use syntax like this: pdl> ($pdl = $im->slice(':,(2)')) .= zeroes(5)->xvals->float which works both with and without the debugger but is arguably clumsy and awkward to read. Note that there can be a problem with assignments like this when lvalue and rvalue ndarrays refer to overlapping portions of data in the parent ndarray: # revert the elements of the first line of $x ($tmp = $x->slice(':,(1)')) .= $x->slice('-1:0,(1)'); Currently, the parent data on the right side of the assignments is not copied before the (internal) assignment loop proceeds. Therefore, the outcome of this assignment will depend on the sequence in which elements are assigned and almost certainly I do what you wanted. So the semantics are currently B for now and liable to change anytime. To obtain the desired behaviour, use ($tmp = $x->slice(':,(1)')) .= $x->slice('-1:0,(1)')->copy; which makes a physical copy of the slice or ($tmp = $x->slice(':,(1)')) .= $x->slice('-1:0,(1)')->sever; which returns the same slice but severs the connection of the slice to its parent. =head2 Other functions that manipulate dimensions Having talked extensively about the L function it should be noted that this is not the only PDL indexing function. There are additional indexing functions which are also useful (especially in the context of threading which we will talk about later). Here are a list and some examples how to use them. =over 4 =item C inserts a dummy dimension of the size you specify (default 1) at the chosen location. You can't wait to hear how that is achieved? Well, all elements with index C<(X,x,Y)> (C<0E=xEsize_of_dummy_dim>) just map to the element with index C<(X,Y)> of the parent ndarray (where C and C refer to the group of indices before and after the location where the dummy dimension was inserted.) This example calculates the x coordinate of the centroid of an image (later we will learn that we didn't actually need the dummy dimension thanks to the magic of implicit threading; but using dummy dimensions the code would also work in a thread-less world; though once you have worked with PDL threads you wouldn't want to live without them again). # centroid ($xd,$yd) = $im->dims; $xc = sum($im*xvals(zeroes($xd))->dummy(1,$yd))/sum($im); Let's explain how that works in a little more detail. First, the product: $xvs = xvals(zeroes($xd)); print $xvs->dummy(1,$yd); # repeat the line $yd times $prod = $im*xvs->dummy(1,$yd); # form the pixel-wise product with # the repeated line of x-values The rest is then summing the results of the pixel-wise product together and normalizing with the sum of all pixel values in the original image thereby calculating the x-coordinate of the "center of mass" of the image (interpreting pixel values as local mass) which is known as the centroid of an image. Next is a (from the point of view of memory consumption) very cheap conversion from grey-scale to RGB, i.e. every pixel holds now a triple of values instead of a scalar. The three values in the triple are, fortunately, all the same for a grey image, so that our trick works well in that it maps all the three members of the triple to the same source element: # a cheap grey-scale to RGB conversion $rgb = $grey->dummy(0,3) Unfortunately this trick cannot be used to convert your old B/W photos to color ones in the way you'd like. :( Note that the memory usage of ndarrays with dummy dimensions is especially sensitive to the internal representation. If the ndarray can be represented as a virtual affine (``vaffine'') ndarray, only the control structures are stored. But if C<$y> in $x = zeroes(10000); $y = $x->dummy(1,10000); is made physical by some routine, you will find that the memory usage of your program has suddenly grown by 100Mb. =item C replaces two dimensions (which have to be of equal size) by one dimension that references all the elements along the "diagonal" along those two dimensions. Here, we have two examples which should appear familiar to anyone who has ever done some linear algebra. Firstly, make a unity matrix: # unity matrix $e = zeroes(float, 3, 3); # make everything zero ($tmp = $e->diagonal(0,1)) .= 1; # set the elements along the diagonal to 1 print $e; Or the other diagonal: ($tmp = $e->slice(':-1:0')->diagonal(0,1)) .= 2; print $e; (Did you notice how we used the slice function to revert the sequence of lines before setting the diagonal of the new child, thereby setting the cross diagonal of the parent ?) Or a mapping from the space of diagonal matrices to the field over which the matrices are defined, the trace of a matrix: # trace of a matrix $trace = sum($mat->diagonal(0,1)); # sum all the diagonal elements =item C and C L exchanges or "transposes" the two specified dimensions. A straightforward example: # transpose a matrix (without explicitly reshuffling data and # making a copy) $prod = $x x $x->xchg(0,1); C<$prod> should now be pretty close to the unity matrix if C<$x> is an orthogonal matrix. Often C will be used in the context of threading but more about that later. L works in a similar fashion. It moves a dimension (specified by its number in the parent) to a new position in the new child ndarray: $y = $x->mv(4,0); # make the 5th dimension of $x the first in the # new child $y The difference between C and C is that C only changes the position of two dimensions with each other, whereas C inserts the first dimension to the place of second, moving the other dimensions around accordingly. =item C collapses several dimensions into one. Its only argument specifies how many dimensions of the source ndarray should be collapsed (starting from the first). An (admittedly unrealistic) example is a 3D ndarray which holds data from a stack of image files that you have just read in. However, the data from each image really represents a 1D time series and has only been arranged that way because it was digitized with a frame grabber. So to have it again as an array of time sequences you say pdl> $seqs = $stack->clump(2) pdl> help vars PDL variables in package main:: Name Type Dimension Flow State Mem ---------------------------------------------------------------- $seqs Double D [8000,50] -C 0.00Kb $stack Double D [100,80,50] P 3.05Mb Unrealistic as it may seem, our confocal microscope software writes data (sometimes) this way. But more often you use clump to achieve a certain effect when using implicit or explicit threading. =back =head2 Calls to indexing functions can be chained As you might have noticed in some of the examples above calls to the indexing functions can be nicely chained since all of these functions return a newly created child object. However, when doing extensive index manipulations in a chain be sure to keep track of what you are doing, e.g. $x->xchg(0,1)->mv(0,4) moves the dimension 1 of C<$x> to position 4 since when the second command is executed the original dimension 1 has been moved to position 0 of the new child that calls the C function. I think you get the idea (in spite of my convoluted explanations). =head2 Propagated assignments ('.=') and dummy dimensions A subtlety related to indexing is the assignment to ndarrays containing dummy dimensions of size greater than 1. These assignments (using C<.=>) are forbidden since several elements of the lvalue ndarray point to the same element of the parent. As a consequence the value of those parent elements are potentially ambiguous and would depend on the sequence in which the implementation makes the assignments to elements. Therefore, an assignment like this: $x = pdl [1,2,3]; $y = $x->dummy(1,4); $y .= yvals(zeroes(3,4)); can produce unexpected results and the results are explicitly B by PDL because when PDL gets parallel computing features, the current result may well change. From the point of view of dataflow the introduction of greater-size-than-one dummy dimensions is regarded as an irreversible transformation (similar to the terminology in thermodynamics) which precludes backward propagation of assignment to a parent (which you had explicitly requested using the C<.=> assignment). A similar problem to watch out for occurs in the context of threading where sometimes dummy dimensions are created implicitly during the thread loop (see below). =head2 Reasons for the parent/child (or "pointer") concept [ this will have to wait a bit ] XXXXX being memory efficient XXXXX in the context of threading XXXXX very flexible and powerful way of accessing portions of ndarray data (in much more general way than sec, etc allow) XXXXX efficient implementation XXXXX difference to section/at, etc. =head2 How to make things physical again [ XXXXX fill in later when everything has settled a bit more ] ** When needed (xsub routine interfacing C lib function) ** How achieved (->physical) ** How to test (isphysical (explain how it works currently)) ** ->copy and ->sever =head1 Threading In the previous paragraph on indexing we have already mentioned the term occasionally but now its really time to talk explicitly about "threading" with ndarrays. The term threading has many different meanings in different fields of computing. Within the framework of PDL it could probably be loosely defined as an implicit looping facility. It is implicit because you don't specify anything like enclosing for-loops but rather the loops are automatically (or 'magically') generated by PDL based on the dimensions of the ndarrays involved. This should give you a first idea why the index/dimension manipulating functions you have met in the previous paragraphs are especially important and useful in the context of threading. The other ingredient for threading (apart from the ndarrays involved) is a function that is threading aware (generally, these are L compiled functions) and that the ndarrays are "threaded" over. So much about the terminology and now let's try to shed some light on what it all means. =head2 Implicit threading - a first example There are two slightly different variants of threading. We start with what we call "implicit threading". Let's pick a practical example that involves looping of a function over many elements of a ndarray. Suppose we have an RGB image that we want to convert to grey-scale. The RGB image is represented by a 3-dim ndarray C where the first dimension contains the three color components of each pixel and C and C are width and height of the image, respectively. Next we need to specify how to convert a color-triple at a given pixel into a grey-value (to be a realistic example it should represent the relative intensity with which our color insensitive eye cells would detect that color to achieve what we would call a natural conversion from color to grey-scale). An approximation that works quite well is to compute the grey intensity from each RGB triplet (r,g,b) as a weighted sum grey-value = 77/256*r + 150/256*g + 29/256*b = inner([77,150,29]/256, [r,g,b]) where the last form indicates that we can write this as an inner product of the 3-vector comprising the weights for red, green and blue components with the 3-vector containing the color components. Traditionally, we might have written a function like the following to process the whole image: my @dims=$im->dims; # here normally check that first dim has correct size (3), etc $grey=zeroes(@dims[1,2]); # make the ndarray for the resulting grey image $w = pdl [77,150,29] / 256; # the vector of weights for ($j=0;$jslice(':,(i),(j)')); set($grey,$i,$j,$tmp); # and set it in the grey-scale image } } Now we write the same using threading (noting that C is a threading aware function defined in the L package) $grey = inner($im,pdl([77,150,29]/256)); We have ended up with a one-liner that automatically creates the ndarray C<$grey> with the right number and size of dimensions and performs the loops automatically (these loops are implemented as fast C code in the internals of PDL). Well, we still owe you an explanation how this 'magic' is achieved. =head2 How does the example work ? The first thing to note is that every function that is threading aware (these are without exception functions compiled from concise descriptions by L, later just called PP-functions) expects a defined (minimum) number of dimensions (we call them core dimensions) from each of its ndarray arguments. The L function expects two one-dimensional (input) parameters from which it calculates a zero-dimensional (output) parameter. We write that symbolically as C and call it C's I, where n represents the size of that dimension. n being equal in the first and second parameter means that those dimensions have to be of equal size in any call. As a different example take the outer product which takes two 1D vectors to generate a 2D matrix, symbolically written as C. The C<[o]> in both examples indicates that this (here third) argument is an output argument. In the latter example the dimensions of first and second argument don't have to agree but you see how they determine the size of the two dimensions of the output ndarray. Here is the point when threading finally enters the game. If you call PP-functions with ndarrays that have I than the required core dimensions the first dimensions of the ndarray arguments are used as the core dimensions and the additional extra dimensions are threaded over. Let us demonstrate this first with our example above $grey = inner($im,$w); # w is the weight vector from above In this case $w is 1D and so supplied just the core dimension, C<$im> is 3D, more specifically C<(3,x,y)>. The first dimension (of size 3) is the required core dimension that matches (as required by inner) the first (and only) dimension of C<$w>. The second dimension is the first thread dimension (of size C) and the third is here the second thread dimension (of size C). The output ndarray is automatically created (as requested by setting C<$grey> to "null" prior to invocation). The output dimensions are obtained by appending the I (here C<(x,y)>) to the core output dimensions (here 0D) to yield the final dimensions of the auto-created ndarray (here C<0D+2D=2D> to yield a 2D output of size C<(x,y)>). So the above command calls the core functionality that computes the inner product of two 1D vectors C times with C<$w> and all 1D slices of the form C<(':,(i),(j)')> of C<$im> and sets the respective elements of the output ndarray C<$grey(i,j)> to the result of each computation. We could write that symbolically as $grey(0,0) = f($w,$im(:,(0),(0))) $grey(1,0) = f($w,$im(:,(1),(0))) . . . $grey(x-2,y-1) = f($w,$im(:,(x-2),(y-1))) $grey(x-1,y-1) = f($w,$im(:,(x-1),(y-1))) But this is done automatically by PDL without writing any explicit Perl loops. We see that the command really creates an output ndarray with the right dimensions and sets the elements indeed to the result of the computation for each pixel of the input image. When even more ndarrays and extra dimensions are involved things get a bit more complicated. We will first give the general rules how the thread dimensions depend on the dimensions of input ndarrays enabling you to figure out the dimensionality of an auto-created output ndarray (for any given set of input ndarrays and core dimensions of the PP-function in question). The general rules will most likely appear a bit confusing on first sight so that we'll set out to illustrate the usage with a set of further examples (which will hopefully also demonstrate that there are indeed many practical situations where threading comes in extremely handy). =head2 A call for coding discipline Before we point out the other technical details of threading, please note this call for programming discipline when using threading: In order to preserve human readability, I comment any nontrivial expression in your code involving threading. Most importantly, for any subroutine, include information at the beginning about what you expect the dimensions to represent (or ranges of dimensions). As a warning, look at this undocumented function and try to guess what might be going on: sub lookup { my ($im,$palette) = @_; my $res; index($palette->xchg(0,1), $im->long->dummy(0,($palette->dim)[0]), ($res=null)); return $res; } Would you agree that it might be difficult to figure out expected dimensions, purpose of the routine, etc ? (If you want to find out what this piece of code does, see below) =head2 How to figure out the loop dimensions There are a couple of rules that allow you to figure out number and size of loop dimensions (and if the size of your input ndarrays comply with the threading rules). Dimensions of any ndarray argument are broken down into two groups in the following: Core dimensions (as defined by the PP-function, see B for a list of PDL primitives) and extra dimensions which comprises all remaining dimensions of that ndarray. For example calling a function C with the signature C with an ndarray C<$x(2,4,7,1,3)> as C results in the semantic splitting of x's dimensions into: core dimensions C<(2,4)> and extra dimensions C<(7,1,3)>. =over 6 =item R0 Core dimensions are identified with the first N dimensions of the respective ndarray argument (and are required). Any further dimensions are extra dimensions and used to determine the loop dimensions. =item R1 The number of (implicit) loop dimensions is equal to the maximal number of extra dimensions taken over the set of ndarray arguments. =item R2 The size of each of the loop dimensions is derived from the size of the respective dimensions of the ndarray arguments. The size of a loop dimension is given by the maximal size found in any of the ndarrays having this extra dimension. =item R3 For all ndarrays that have a given extra dimension the size must be equal to the size of the loop dimension (as determined by the previous rule) or 1; otherwise you raise a runtime exception. If the size of the extra dimension in an ndarray is one it is implicitly treated as a dummy dimension of size equal to that loop dim size when performing the thread loop. =item R4 If an ndarray doesn't have a loop dimension, in the thread loop this ndarray is treated as if having a dummy dimension of size equal to the size of that loop dimension. =item R5 If output auto-creation is used (by setting the relevant ndarray to Cnull> before invocation) the number of dimensions of the created ndarray is equal to the sum of the number of core output dimensions + number of loop dimensions. The size of the core output dimensions is derived from the relevant dimension of input ndarrays (as specified in the function definition) and the sizes of the other dimensions are equal to the size of the loop dimension it is derived from. The automatically created ndarray will be physical (unless dataflow is in operation). =back In this context, note that you can run into the problem with assignment to ndarrays containing greater-than-one dummy dimensions (see above). Although your output ndarray(s) didn't contain any dummy dimensions in the first place they may end up with implicitly created dummy dimensions according to I. As an example, suppose we have a (here unspecified) PP-function with the signature: func((m,n),(m,n,o),(m),[o](m,o)) and you call it with 3 ndarrays C<$x(5,3,10,11)>, C<$y(5,3,2,10,1,12)>, and C<$z(5,1,11,12)> as func($x,$y,$z,($d=null)) then the number of loop dimensions is 3 (by C from C<$y> and C<$z>) with sizes C<(10,11,12)> (by R2); the two output core dimensions are C<(5,2)> (from the signature of func) resulting in a 5-dimensional output ndarray C<$c> of size C<(5,2,10,11,12)> (see R5) and (the automatically created) C<$d> is derived from C<($x,$y,$z)> in a way that can be expressed in pdl pseudo-code as $d(:,:,i,j,k) .= func($x(:,:,i,j),$y(:,:,:,i,0,k),$z(:,0,j,k)) with 0<=i<10, 0<=j<=11, 0<=k<12 If we analyze the color to grey-scale conversion again with these rules in mind we note another great advantage of implicit threading. We can call the conversion with an ndarray representing a pixel (C), a line of rgb pixels (C), a proper color image (C) or a whole stack of RGB images (C). As long as C<$im> is of the form C<(3,...)> the automatically created output ndarray will contain the right number of dimensions and contain the intensity data as we expect it since the loops have been implicitly performed thanks to I. You can easily convince yourself that calling with a color pixel C<$grey> is 0D, with a line it turns out 1D C, with an image we get C and finally we get a converted image stack C. Let's fill these general rules with some more life by going through a couple of further examples. The reader may try to figure out equivalent formulations with explicit for-looping and compare the flexibility of those routines using implicit threading to the explicit formulation. Furthermore, especially when using several thread dimensions it is a useful exercise to check the relative speed by doing some benchmark tests (which we still have to do). First in the row is a slightly reworked centroid example, now coded with threading in mind. # threaded mult to calculate centroid coords, works for stacks as well $xc = sumover(($im*xvals(($im->dims)[0]))->clump(2)) / sumover($im->clump(2)); Let's analyze what's going on step by step. First the product: $prod = $im*xvals(zeroes(($im->dims)[0])) This will actually work for C<$im> being one, two, three, and higher dimensional. If C<$im> is one-dimensional it's just an ordinary product (in the sense that every element of C<$im> is multiplied with the respective element of C), if C<$im> has more dimensions further threading is done by adding appropriate dummy dimensions to C according to R4. More importantly, the two L operations show a first example of how to make use of the dimension manipulating commands. A quick look at sumover's signature will remind you that it will only "gobble up" the first dimension of a given input ndarray. But what if we want to really compute the sum over all elements of the first two dimensions? Well, nothing keeps us from passing a virtual ndarray into sumover which in this case is formed by clumping the first two dimensions of the "parent ndarray" into one. From the point of view of the parent ndarray the sum is now computed over the first two dimensions, just as we wanted, though sumover has just done the job as specified by its signature. Got it ? Another little finesse of writing the code like that: we intentionally used Cclump(2))> instead of C so that we can either pass just an image C<(x,y)> or a stack of images C<(x,y,t)> into this routine and get either just one x-coordinate or a vector of x-coordinates (of size t) in return. Another set of common operations are what one could call "projection operations". These operations take a N-D ndarray as input and return a (N-1)-D "projected" ndarray. These operations are often performed with functions like L, L, L and L. Using again images as examples we might want to calculate the maximum pixel value for each line of an image or image stack. We know how to do that # maxima of lines (as function of line number and time) maximum($stack,($ret=null)); But what if you want to calculate maxima per column when implicit threading always applies the core functionality to the first dimension and threads over all others? How can we achieve that instead the core functionality is applied to the second dimension and threading is done over the others. Can you guess it? Yes, we make a virtual ndarray that has the second dimension of the "parent ndarray" as its first dimension using the C command. # maxima of columns (as function of column number and time) maximum($stack->mv(1,0),($ret=null)); and calculating all the sums of sub-slices over the third dimension is now almost too easy # sums of pixels in time (assuming time is the third dim) sumover($stack->mv(2,0),($ret=null)); Finally, if you want to apply the operation to all elements (like max over all elements or sum over all elements) regardless of the dimensions of the ndarray in question C comes in handy. As an example look at a definition of C (summarised from F): sub sum { PDL::Ufunc::sumover($name->clump(-1),($tmp=null)); return $tmp; # return a 0D ndarray } We have already mentioned that all basic operations support threading and assignment is no exception. So here are a couple of threaded assignments pdl> $im = zeroes(byte, 10,20) pdl> $line = exp(-rvals(10)**2/9) # threaded assignment pdl> $im .= $line # set every line of $im to $line pdl> $im2 .= 5 # set every element of $im2 to 5 By now you probably see how it works and what it does, don't you? To finish the examples in this paragraph here is a function to create an RGB image from what is called a palette image. The palette image consists of two parts: an image of indices into a color lookup table and the color lookup table itself. [ describe how it works ] We are going to use a PP-function we haven't encoutered yet in the previous examples. It is the aptly named L function, signature C<((n),(),[o]())> (see B) with the core functionality that C will return the element with index 2 of the first input ndarray. In this case, C<$ret> will contain the value 4. So here is the example: # a threaded index lookup to generate an RGB, or RGBA or YMCK image # from a palette image (represented by a lookup table $palette and # an color-index image $im) # you can say just dummy(0) since the rules of threading make it fit pdl> index($palette->xchg(0,1), $im->long->dummy(0,($palette->dim)[0]), ($res=null)); Let's go through it and explain the steps involved. Assuming we are dealing with an RGB lookup-table $palette is of size C<(3,x)>. First we exchange the dimensions of the palette so that looping is done over the first dimension of C<$palette> (of size 3 that represent r, g, and b components). Now looking at C<$im>, we add a dummy dimension of size equal to the length of the number of components (in the case we are discussing here we could have just used the number 3 since we have 3 color components). We can use a dummy dimension since for red, green and blue color components we use the same index from the original image, e.g. assuming a certain pixel of C<$im> had the value 4 then the lookup should produce the triple [palette(0,4),palette(1,4),palette(2,4)] for the new red, green and blue components of the output image. Hopefully by now you have some sort of idea what the above piece of code is supposed to do (it is often actually quite complicated to describe in detail how a piece of threading code works; just go ahead and experiment a bit to get a better feeling for it). If you have read the threading rules carefully, then you might have noticed that we didn't have to explicitly state the size of the dummy dimension that we created for C<$im>; when we create it with size 1 (the default) the rules of threading make it automatically fit to the desired size (by rule R3, in our example the size would be 3 assuming a palette of size C<(3,x)>). Since situations like this do occur often in practice this is actually why rule R3 has been introduced (the part that makes dimensions of size 1 fit to the thread loop dim size). So we can just say pdl> index($palette->xchg(0,1),$im->long->dummy(0),($res=null)); Again, you can convince yourself that this routine will create the right output if called with a pixel (C<$im> is 0D), a line (C<$im> is 1D), an image (C<$im> is 2D), ..., an RGB lookup table (palette is C<(3,x)>) and RGBA lookup table (palette is C<(4,x)>, see e.g. OpenGL). This flexibility is achieved by the rules of threading which are made to do the right thing in most situations. To wrap it all up once again, the general idea is as follows. If you want to achieve looping over certain dimensions and have the I applied to another specified set of dimensions you use the dimension manipulating commands to create a (or several) I ndarray(s) so that from the point of view of the I ndarray(s) you get what you want (always having the signature of the function in question and R1-R5 in mind!). Easy, isn't it ? =head2 Output auto-creation and PP-function calling conventions At this point we have to divert to some technical detail that has to do with the general calling conventions of PP-functions and the automatic creation of output arguments. Basically, there are two ways of invoking PDL routines, namely $result = func($x,$y); and func($x,$y,$result); If you are only using implicit threading then the output variable can be automatically created by PDL. You flag that to the PP-function by setting the output argument to a special kind of ndarray that is returned from a call to the function Cnull> that returns an essentially "empty" ndarray (for those interested in details there is a flag in the C pdl structure for this). The dimensions of the created ndarray are determined by the rules of implicit threading: the first dimensions are the core output dimensions to which the threading dimensions are appended (which are in turn determined by the dimensions of the input ndarrays as described above). So you can say func($x,$y,($result=PDL->null)); or $result = func($x,$y) which are B equivalent. Be warned that you can I use output auto-creation when using explicit threading (for reasons explained in the following section on B, the second variant of threading). In "tight" loops you probably want to avoid the implicit creation of a temporary ndarray in each step of the loop that comes along with the "functional" style but rather say # create output ndarray of appropriate size only at first invocation $result = null; for (0...$n) { func($x,$y,$result); # in all but the first invocation $result func2($y); # is defined and has the right size to # take the output provided $y's dims don't change twiddle($result,$x); # do something from $result to $x for iteration } The take-home message of this section once more: be aware of the limitation on output creation when using B. =head2 Explicit threading Having so far only talked about the first flavour of threading it is now about time to introduce the second variant. Instead of shuffling around dimensions all the time and relying on the rules of implicit threading to get it all right you sometimes might want to specify in a more explicit way how to perform the thread loop. It is probably not too surprising that this variant of the game is called I. Now, before we create the wrong impression: it is not either I or I; the two flavours do mix. But more about that later. The two most used functions with explicit threading are L and L. We start with an example that illustrates typical usage of the former: [ # ** this is the worst possible example to start with ] # but can be used to show that $mat += $line is different from # $mat->thread(0) += $line # explicit threading to add a vector to each column of a matrix pdl> $mat = zeroes(4,3) pdl> $line = pdl (3.1416,2,-2) pdl> ($tmp = $mat->thread(0)) += $line In this example, C<$mat-Ethread(0)> tells PDL that you want the second dimension of this ndarray to be threaded over first leading to a thread loop that can be expressed as for (j=0; j<3; j++) { for (i=0; i<4; i++) { mat(i,j) += src(j); } } C takes a list of numbers as arguments which explicitly specify which dimensions to thread over first. With the introduction of explicit threading the dimensions of an ndarray are conceptually split into three different groups the latter two of which we have already encountered: thread dimensions, core dimensions and extra dimensions. Conceptually, it is best to think of those dimensions of an ndarray that have been specified in a call to C as being taken away from the set of normal dimensions and put on a separate stack. So assuming we have an ndarray C saying $y = $x->thread(2,1) creates a new virtual ndarray of dimension C (which we call the remaining dims) that also has 2 thread dimensions of size C<(2,7)>. For the purposes of this document we write that symbolically as C. An important difference to the previous examples where only implicit threading was used is the fact that the core dimensions are matched against the I which are not necessarily the first dimensions of the ndarray. We will now specify how the presence of thread dimensions changes the rules R1-R5 for thread loops (which apply to the special case where none of the ndarray arguments has any thread dimensions). =over 4 =item T0 Core dimensions are matched against the first n I of the ndarray argument (note the difference to R1). Any further I are I and are used to determine the I. =item T1a The number of I is equal to the maximal number of extra dimensions taken over the set of ndarray arguments. =item T1b The number of I is equal to the maximal number of thread dimensions taken over the set of ndarray arguments. =item T1c The total number of I is equal to the sum of I and I. In the thread loop, I are threaded over first followed by I. =item T2 The size of each of the I is derived from the size of the respective dimensions of the ndarray arguments. It is given by the maximal size found in any ndarrays having this thread dimension (for I) or extra dimension (for I). =item T3 This rule applies to any I as well as any I. For all ndarrays that have a given I the size must be equal to the size of the respective I or 1; otherwise you raise a runtime exception. If the size of a I of an ndarray is one it is implicitly treated as a dummy dimension of size equal to the I. =item T4 If an ndarray doesn't have a I that corresponds to an I, in the thread loop this ndarray is treated as if having a dummy dimension of size equal to the size of that loop dimension. =item T4a All ndarrays that do have I must have the same number of thread dimensions. =item T5 Output auto-creation cannot be used if any of the ndarray arguments has any I. Otherwise R5 applies. =back The same restrictions apply with regard to implicit dummy dimensions (created by application of T4) as already mentioned in the section on implicit threading: if any of the output ndarrays has an (explicit or implicitly created) greater-than-one dummy dimension a runtime exception will be raised. Let us demonstrate these rules at work in a generic case. Suppose we have a (here unspecified) PP-function with the signature: func((m,n),(m),(),[o](m)) and you call it with 3 ndarrays C, C, C and an output ndarray C (which can here I be automatically created) as func($x->thread(1,3),$y->thread(0,3),$c,$d->thread(0,1)) From the signature of func and the above call the ndarrays split into the following groups of core, extra and thread dimensions (written in the form C): a(5,10){3,11}[] b(5){3,1}[10,12] c(){}[10] d(5){3,11}[10,12] With this to help us along (it is in general helpful to write the arguments down like this when you start playing with threading and want to keep track of what is going on) we further deduce that the number of explicit loop dimensions is 2 (by T1b from C<$a> and C<$b>) with sizes C<(3,11)> (by T2); 2 implicit loop dimensions (by T1a from C<$b> and C<$d>) of size C<(10,12)> (by T2) and the elements of are computed from the input ndarrays in a way that can be expressed in pdl pseudo-code as for (l=0;l<12;l++) for (k=0;k<10;k++) for (j=0;j<11;j++) effect of treating it as dummy dim (index j) for (i=0;i<3;i++) | d(i,j,:,k,l) = func(a(:,i,:,j),b(i,:,k,0,l),c(k)) Ugh, this example was really not easy in terms of bookkeeping. It serves mostly as an example how to figure out what's going on when you encounter a complicated looking expression. But now it is really time to show that threading is useful by giving some more of our so called "practical" examples. [ The following examples will need some additional explanations in the future. For the moment please try to live with the comments in the code fragments. ] Example 1: *** inverse of matrix represented by eigvecs and eigvals ** given a symmetrical matrix M = A^T x diag(lambda_i) x A ** => inverse M^-1 = A^T x diag(1/lambda_i) x A ** first $tmp = diag(1/lambda_i)*A ** then A^T * $tmp by threaded inner product # index handling so that matrices print correct under pdl $inv .= $evecs*0; # just copy to get appropriately sized output $tmp .= $evecs; # initialise, no back-propagation ($tmp2 = $tmp->thread(0)) /= $evals; # threaded division # and now a matrix multiplication in disguise PDL::Primitive::inner($evecs->xchg(0,1)->thread(-1,1), $tmp->thread(0,-1), $inv->thread(0,1)); # alternative for matrix mult using implicit threading, # first xchg only for transpose PDL::Primitive::inner($evecs->xchg(0,1)->dummy(1), $tmp->xchg(0,1)->dummy(2), ($inv=null)); Example 2: # outer product by threaded multiplication # stress that we need to do it with explicit call to my_biop1 # when using explicit threading $res=zeroes(($x->dims)[0],($y->dims)[0]); my_biop1($x->thread(0,-1),$y->thread(-1,0),$res->(0,1),"*"); # similar thing by implicit threading with auto-created ndarray $res = $x->dummy(1) * $y->dummy(0); Example 3: # different use of thread and unthread to shuffle a number of # dimensions in one go without lots of calls to ->xchg and ->mv # use thread/unthread to shuffle dimensions around # just try it out and compare the child ndarray with its parent $trans = $x->thread(4,1,0,3,2)->unthread; Example 4: # calculate a couple of bounding boxes # $bb will hold BB as [xmin,xmax],[ymin,ymax],[zmin,zmax] # we use again thread and unthread to shuffle dimensions around pdl> $bb = zeroes(double, 2,3 ); pdl> minimum($vertices->thread(0)->clump->unthread(1), $bb->slice('(0),:')); pdl> maximum($vertices->thread(0)->clump->unthread(1), $bb->slice('(1),:')); Example 5: # calculate a self-rationed (i.e. self normalized) sequence of images # uses explicit threading and an implicitly threaded division $stack = read_image_stack(); # calculate the average (per pixel average) of the first $n+1 images $aver = zeroes([stack->dims]->[0,1]); # make the output ndarray sumover($stack->slice(":,:,0:$n")->thread(0,1),$aver); $aver /= ($n+1); $stack /= $aver; # normalize the stack by doing a threaded division # implicit versus explicit # alternatively calculate $aver with implicit threading and auto-creation sumover($stack->slice(":,:,0:$n")->mv(2,0),($aver=null)); $aver /= ($n+1); # =head2 Implicit versus explicit threading In this paragraph we are going to illustrate when explicit threading is preferable over implicit threading and vice versa. But then again, this is probably not the best way of putting the case since you already know: the two flavours do mix. So, it's more about how to get the best of both worlds and, anyway, in the best of Perl traditions: TIMTOWTDI ! [ Sorry, this still has to be filled in in a later release; either refer to above examples or choose some new ones ] Finally, this may be a good place to justify all the technical detail we have been going on about for a couple of pages: why threading ? Well, code that uses threading should be (considerably) faster than code that uses explicit for-loops (or similar Perl constructs) to achieve the same functionality. Especially on supercomputers (with vector computing facilities/parallel processing) PDL threading will be implemented in a way that takes advantage of the additional facilities of these machines. Furthermore, it is a conceptually simple construct (though technical details might get involved at times) and can I reduce the syntactical complexity of PDL code (but keep the admonition for documentation in mind). Once you are comfortable with the I way of thinking (and coding) it shouldn't be too difficult to understand code that somebody else has written than (provided he gave you an idea what expected input dimensions are, etc.). As a general tip to increase the performance of your code: if you have to introduce a loop into your code try to reformulate the problem so that you can use threading to perform the loop (as with anything there are exceptions to this rule of thumb; but the authors of this document tend to think that these are rare cases ;). =head1 PDL::PP =head2 An easy way to define functions that are aware of indexing and threading (and the universe and everything) PDL:PP is part of the PDL distribution. It is used to generate functions that are aware of indexing and threading rules from very concise descriptions. It can be useful for you if you want to write your own functions or if you want to interface functions from an external library so that they support indexing and threading (and maybe dataflow as well, see L). For further details check L. =head1 Appendix A =head2 Affine transformations - a special class of simple and powerful transformations [ This is also something to be added in future releases. Do we already have the general make_affine routine in PDL ? It is possible that we will reference another appropriate man page from here ] =head1 Appendix B =head2 signatures of standard PDL::PP compiled functions A selection of signatures of PDL primitives to show how many dimensions PP compiled functions gobble up (and therefore you can figure out what will be threaded over). Most of those functions are the basic ones defined in C # functions in primitive.pd # sumover ((n),[o]()) prodover ((n),[o]()) axisvalues ((n)) inplace inner ((n),(n),[o]()) outer ((n),(m),[o](n,m)) innerwt ((n),(n),(n),[o]()) inner2 ((m),(m,n),(n),[o]()) inner2t ((j,n),(n,m),(m,k),[o]()) index (1D,0D,[o]) minimum (1D,[o]) maximum (1D,[o]) wstat ((n),(n),(),[o],()) assgn ((),()) # basic operations binary operations ((),(),[o]()) unary operations ((),[o]()) =head1 AUTHOR & COPYRIGHT Copyright (C) 1997 Christian Soeller (c.soeller@auckland.ac.nz) & Tuomas J. Lukka (lukka@fas.harvard.edu). All rights reserved. Although destined for release as a man page with the standard PDL distribution, it is not public domain. Permission is granted to freely distribute verbatim copies of this document provided that no modifications outside of formatting be made, and that this notice remain intact. You are permitted and encouraged to use its code and derivatives thereof in your own source code for fun or for profit as you see fit. PDL-2.074/Basic/Pod/API.pod0000644000175000017500000004031614172737630014771 0ustar osboxesosboxes=head1 NAME PDL::API - making ndarrays from Perl and C/XS code =head1 SYNOPSIS use PDL; sub mkmyndarray { ... } =head1 DESCRIPTION A simple cookbook how to create ndarrays manually. It covers both the Perl and the C/XS level. Additionally, it describes the PDL core routines that can be accessed from other modules. These routines basically define the PDL API. If you need to access ndarrays from C/XS you probably need to know about these functions. Also described is the new (as of PDL 2.058) access to PDL operations via C functions, which the XS functions now call. =head2 Creating an ndarray manually from Perl Sometimes you want to create an ndarray I from binary data. You can do that at the Perl level. Examples in the distribution include some of the IO routines. The code snippet below illustrates the required steps. use Carp; sub mkmyndarray { my $class = shift; my $pdl = $class->new; $pdl->set_datatype($PDL_B); $pdl->setdims([1,3,4]); my $dref = $pdl->get_dataref(); # read data directly from file open my $file, 'nelems*PDL::Core::howbig($pdl->get_datatype); croak "couldn't read enough data" if read( $file, $$dref, $len) != $len; close $file; $pdl->upd_data(); return $pdl; } =head2 Creating an ndarray in C The following example creates an ndarray at the C level. We use the C module which is a good way to interface Perl and C, using the C capability in L 0.68+. Note that to create a "scalar" ndarray (with no dimensions at all, and a single element), just pass a zero-length C array, with C as zero. use PDL::LiteF; $x = myfloatseq(); # exercise our C ndarray constructor print $x->info,"\n"; use Inline with => 'PDL'; use Inline C; Inline->init; # useful if you want to be able to 'do'-load this script __DATA__ __C__ static pdl* new_pdl(int datatype, PDL_Indx dims[], int ndims) { pdl *p = PDL->pdlnew(); if (!p) return p; pdl_error err = PDL->setdims(p, dims, ndims); /* set dims */ if (err.error) { PDL->destroy(p); return NULL; } p->datatype = datatype; /* and data type */ err = PDL->allocdata (p); /* allocate the data chunk */ if (err.error) { PDL->destroy(p); return NULL; } return p; } pdl* myfloatseq() { PDL_Indx dims[] = {5,5,5}; pdl *p = new_pdl(PDL_F,dims,3); if (!p) return p; PDL_Float *dataf = (PDL_Float *) p->data; PDL_Indx i; /* dimensions might be 64bits */ for (i=0;i<5*5*5;i++) dataf[i] = i; /* the data must be initialized ! */ return p; } =head2 Wrapping your own data into an ndarray Sometimes you obtain a chunk of data from another source, for example an image processing library, etc. All you want to do in that case is wrap your data into an ndarray struct at the C level. Examples using this approach can be found in the IO modules (where FastRaw and FlexRaw use it for mmapped access) and the Gimp Perl module (that uses it to wrap Gimp pixel regions into ndarrays). The following script demonstrates a simple example: use PDL::LiteF; use PDL::Core::Dev; use PDL::Graphics::PGPLOT; $y = mkndarray(); print $y->info,"\n"; imag1 $y; use Inline with => 'PDL'; use Inline C; Inline->init; __DATA__ __C__ /* wrap a user supplied chunk of data into an ndarray * You must specify the dimensions (dims,ndims) and * the datatype (constants for the datatypes are declared * in pdl.h; e.g. PDL_B for byte type, etc) * * when the created ndarray 'p' is destroyed on the * Perl side the function passed as the 'delete_magic' * parameter will be called with the pointer to the pdl structure * and the 'delparam' argument. * This gives you an opportunity to perform any clean up * that is necessary. For example, you might have to * explicitly call a function to free the resources * associated with your data pointer. * At the very least 'delete_magic' should zero the ndarray's data pointer: * * void delete_mydata(pdl* pdl, int param) * { * pdl->data = 0; * } * pdl *p = pdl_wrap(mydata, PDL_B, dims, ndims, delete_mydata,0); * * pdl_wrap returns the pointer to the pdl * that was created. */ typedef void (*DelMagic)(pdl *, int param); static void default_magic(pdl *p, int pa) { p->data = 0; } static pdl* pdl_wrap(void *data, int datatype, PDL_Indx dims[], int ndims, DelMagic delete_magic, int delparam) { pdl* p = PDL->pdlnew(); /* get the empty container */ if (!p) return p; pdl_error err = PDL->setdims(p, dims, ndims); /* set dims */ if (err.error) { PDL->destroy(p); return NULL; } p->datatype = datatype; /* and data type */ p->data = data; /* point it to your data */ /* make sure the core doesn't meddle with your data */ p->state |= PDL_DONTTOUCHDATA | PDL_ALLOCATED; if (delete_magic != NULL) PDL->add_deletedata_magic(p, delete_magic, delparam); else PDL->add_deletedata_magic(p, default_magic, 0); return p; } #define SZ 256 /* a really silly function that makes a ramp image * in reality this could be an opaque function * in some library that you are using */ static PDL_Byte* mkramp(void) { PDL_Byte *data; int i; /* should use PDL_Indx to support 64bit pdl indexing */ if ((data = malloc(SZ*SZ*sizeof(PDL_Byte))) == NULL) croak("mkramp: Couldn't allocate memory"); for (i=0;idata) free(p->data); p->data = 0; } pdl* mkndarray() { PDL_Indx dims[] = {SZ,SZ}; pdl *p; p = pdl_wrap((void *) mkramp(), PDL_B, dims, 2, delete_myramp,0); /* the delparam is abitrarily set to 0 */ return p; } =head1 IMPLEMENTATION DETAILS =head2 The Core struct -- getting at PDL core routines at runtime PDL uses a technique similar to that employed by the Tk modules to let other modules use its core routines. A pointer to all shared core PDL routines is stored in the C<$PDL::SHARE> variable. XS code should get hold of this pointer at boot time so that the rest of the C/XS code can then use that pointer for access at run time. This initial loading of the pointer is most easily achieved using the functions C and C that are defined and exported by C. Typical usage with the Inline module has already been demonstrated: use Inline with => 'PDL'; In earlier versions of C, this was achieved like this: use Inline C => Config => INC => &PDL_INCLUDE, TYPEMAPS => &PDL_TYPEMAP, AUTO_INCLUDE => &PDL_AUTO_INCLUDE, # declarations BOOT => &PDL_BOOT; # code for the XS boot section The code returned by C makes sure that F is included and declares the static variables to hold the pointer to the C struct. It looks something like this: print PDL_AUTO_INCLUDE; #include static Core* PDL; /* Structure holds core C functions */ static SV* CoreSV; /* Gets pointer to Perl var holding core structure */ The code returned by C retrieves the C<$PDL::SHARE> variable and initializes the pointer to the C struct. For those who know their way around the Perl API here is the code: perl_require_pv ("PDL/Core.pm"); /* make sure PDL::Core is loaded */ #ifndef aTHX_ #define aTHX_ #endif if (SvTRUE (ERRSV)) Perl_croak(aTHX_ "%s",SvPV_nolen (ERRSV)); if (!(CoreSV = perl_get_sv("PDL::SHARE",FALSE))) /* SV* value */ Perl_croak(aTHX_ "We require the PDL::Core module, which was not found"); if (!(PDL = INT2PTR(Core*,SvIV( CoreSV )))) /* Core* value */ Perl_croak(aTHX_ "Got NULL pointer for PDL"); if (PDL->Version != PDL_CORE_VERSION) Perl_croak(aTHX_ "[PDL->Version: \%d PDL_CORE_VERSION: \%d XS_VERSION: \%s] The code needs to be recompiled against the newly installed PDL", PDL->Version, PDL_CORE_VERSION, XS_VERSION); The C struct contains version info to ensure that the structure defined in F really corresponds to the one obtained at runtime. The code above tests for this if (PDL->Version != PDL_CORE_VERSION) .... For more information on the Core struct see L. With these preparations your code can now access the core routines as already shown in some of the examples above, e.g. pdl *p = PDL->pdlnew(); By default the C variable named C is used to hold the pointer to the C struct. If that is (for whichever reason) a problem you can explicitly specify a name for the variable with the C and the C routines: use Inline C => Config => INC => &PDL_INCLUDE, TYPEMAPS => &PDL_TYPEMAP, AUTO_INCLUDE => &PDL_AUTO_INCLUDE 'PDL_Corep', BOOT => &PDL_BOOT 'PDL_Corep'; Make sure you use the same identifier with C and C and use that same identifier in your own code. E.g., continuing from the example above: pdl *p = PDL_Corep->pdlnew(); =head2 Some selected core routines explained The full definition of the C struct can be found in the file F. In the following the most frequently used member functions of this struct are briefly explained. =over 5 =item * C =item * C =item * C C returns an empty pdl object that is initialised like a "null" but with no data. Example: pdl *p = PDL->pdlnew(); if (!p) return p; pdl_error err = PDL->setdims(p, dims, ndims); /* set dims */ if (err.error) { PDL->destroy(p); return NULL; } p->datatype = PDL_B; Returns C if a problem occurred, so check for that. =item * C Returns C if a problem occurred, so check for that. =item * C =item * C =item * C =item * C =item * C =item * C =item * C =item * C =item * C and C These are C-code equivalents of C and C. They include special handling of error or warning messages during pthreading (i.e. processor multi-threading) that defer the messages until after pthreading is completed. When pthreading is complete, perl's C or C is called with the deferred messages. This is needed to keep from calling perl's C or C during pthreading, which can cause segfaults. Note that C and C have been redefined (using c-preprocessor macros) in pdlcore.h to C<< PDL->barf >> and C<< PDL->warn >>. This is to keep any XS or PP code from calling perl's C or C directly, which can cause segfaults during pthreading. See L for more information on pthreading. B As of 2.064, it is B that you do not call C at all in PP code, but instead use C<$CROAK()>. This will return a C which will transparently be used to throw the correct exception in Perl code, but can be handled suitably by non-Perl callers. =item * safe_indterm Checks given offset is within given ndarray's bounds, else throws an exception. =item * converttype Used by C to change an ndarray's type, converting and possibly re-allocating the data if a different size. If the ndarray's C was set, its C will become the default for the new type. Bad values will still be bad. =item * converttypei_new Affine transformation used only by C to convert an ndarray's type. Not bad-value aware. =item * get_convertedpdl Used by L. =item * affine_new Creates a child vaffine ndarray from given parent ndarray, with given offs (starting point for that pthread in that ndarray), inclist and dims. =item * make_trans_mutual Triggers the actual running of a previously-set-up C. =item * get Get data at given coordinates. =item * get_offs Get data at given offset. =item * put_offs Put data at given offset. =item * setdims_careful Despite the name, just calls C then C with one. =item * destroy Destroy ndarray. =item * reallocdims Cause the ndarray to have given number of dimensions, destroying previous ones. =item * reallocthreadids Reallocate n threadids. Set the new extra ones to the end. =item * resize_defaultincs Recalculate default increments from C, and grow the PDL data. =back =head2 Handy macros from pdl.h Some of the C API functions return C C type which is a structure and therefore requires special handling. You might want to use for example C function: /* THIS DOES NOT WORK! (although it did in older PDL) */ if( PDL->get_pdl_badvalue(a) == 0 ) { ... } /* THIS IS CORRECT */ double bad_a; PDL_Anyval bv = PDL->get_pdl_badvalue(a); if (bv.type < 0) croak("error getting badvalue"); ANYVAL_TO_CTYPE(bad_a, double, bv); if( bad_a == 0 ) { ... } As of PDL 2.014, in F there are the following macros for handling PDL_Anyval from C code: ANYVAL_FROM_CTYPE(out_anyval, out_anyval_type, in_variable) ANYVAL_TO_CTYPE(out_variable, out_ctype, in_anyval) ANYVAL_EQ_ANYVAL(x, y) /* returns -1 on type error */ As of PDL 2.039 (returns -1 rather than croaking on failure as of 2.064) there is: ANYVAL_ISNAN(anyval) As of PDL 2.040 (changed parameter list, also returns -1 rather than croaking on failure, in 2.064) - you need to check the badflag first: ANYVAL_ISBAD(in_anyval, badval) e.g. int badflag = (x->state & PDL_BADVAL) > 0; PDL_Anyval badval = pdl_get_pdl_badvalue(x); if (badflag) { int isbad = ANYVAL_ISBAD(result, badval); if (isbad == -1) croak("ANYVAL_ISBAD error on types %d, %d", result.type, badval.type); if (isbad) RETVAL = newSVpvn( "BAD", 3 ); else ANYVAL_TO_SV(RETVAL, result); } else ANYVAL_TO_SV(RETVAL, result); As of PDL 2.058, there are: ANYVAL_FROM_CTYPE_OFFSET(result, datatype, x, ioff); ANYVAL_TO_CTYPE_OFFSET(x, ioff, datatype, value); The latter dispatches on both the destination type and the input "anyval" type. They are intended for retrieving values from, and setting them within, ndarrays. As of PDL 2.048, in F there are: ANYVAL_FROM_SV(out_anyval, in_SV, use_undefval, forced_type) ANYVAL_TO_SV(out_SV, in_anyval) Because these are used in the PDL F, you will need to include F in any XS file with functions that take or return a C. =head2 Access to PDL operations as C functions As of 2.058, all PDL operations can be accessed from C code in a similar way to XS functions, since that is what the XS functions now call. Each module defines various C functions and data-structures for each operation, as needed to operate as a PDL transformation. The entry point from outside (and from XS functions) is a C function called C, with a signature derived from its C and C. E.g. # from PDL::Primitive pp_def('wtstat', Pars => 'a(n); wt(n); avg(); [o]b();', OtherPars => 'int deg', # ... ); has the C signature: void pdl_wtstat_run(pdl *a, pdl *wt, pdl *avg, pdl *b, int deg); Not very surprisingly, all C parameters must be initialised (at least to C<< PDL->null >> status), and they are changed according to the operation's specification. This makes the XS C<_(name)_int> non-varargs XS functions very thin layers over this. =head1 SEE ALSO L L =head1 BUGS This manpage is still under development. Feedback and corrections are welcome. =head1 COPYRIGHT Copyright 2013 Chris Marshall (chm@cpan.org). Copyright 2010 Christian Soeller (c.soeller@auckland.ac.nz). You can distribute and/or modify this document under the same terms as the current Perl license. See: http://dev.perl.org/licenses/ =cut PDL-2.074/Basic/Pod/ParallelCPU.pod0000644000175000017500000001606014164221257016455 0ustar osboxesosboxes=head1 NAME PDL::ParallelCPU - Parallel processor multi-threading support in PDL =head1 DESCRIPTION PDL has support for splitting up numerical processing between multiple parallel processor threads (or pthreads) using the I and I functions. This can improve processing performance (by greater than 2-4X in most cases) by taking advantage of multi-core and/or multi-processor machines. As of 2.059, L is used to set the number of threads used if C is not set. =head1 SYNOPSIS use PDL; # Set target of 4 parallel pthreads to create, with a lower limit of # 5Meg elements for splitting processing into parallel pthreads. set_autopthread_targ(4); set_autopthread_size(5); $x = zeroes(5000,5000); # Create 25Meg element array $y = $x + 5; # Processing will be split up into multiple pthreads # Get the actual number of pthreads for the last # processing operation. $actualPthreads = get_autopthread_actual(); # Or compare these to see CPU usage (first one only 1 pthread, second one 10) # in the PDL shell: $x = ones(10,1000,10000); set_autopthread_targ(1); $y = sin($x)*cos($x); p get_autopthread_actual; $x = ones(10,1000,10000); set_autopthread_targ(10); $y = sin($x)*cos($x); p get_autopthread_actual; =head1 Terminology The use of the term I can be confusing with PDL, because it can refer to I, as defined in the L docs, or to I. To reduce confusion with the existing PDL threading terminology, this document uses B to refer to I, which is the use of multiple processor threads to split up numerical processing into parallel operations. =head1 Functions that control PDL pthreads This is a brief listing and description of the PDL pthreading functions, see the L docs for detailed information. =over 5 =item set_autopthread_targ Set the target number of processor-threads (pthreads) for multi-threaded processing. Setting auto_pthread_targ to 0 means that no pthreading will occur. See L for details. =item set_autopthread_size Set the minimum size (in Meg-elements or 2**20 elements) of the largest PDL involved in a function where auto-pthreading will be performed. For small PDLs, it probably isn't worth starting multiple pthreads, so this function is used to define a minimum threshold where auto-pthreading won't be attempted. See L for details. =item get_autopthread_actual Get the actual number of pthreads executed for the last pdl processing function. See L for details. =back =head1 Global Control of PDL pthreading using Environment Variables PDL pthreading can be globally turned on, without modifying existing code by setting environment variables B and B before running a PDL script. These environment variables are checked when PDL starts up and calls to I and I functions made with the environment variable's values. For example, if the environment var B is set to 3, and B is set to 10, then any pdl script will run as if the following lines were at the top of the file: set_autopthread_targ(3); set_autopthread_size(10); =head1 How It Works The auto-pthreading process works by analyzing threaded array dimensions in PDL operations and splitting up processing based on the thread dimension sizes and desired number of pthreads (i.e. the pthread target or pthread_targ). The offsets, increments, and dimension-sizes (in case the whole dimension does not divide neatly by the number of pthreads) that PDL uses to step thru the data in memory are modified for each pthread so each one sees a different set of data when performing processing. B $x = sequence(20,4,3); # Small 3-D Array, size 20,4,3 # Setup auto-pthreading: set_autopthread_targ(2); # Target of 2 pthreads set_autopthread_size(0); # Zero so that the small PDLs in this example will be pthreaded # This will be split up into 2 pthreads $c = maximum($x); For the above example, the I function has a signature of C<(a(n); [o]c())>, which means that the first dimension of $x (size 20) is a I dimension of the I function. The other dimensions of $x (size 4,3) are I dimensions (i.e. will be threaded-over in the I function. The auto-pthreading algorithm examines the threaded dims of size (4,3) and picks the 4 dimension, since it is evenly divisible by the autopthread_targ of 2. The processing of the maximum function is then split into two pthreads on the size-4 dimension, with dim indexes 0,2 processed by one pthread and dim indexes 1,3 processed by the other pthread. =head1 Limitations =head2 Must have POSIX Threads Enabled Auto-pthreading only works if your PDL installation was compiled with POSIX threads enabled. This is normally the case if you are running on Windows, Linux, MacOS X, or other unix variants. =head2 Non-Threadsafe Code Not all the libraries that PDL intefaces to are thread-safe, i.e. they aren't written to operate in a multi-threaded environment without crashing or causing side-effects. Some examples in the PDL core is the I function and the I functions. To operate properly with these types of functions, the PPCode flag B has been introduced to indicate a function as I being pthread-safe. See L docs for details. =head2 Size of PDL Dimensions and pthread Target As of PDL 2.058, the threaded dimension sizes do not need to divide exactly by the pthread target, although if one does, it will be used. If no dimension is as large as the pthread target, the number of pthreads will be the size of the largest threaded dimension. In order to minimise idle CPUs on the last iteration at the end of the threaded dimension, the algorithm that picks the dimension to pthread on aims for the largest remainder in dividing the pthread target into the sizes of the threaded dimensions. For example, if a PDL has threaded dimension sizes of (9,6,2) and the I is 4, the algorithm will pick the 1-th (size 6), as that will leave a remainder of 2 (leaving 2 idle at the end) in preference to one with size 9, which would leave 3 idle. =head2 Speed improvement might be less than you expect. If you have an 8-core machine and call I with 8 to generate 8 parallel pthreads, you probably won't get a 8X improvement in speed, due to memory bandwidth issues. Even though you have 8 separate CPUs crunching away on data, you will have (for most common machine architectures) common RAM that now becomes your bottleneck. For simple calculations (e.g simple additions) you can run into a performance limit at about 4 pthreads. For more CPU-bound calculations the limit will be higher. =head1 COPYRIGHT Copyright 2011 John Cerney. You can distribute and/or modify this document under the same terms as the current Perl license. See: http://dev.perl.org/licenses/ PDL-2.074/Basic/Pod/PP.pod0000644000175000017500000027711414200147452014674 0ustar osboxesosboxespackage PDL::PP; __END__ =head1 NAME PDL::PP - Generate PDL routines from concise descriptions =head1 SYNOPSIS # let PDL::PP tell you what it's doing $::PP_VERBOSE = 1; pp_def( 'sumover', Pars => 'a(n); [o]b();', Code => q{ double tmp=0; loop(n) %{ tmp += $a(); %} $b() = tmp; }, ); pp_done(); # do not call exit() as some processing can be done in same process =head1 FUNCTIONS Here is a quick reference list of the functions provided by PDL::PP. =head2 pp_add_boot =for ref Add code to the BOOT section of generated XS file =head2 pp_add_exported =for ref Add functions to the list of exported functions =head2 pp_add_isa =for ref Add entries to the @ISA list =head2 pp_addbegin =for ref Sets code to be added at the top of the generate .pm file =head2 pp_addhdr =for ref Add code and includes to C section of the generated XS file. When used in a module that is "multi-C" (one F<.c> file per Ced function), you need to bear in mind that as each one is generated, all the C so far will be included. Therefore, if you add C functions, make sure to make them C to avoid clashes with later F<.c> files. But a better practice is make them be separate C files, with any necessary F<.h> to be included by them and the F<.pd> file. You can then add them to your F (note this is the C<_int> version, see separate notes on how to "opt-in" for your own modules): my @pack = (["pnm.pd", qw(Pnm PDL::IO::Pnm)]); my %hash = pdlpp_stdargs_int(@pack); $hash{OBJECT} .= ' get$(OBJ_EXT)'; sub MY::postamble { pdlpp_postamble_int(@pack); }; WriteMakefile(%hash); =head2 pp_addpm =for ref Add code to the generated .pm file =head2 pp_addxs =for ref Add extra XS code to the generated XS file =head2 pp_add_macros =for ref Add extra C<$MACRO()> definitions for these functions. Note these generate C code. =for example pp_add_macros(SUCC => sub { "($_[0] + 1)" }); # ... Code => '$a() = $SUCC($b());', =head2 pp_beginwrap =for ref Add BEGIN-block wrapping to code for the generated .pm file =head2 pp_bless =for ref Sets the package to which the XS code is added (default is PDL) =head2 pp_boundscheck =for ref Control state of PDL bounds checking activity =head2 pp_core_importList =for ref Specify what is imported from PDL::Core =head2 pp_def =for ref Define a new PDL function =head2 pp_deprecate_module =for ref Add runtime and POD warnings about a module being deprecated =head2 pp_done =for ref Mark the end of PDL::PP definitions in the file =head2 pp_export_nothing =for ref Clear out the export list for your generated module =head2 pp_line_numbers =for ref Add line number information to simplify debugging of PDL::PP code =head1 OVERVIEW For an alternate introduction to PDL::PP, see L. Why do we need PP? Several reasons: firstly, we want to be able to generate subroutine code for each of the PDL datatypes (PDL_Byte, PDL_Short, etc). AUTOMATICALLY. Secondly, when referring to slices of PDL arrays in Perl (e.g. C<< $x->slice('0:10:2,:') >> or other things such as transposes) it is nice to be able to do this transparently and to be able to do this 'in-place' - i.e, not to have to make a memory copy of the section. PP handles all the necessary element and offset arithmetic for you. There are also the notions of threading (repeated calling of the same routine for multiple slices, see L) and dataflow (see L, and L) which use of PP allows. In much of what follows we will assume familiarity of the reader with the concepts of implicit and explicit threading and index manipulations within PDL. If you have not yet heard of these concepts or are not very comfortable with them it is time to check L. As you may appreciate from its name PDL::PP is a Pre-Processor, i.e. it expands code via substitutions to make real C-code. Technically, the output is XS code (see I) but that is very close to C. So how do you use PP? Well for the most part you just write ordinary C code except for special PP constructs which take the form: $something(something else) or: PPfunction %{ %} The most important PP construct is the form C<$array()>. Consider the very simple PP function to sum the elements of a 1D vector (in fact this is very similar to the actual code used by 'sumover'): pp_def('sumit', Pars => 'a(n); [o]b();', Code => q{ double tmp; tmp = 0; loop(n) %{ tmp += $a(); %} $b() = tmp; } ); What's going on? The C<< Pars => >> line is very important for PP - it specifies all the arguments and their dimensionality. We call this the I of the PP function (compare also the explanations in L). In this case the routine takes a 1-D function as input and returns a 0-D scalar as output. The C<$a()> PP construct is used to access elements of the array a(n) for you - PP fills in all the required C code. You will notice that we are using the C single-quote operator. This is not an accident. You generally want to use single quotes to denote your PP Code sections. PDL::PP uses C<$var()> for its parsing and if you don't use single quotes, Perl will try to interpolate C<$var()>. Also, using the single quote C operator with curly braces makes it look like you are creating a code block, which is What You Mean. (Perl is smart enough to look for nested curly braces and not close the quote until it finds the matching curly brace, so it's safe to have nested blocks.) Under other circumstances, such as when you're stitching together a Code block using string concatenations, it's often easiest to use real single quotes as Code => 'something'.$interpolatable.'somethingelse;' In the simple case here where all elements are accessed the PP construct C is used to loop over all elements in dimension C. Note this feature of PP: ALL DIMENSIONS ARE SPECIFIED BY NAME. This is made clearer if we avoid the PP loop() construct and write the loop explicitly using conventional C: pp_def('sumit', Pars => 'a(n); [o]b();', Code => q{ PDL_Indx i,n_size; double tmp; n_size = $SIZE(n); tmp = 0; for(i=0; ii); } $b() = tmp; }, ); which does the same as before, but is more long-winded. You can see to get element C of a() we say C<< $a(n=>i) >> - we are specifying the dimension by name C. In 2D we might say: Pars=>'a(m,n);', ... tmp += $a(m=>i,n=>j); ... The syntax C<< m=>i >> borrows from Perl hashes, which are in fact used in the implementation of PP. One could also say C<< $a(n=>j,m=>i) >> as order is not important. You can also see in the above example the use of another PP construct - C<$SIZE(n)> to get the length of the dimension C. It should, however, be noted that you shouldn't write an explicit C-loop when you could have used the PP C construct since PDL::PP checks automatically the loop limits for you, usage of C makes the code more concise, etc. But there are certainly situations where you need explicit control of the loop and now you know how to do it ;). To revisit 'Why PP?' - the above code for sumit() will be generated for each data-type. It will operate on slices of arrays 'in-place'. It will thread automatically - e.g. if a 2D array is given it will be called repeatedly for each 1D row (again check L for the details of threading). And then b() will be a 1D array of sums of each row. We could call it with $x->transpose to sum the columns instead. And Dataflow tracing etc. will be available. You can see PP saves the programmer from writing a lot of needlessly repetitive C-code -- in our opinion this is one of the best features of PDL making writing new C subroutines for PDL an amazingly concise exercise. A second reason is the ability to make PP expand your concise code definitions into different C code based on the needs of the computer architecture in question. Imagine for example you are lucky to have a supercomputer at your hands; in that case you want PDL::PP certainly to generate code that takes advantage of the vectorising/parallel computing features of your machine (this a project for the future). In any case, the bottom line is that your unchanged code should still expand to working XS code even if the internals of PDL changed. Also, because you are generating the code in an actual Perl script, there are many fun things that you can do. Let's say that you need to write both sumit (as above) and multit. With a little bit of creativity, we can do for({Name => 'sumit', Init => '0', Op => '+='}, {Name => 'multit', Init => '1', Op => '*='}) { pp_def($_->{Name}, Pars => 'a(n); [o]b();', Code => ' double tmp; tmp = '.$_->{Init}.'; loop(n) %{ tmp '.$_->{Op}.' $a(); %} $b() = tmp; '); } which defines both the functions easily. Now, if you later need to change the signature or dimensionality or whatever, you only need to change one place in your code. Yeah, sure, your editor does have 'cut and paste' and 'search and replace' but it's still less bothersome and definitely more difficult to forget just one place and have strange bugs creep in. Also, adding 'orit' (bitwise or) later is a one-liner. And remember, you really have Perl's full abilities with you - you can very easily read any input file and make routines from the information in that file. For simple cases like the above, the author (Tjl) currently favors the hash syntax like the above - it's not too much more characters than the corresponding array syntax but much easier to understand and change. As of 2.064, the C must not just C, since the signature of the generated functions has changed from returning C to returning a C, which is pre-initialised to a successful return value. You can easily just replace the C with C, which is the variable's name. We should mention here also the ability to get the pointer to the beginning of the data in memory - a prerequisite for interfacing PDL to some libraries. This is handled with the C<$P(var)> directive, see below. When starting work on a new pp_def'ined function, if you make a mistake, you will usually find a pile of compiler errors indicating line numbers in the generated XS file. If you know how to read XS files (or if you want to learn the hard way), you could open the generated XS file and search for the line number with the error. However, a recent addition to PDL::PP helps report the correct line number of your errors: C. Working with the original summit example, if you had a mis-spelling of tmp in your code, you could change the (erroneous) code to something like this and the compiler would give you much more useful information: pp_def('sumit', Pars => 'a(n); [o]b();', Code => pp_line_numbers(__LINE__, q{ double tmp; tmp = 0; loop(n) %{ tmp += $a(); %} $b() = rmp; }) ); For the above situation, my compiler tells me: ... test.pd:15: error: 'rmp' undeclared (first use in this function) ... In my example script (called test.pd), line 15 is exactly the line at which I made my typo: C instead of C. So, after this quick overview of the general flavour of programming PDL routines using PDL::PP let's summarise in which circumstances you should actually use this preprocessor/precompiler. You should use PDL::PP if you want to =over 3 =item * interface PDL to some external library =item * write some algorithm that would be slow if coded in Perl (this is not as often as you think; take a look at threading and dataflow first). =item * be a PDL developer (and even then it's not obligatory) =back =head1 WARNING Because of its architecture, PDL::PP can be both flexible and easy to use on the one hand, yet exuberantly complicated at the same time. Currently, part of the problem is that error messages are not very informative and if something goes wrong, you'd better know what you are doing and be able to hack your way through the internals (or be able to figure out by trial and error what is wrong with your args to C). Although work is being done to produce better warnings, do not be afraid to send your questions to the mailing list if you run into trouble. =head1 DESCRIPTION Now that you have some idea how to use C to define new PDL functions it is time to explain the general syntax of C. C takes as arguments first the name of the function you are defining and then a hash list that can contain various keys. Based on these keys PP generates XS code and a .pm file. The function C (see example in the SYNOPSIS) is used to tell PDL::PP that there are no more definitions in this file and it is time to generate the .xs and .pm file. As a consequence, there may be several pp_def() calls inside a file (by convention files with PP code have the extension .pd or .pp) but generally only one pp_done(). There are two main different types of usage of pp_def(), the 'data operation' and 'slice operation' prototypes. The 'data operation' is used to take some data, mangle it and output some other data; this includes for example the '+' operation, matrix inverse, sumover etc and all the examples we have talked about in this document so far. Implicit and explicit threading and the creation of the result are taken care of automatically in those operations. You can even do dataflow with C, C, etc (don't be dismayed if you don't understand the concept of dataflow in PDL very well yet; it is still very much experimental). The 'slice operation' is a different kind of operation: in a slice operation, you are not changing any data, you are defining correspondences between different elements of two ndarrays (examples include the index manipulation/slicing function definitions in the file F that is part of the PDL distribution; but beware, this is not introductory level stuff). To support bad values, additional keys are required for C, as explained below. If you are just interested in communicating with some external library (for example some linear algebra/matrix library), you'll usually want the 'data operation' so we are going to discuss that first. =head1 DATA OPERATION =head2 A simple example In the data operation, you must know what dimensions of data you need. First, an example with scalars: pp_def('add', Pars => 'a(); b(); [o]c();', Code => '$c() = $a() + $b();' ); That looks a little strange but let's dissect it. The first line is easy: we're defining a routine with the name 'add'. The second line simply declares our parameters and the parentheses mean that they are scalars. We call the string that defines our parameters and their dimensionality the I of that function. For its relevance with regard to threading and index manipulations check the L man page. The third line is the actual operation. You need to use the dollar signs and parentheses to refer to your parameters (this will probably change at some point in the future, once a good syntax is found). These lines are all that is necessary to actually define the function for PDL (well, actually it isn't; you additionally need to write a Makefile.PL (see below) and build the module (something like 'perl Makefile.PL; make'); but let's ignore that for the moment). So now you can do use MyModule; $x = pdl 2,3,4; $y = pdl 5; $c = add($x,$y); # or add($x,$y,($c=null)); # Alternative form, useful if $c has been # preset to something big, not useful here. and have threading work correctly (the result is $c == [7 8 9]). =head2 The Pars section: the signature of a PP function Seeing the above example code you will most probably ask: what is this strange C<$c=null> syntax in the second call to our new C function? If you take another look at the definition of C you will notice that the third argument C is flagged with the qualifier C<[o]> which tells PDL::PP that this is an output argument. So the above call to add means 'create a new $c from scratch with correct dimensions' - C is a special token for 'empty ndarray' (you might ask why we haven't used the value C to flag this instead of the PDL specific C; we are currently thinking about it ;). [This should be explained in some other section of the manual as well!!] The reason for having this syntax as an alternative is that if you have really huge ndarrays, you can do $c = PDL->null; for(some long loop) { # munge a,b add($x,$y,$c); # munge c, put something back to x,y } and avoid allocating and deallocating $c each time. It is allocated once at the first add() and thereafter the memory stays until $c is destroyed. If you just say $c = add($x,$y); the code generated by PP will automatically fill in C<$c=null> and return the result. If you want to learn more about the reasons why PDL::PP supports this style where output arguments are given as last arguments check the L man page. C<[o]> is not the only qualifier a pdl argument can have in the signature. Another important qualifier is the C<[t]> option which flags a pdl as temporary. What does that mean? You tell PDL::PP that this pdl is only used for temporary results in the course of the calculation and you are not interested in its value after the computation has been completed. But why should PDL::PP want to know about this in the first place? The reason is closely related to the concepts of pdl auto creation (you heard about that above) and implicit threading. If you use implicit threading the dimensionality of automatically created pdls is actually larger than that specified in the signature. With C<[o]> flagged pdls will be created so that they have the additional dimensions as required by the number of implicit thread dimensions. When creating a temporary pdl, however, it will always only be made big enough so that it can hold the result for one iteration in a thread loop, i.e. as large as required by the signature. So less memory is wasted when you flag a pdl as temporary. Secondly, you can use output auto creation with temporary pdls even when you are using explicit threading which is forbidden for normal output pdls flagged with C<[o]> (see L). As of 2.073, the user is unable to pass a C<[t]> parameter, and PDL will create and size it to its notional size, times the number of threads. Here is an example where we use the C<[t]> qualifier. We define the function C that calls a C routine C which needs a temporary array of the same size and type as the array C (sorry about the forward reference for C<$P>; it's a pointer access, see below) : pp_def('callf', Pars => 'a(n); [t] tmp(n); [o] b()', Code => 'PDL_Indx ns = $SIZE(n); f($P(a),$P(b),$P(tmp),ns); ' ); Another possible qualifier is C<[phys]>. If given, this means the pdl will have L called on it. Additionally, if it has a specified dimension C that has value 1, C will not magically be grown if C is larger in another pdl with specified dimension C, and instead an exception will be thrown. E.g.: pp_def('callf', Pars => 'a(n); [phys] b(n); [o] c()', # ... ); If C had lead dimension of 2 and C of 3, an exception will always be thrown. However, if C has lead dimension of 1, it would be silently repeated as if it were 2, if it were not a C parameter. =head2 Argument dimensions and the signature Now we have just talked about dimensions of pdls and the signature. How are they related? Let's say that we want to add a scalar + the index number to a vector: pp_def('add2', Pars => 'a(n); b(); [o]c(n);', Code => 'loop(n) %{ $c() = $a() + $b() + n; %}' ); There are several points to notice here: first, the C argument now contains the I arguments to show that we have a single dimensions in I and I. It is important to note that dimensions are actual entities that are accessed by name so this declares I and I to have the B first dimensions. In most PP definitions the size of named dimensions will be set from the respective dimensions of non-output pdls (those with no C<[o]> flag) but sometimes you might want to set the size of a named dimension explicitly through an integer parameter. See below in the description of the C section how that works. =head2 Constant argument dimensions in the signature Suppose you want an output ndarray to be created automatically and you know that on every call its dimension will have the same size (say 9) regardless of the dimensions of the input ndarrays. In this case you use the following syntax in the Pars section to specify the size of the dimension: ' [o] y(n=9); ' As expected, extra dimensions required by threading will be created if necessary. If you need to assign a named dimension according to a more complicated formula (than a constant) you must use the C key described below. =head2 Type conversions and the signature The signature also determines the type conversions that will be performed when a PP function is invoked. So what happens when we invoke one of our previously defined functions with pdls of different type, e.g. add2($x,$y,($ret=null)); where $x is of type C and $y of type C? With the signature as shown in the definition of C above the datatype of the operation (as determined at runtime) is that of the pdl with the 'highest' type (sequence is byte < short < ushort < long < float < double). In the add2 example the datatype of the operation is float ($x has that datatype). All pdl arguments are then type converted to that datatype (they are not converted inplace but a copy with the right type is created if a pdl argument doesn't have the type of the operation). Null pdls don't contribute a type in the determination of the type of the operation. However, they will be created with the datatype of the operation; here, for example, $ret will be of type float. You should be aware of these rules when calling PP functions with pdls of different types to take the additional storage and runtime requirements into account. These type conversions are correct for most functions you normally define with C. However, there are certain cases where slightly modified type conversion behaviour is desired. For these cases additional qualifiers in the signature can be used to specify the desired properties with regard to type conversion. These qualifiers can be combined with those we have encountered already (the I C<[o]> and C<[t]>). Let's go through the list of qualifiers that change type conversion behaviour. The most important is the C qualifier which comes in handy when a pdl argument represents indices into another pdl. Let's take a look at an example from C: pp_def('maximum_ind', Pars => 'a(n); indx [o] b()', Code => '$GENERIC() cur; PDL_Indx curind; loop(n) %{ if (!n || $a() > cur) {cur = $a(); curind = n;} %} $b() = curind;', ); The function C finds the index of the largest element of a vector. If you look at the signature you notice that the output argument C has been declared with the additional C qualifier. This has the following consequences for type conversions: regardless of the type of the input pdl C the output pdl C will be of type C which makes sense since C will represent an index into C. Note that 'curind' is declared as type C and not C. While most datatype declarations in the 'Pars' section use the same name as the underlying C type, C is a type which is sufficient to handle PDL indexing operations. For 32-bit installs, it can be a 32-bit integer type. For 64-bit installs, it will be a 64-bit integer type. Furthermore, if you call the function with an existing output pdl C its type will not influence the datatype of the operation (see above). Hence, even if C is of a smaller type than C it will not be converted to match the type of C but stays untouched, which saves memory and CPU cycles and is the right thing to do when C represents indices. Also note that you can use the 'indx' qualifier together with other qualifiers (the C<[o]> and C<[t]> qualifiers). Order is significant -- type qualifiers precede creation qualifiers (C<[o]> and C<[t]>). The above example also demonstrates typical usage of the C<$GENERIC()> macro. It expands to the current type in a so called generic loop. What is a generic loop? As you already heard a PP function has a runtime datatype as determined by the type of the pdl arguments it has been invoked with. The PP generated XS code for this function therefore contains a switch like C that selects a case based on the runtime datatype of the function (it's called a type ``loop'' because there is a loop in PP code that generates the cases). In any case your code is inserted once for each PDL type into this switch statement. The C<$GENERIC()> macro just expands to the respective type in each copy of your parsed code in this C statement, e.g., in the C section C will expand to C and so on for the other case statements. I guess you realise that this is a useful macro to hold values of pdls in some code. There are a couple of other qualifiers with similar effects as C. For your convenience there are the C and C qualifiers with analogous consequences on type conversions as C. Let's assume you have a I large array for which you want to compute row and column sums with an equivalent of the C function. However, with the normal definition of C you might run into problems when your data is, e.g. of type short. A call like sumover($large_pdl,($sums = null)); will result in C<$sums> be of type short and is therefore prone to overflow errors if C<$large_pdl> is a very large array. On the other hand calling @dims = $large_pdl->dims; shift @dims; sumover($large_pdl,($sums = zeroes(double,@dims))); is not a good alternative either. Now we don't have overflow problems with C<$sums> but at the expense of a type conversion of C<$large_pdl> to double, something bad if this is really a large pdl. That's where C comes in handy: pp_def('sumoverd', Pars => 'a(n); double [o] b()', Code => 'double tmp=0; loop(n) %{ tmp += a(); %} $b() = tmp;', ); This gets us around the type conversion and overflow problems. Again, analogous to the C qualifier C results in C always being of type double regardless of the type of C without leading to a type conversion of C as a side effect. There is also a special type, C. The others above are all actual PDL/C datatypes, but C is a modifier; if the operation type is real, it has no effect; if it is complex, then the parameter will be the real version - so C becomes C, etc. There is also the converse, C. If the operation is already complex, there is no effect; if not, the output will be promoted to the type's L, which defaults to C. Note this is controlled both by the L data, and the code in L. B Because this outputs floating-point data, the inputs will by definition be turned into such. Therefore, it only makes sense to have floating-point C inputs. If you want to default to coercing inputs to C, give that as the last C as the generated XS function defaults to the last-given one. Hence (with the C and C omitted): pp_def('r2C', GenericTypes=>[reverse qw(F D G C)], # last one is default so here = F Pars => 'r(); complex [o]c()', Code => '$c() = $r();' ); Finally, there are the C qualifiers where type is one of C or C. What shall that mean. Let's illustrate the C qualifier with the actual definition of sumover: pp_def('sumover', Pars => 'a(n); int+ [o] b()', Code => '$GENERIC(b) tmp=0; loop(n) %{ tmp += a(); %} $b() = tmp;', ); As we had already seen for the C, C and C qualifiers, a pdl marked with a C qualifier does not influence the datatype of the pdl operation. Its meaning is "make this pdl at least of type C or higher, as required by the type of the operation". In the sumover example this means that when you call the function with an C of type PDL_Short the output pdl will be of type PDL_Long (just as would have been the case with the C qualifier). This again tries to avoid overflow problems when using small datatypes (e.g. byte images). However, when the datatype of the operation is higher than the type specified in the C qualifier C will be created with the datatype of the operation, e.g. when C is of type double then C will be double as well. We hope you agree that this is sensible behaviour for C. It should be obvious how the C qualifier works by analogy. It may become necessary to be able to specify a set of alternative types for the parameters. However, this will probably not be implemented until someone comes up with a reasonable use for it. Note that we now had to specify the C<$GENERIC> macro with the name of the pdl to derive the type from that argument. Why is that? If you carefully followed our explanations you will have realised that in some cases C will have a different type than the type of the operation. Calling the '$GENERIC' macro with C as argument makes sure that the type will always the same as that of C in that part of the generic loop. This is about all there is to say about the C section in a C call. You should remember that this section defines the I of a PP defined function, you can use several options to qualify certain arguments as output and temporary args and all dimensions that you can later refer to in the C section are defined by name. It is important that you understand the meaning of the signature since in the latest PDL versions you can use it to define threaded functions from within Perl, i.e. what we call I. Please check L for details. =head2 The Code section The C section contains the actual XS code that will be in the innermost part of a thread loop (if you don't know what a thread loop is then you still haven't read L; do it now ;) after any PP macros (like C<$GENERIC>) and PP functions have been expanded (like the C function we are going to explain next). Let's quickly reiterate the C example: pp_def('sumover', Pars => 'a(n); int+ [o] b()', Code => '$GENERIC(b) tmp=0; loop(n) %{ tmp += a(); %} $b() = tmp;', ); The C construct in the C section also refers to the dimension name so you don't need to specify any limits: the loop is correctly sized and everything is done for you, again. Next, there is the surprising fact that C<$a()> and C<$b()> do B contain the index. This is not necessary because we're looping over I and both variables know which dimensions they have so they automatically know they're being looped over. This feature comes in very handy in many places and makes for much shorter code. Of course, there are times when you want to circumvent this; here is a function which make a matrix symmetric and serves as an example of how to code explicit looping: pp_def('symm', Pars => 'a(n,n); [o]c(n,n);', Code => 'loop(n) %{ int n2; for(n2=n; n2<$SIZE(n); n2++) { $c(n0 => n, n1 => n2) = $c(n0 => n2, n1 => n) = $a(n0 => n, n1 => n2); } %} ' ); Let's dissect what is happening. Firstly, what is this function supposed to do? From its signature you see that it takes a 2D matrix with equal numbers of columns and rows and outputs a matrix of the same size. From a given input matrix $a it computes a symmetric output matrix $c (symmetric in the matrix sense that A^T = A where ^T means matrix transpose, or in PDL parlance $c == $c->transpose). It does this by using only the values on and below the diagonal of $a. In the output matrix $c all values on and below the diagonal are the same as those in $a while those above the diagonal are a mirror image of those below the diagonal (above and below are here interpreted in the way that PDL prints 2D pdls). If this explanation still sounds a bit strange just go ahead, make a little file into which you write this definition, build the new PDL extension (see section on Makefiles for PP code) and try it out with a couple of examples. Having explained what the function is supposed to do there are a couple of points worth noting from the syntactical point of view. First, we get the size of the dimension named C again by using the C<$SIZE> macro. Second, there are suddenly these funny C and C index names in the code though the signature defines only the dimension C. Why this? The reason becomes clear when you note that both the first and second dimension of $a and $b are named C in the signature of C. This tells PDL::PP that the first and second dimension of these arguments should have the same size. Otherwise the generated function will raise a runtime error. However, now in an access to C<$a> and C<$c> PDL::PP cannot figure out which index C refers to any more just from the name of the index. Therefore, the indices with equal dimension names get numbered from left to right starting at 0, e.g. in the above example C refers to the first dimension of C<$a> and C<$c>, C to the second and so on. In all examples so far, we have only used the C and C members of the hash that was passed to C. There are certainly other keys that are recognised by PDL::PP and we will hear about some of them in the course of this document. Find a (non-exhaustive) list of keys in Appendix A. A list of macros and PPfunctions (we have only encountered some of those in the examples above yet) that are expanded in values of the hash argument to C is summarised in Appendix B. At this point, it might be appropriate to mention that PDL::PP is not a completely static, well designed set of routines (as Tuomas puts it: "stop thinking of PP as a set of routines carved in stone") but rather a collection of things that the PDL::PP author (Tuomas J. Lukka) considered he would have to write often into his PDL extension routines. PP tries to be expandable so that in the future, as new needs arise, new common code can be abstracted back into it. If you want to learn more on why you might want to change PDL::PP and how to do it check the section on PDL::PP internals. =head2 Handling bad values There are several keys and macros used when writing code to handle bad values. The first one is the C key: =over 4 =item HandleBad => 0 This flags a pp-routine as I handling bad values. If this routine is sent ndarrays with their C set, then a warning message is printed to STDOUT and the ndarrays are processed as if the value used to represent bad values is a valid number. The C value is not propagated to the output ndarrays. An example of when this is used is for FFT routines, which generally do not have a way of ignoring part of the data. =item HandleBad => 1 This causes PDL::PP to write extra code that ensures the BadCode section is used, and that the C<$ISBAD()> macro (and its brethren) work. If no C is supplied, the C section will be used, on the assumption it will use C to handle bad values. =item HandleBad is not given If any of the input ndarrays have their C set, then the output ndarrays will have their C set, but any supplied BadCode is ignored. =back The value of C is used to define the contents of the C key, if it is not given. To handle bad values, code must be written somewhat differently; for instance, $c() = $a() + $b(); becomes something like if ( $a() != BADVAL && $b() != BADVAL ) { $c() = $a() + $b(); } else { $c() = BADVAL; } However, we only want the second version if bad values are present in the input ndarrays (and that bad-value support is wanted!) - otherwise we actually want the original code. This is where the C key comes in; you use it to specify the code to execute if bad values may be present, and PP uses both it and the C section to create something like: if ( bad_values_are_present ) { fancy_threadloop_stuff { BadCode } } else { fancy_threadloop_stuff { Code } } This approach means that there is virtually no overhead when bad values are not present (i.e. the L routine returns 0). The C preprocessor symbol C is defined when the bad code is compiled, so that you can reduce the amount of code you write. The BadCode section can use the same macros and looping constructs as the Code section. As of 2.073, you can also use C. =head2 Other bad-value macros However, it wouldn't be much use without the following additional macros: =head3 $ISBAD(var) To check whether an ndarray's value is bad, use the C<$ISBAD> macro: if ( $ISBAD(a()) ) { printf("a() is bad\n"); } You can also access given elements of an ndarray: if ( $ISBAD(a(n=>l)) ) { printf("element %d of a() is bad\n", l); } =head3 $ISGOOD(var) This is the opposite of the C<$ISBAD> macro. =head3 $SETBAD(var) For when you want to set an element of an ndarray bad. =head3 $ISBADVAR(c_var,pdl) If you have cached the value of an ndarray C<$a()> into a c-variable (C say), then to check whether it is bad, use C<$ISBADVAR(foo,a)>. =head3 $ISGOODVAR(c_var,pdl) As above, but this time checking that the cached value isn't bad. =head3 $SETBADVAR(c_var,pdl) To copy the bad value for an ndarray into a c variable, use C<$SETBADVAR(foo,a)>. I mention the C and C options to C, as well as the C key. I mention C<$PPISBAD()> etc macros. =head2 PDL STATE macros If you want access to the value of the badflag for a given ndarray, you can use the PDL STATE macros: =over 4 =item $ISPDLSTATEBAD(pdl) =item $ISPDLSTATEGOOD(pdl) =item $SETPDLSTATEBAD(pdl) =item $SETPDLSTATEGOOD(pdl) =back =head2 Bad-value examples Using these macros, the above code could be specified as: Code => '$c() = $a() + $b();', BadCode => ' if ( $ISBAD(a()) || $ISBAD(b()) ) { $SETBAD(c()); } else { $c() = $a() + $b(); }', Since this is Perl, TMTOWTDI, so you could also write: BadCode => ' if ( $ISGOOD(a()) && $ISGOOD(b()) ) { $c() = $a() + $b(); } else { $SETBAD(c()); }', You can reduce code repetition using the C C macro, supplying only the C section: Code => ' #ifdef PDL_BAD_CODE if ( $ISGOOD(a()) && $ISGOOD(b()) ) { #endif PDL_BAD_CODE $c() = $a() + $b(); #ifdef PDL_BAD_CODE } else { $SETBAD(c()); } #endif PDL_BAD_CODE ', As of 2.073, you can also use C: Code => ' PDL_IF_BAD(if ( $ISGOOD(a()) && $ISGOOD(b()) ) {,) $c() = $a() + $b(); PDL_IF_BAD(} else $SETBAD(c());,) ', =head2 Interfacing your own/library functions using PP Now, consider the following: you have your own C function (that may in fact be part of some library you want to interface to PDL) which takes as arguments two pointers to vectors of double: void myfunc(int n,double *v1,double *v2); The correct way of defining the PDL function is pp_def('myfunc', Pars => 'a(n); [o]b(n);', GenericTypes => ['D'], Code => 'myfunc($SIZE(n),$P(a),$P(b));' ); The C<$P(>IC<)> syntax returns a pointer to the first element and the other elements are guaranteed to lie after that. Notice that here it is possible to make many mistakes. First, C<$SIZE(n)> must be used instead of C. Second, you shouldn't put any loops in this code. Third, here we encounter a new hash key recognised by PDL::PP : the C declaration tells PDL::PP to ONLY GENERATE THE TYPELOOP FOP THE LIST OF TYPES SPECIFIED. In this case C. This has two advantages. Firstly the size of the compiled code is reduced vastly, secondly if non-double arguments are passed to C PDL will automatically convert them to double before passing to the external C routine and convert them back afterwards. One can also use C to qualify the types of individual arguments. Thus one could also write this as: pp_def('myfunc', Pars => 'double a(n); double [o]b(n);', Code => 'myfunc($SIZE(n),$P(a),$P(b));' ); The type specification in C exempts the argument from variation in the typeloop - rather it is automatically converted to and from the type specified. This is obviously useful in a more general example, e.g.: void myfunc(int n,float *v1,long *v2); pp_def('myfunc', Pars => 'float a(n); long [o]b(n);', GenericTypes => ['F'], Code => 'myfunc($SIZE(n),$P(a),$P(b));' ); Note we still use C to reduce the size of the type loop, obviously PP could in principle spot this and do it automatically though the code has yet to attain that level of sophistication! Finally note when types are converted automatically one MUST use the C<[o]> qualifier for output variables or you hard-won changes will get optimised away by PP! If you interface a large library you can automate the interfacing even further. Perl can help you again(!) in doing this. In many libraries you have certain calling conventions. This can be exploited. In short, you can write a little parser (which is really not difficult in Perl) that then generates the calls to C from parsed descriptions of the functions in that library. For an example, please check the I interface in the C tree of the PDL distribution. If you want to check (during debugging) which calls to PP functions your Perl code generated a little helper package comes in handy which replaces the PP functions by identically named ones that dump their arguments to stdout. Just say perl -MPDL::PP::Dump myfile.pd to see the calls to C and friends. Try it with F and F. If you're interested (or want to enhance it), the source is in Basic/Gen/PP/Dump.pm =head2 Other macros in the Code section Macros: So far we have encountered the C<$SIZE>, C<$GENERIC> and C<$P> macros. Now we are going to quickly explain the other macros that are expanded in the C section of PDL::PP along with examples of their usage. =head3 $T The C<$T> macro is used for type switches. This is very useful when you have to use different external (e.g. library) functions depending on the input type of arguments. The general syntax is $Ttypeletters(type_alternatives) where C is a permutation of a subset of the letters C which stand for Byte, Short, Ushort, etc. and C are the expansions when the type of the PP operation is equal to that indicated by the respective letter. Let's illustrate this incomprehensible description by an example. Assuming you have two C functions with prototypes void float_func(float *in, float *out); void double_func(double *in, double *out); which do basically the same thing but one accepts float and the other double pointers. You could interface them to PDL by defining a generic function C (which will call the correct function depending on the type of the transformation): pp_def('foofunc', Pars => ' a(n); [o] b();', Code => ' $TFD(float,double)_func ($P(a),$P(b));' GenericTypes => [qw(F D)], ); There is a limitation that the comma-separated values cannot have parentheses. =head3 $PP The C<$PP> macro is used for a so called I. The I refers to some internal optimisations of PDL (for those who are familiar with the PDL core we are talking about the vaffine optimisations). This macro is mainly for internal use and you shouldn't need to use it in any of your normal code. =head3 $PPSYM The C<$PPSYM()> macro is replaced by the value of L for the loop type, or that of the given parameter, similar to C<$GENERIC()>. This is useful for e.g. macros that vary by that, avoiding the need for things like C<$TXY(X,Y)>. Another benefit is that if an operation's GenericTypes get extended, this macro will still be correct. =head3 $COMP (and the OtherPars section) The C<$COMP> macro is used to access non-pdl values in the code section. Its name is derived from the implementation of transformations in PDL. The variables you can refer to using C<$COMP> are members of the ``compiled'' structure that represents the PDL transformation in question but does not yet contain any information about dimensions (for further details check L). However, you can treat C<$COMP> just as a black box without knowing anything about the implementation of transformations in PDL. So when would you use this macro? Its main usage is to access values of arguments that are declared in the C section of a C definition. But then you haven't heard about the C key yet?! Let's have another example that illustrates typical usage of both new features: pp_def('pnmout', Pars => 'a(m)', OtherPars => "PerlIO *fp", GenericTypes => [qw(B U S L)], Code => ' if (PerlIO_write($COMP(fp),$P(a),len) != len) $CROAK("Error writing pnm file"); '); This function is used to write data from a pdl to a file. The file descriptor is passed as a string into this function. This parameter does not go into the C section since it cannot be usefully treated like a pdl but rather into the aptly named C section. Parameters in the C section follow those in the C section when invoking the function, i.e. open FILE,">out.dat" or die "couldn't open out.dat"; pnmout($pdl,'FILE'); When you want to access this parameter inside the code section you have to tell PP by using the C<$COMP> macro, i.e. you write C<$COMP(fp)> as in the example. Otherwise PP wouldn't know that the C you are referring to is the same as that specified in the C section. Another use for the C section is to set a named dimension in the signature. Let's have an example how that is done: pp_def('setdim', Pars => '[o] a(n)', OtherPars => 'int ns => n', Code => 'loop(n) %{ $a() = n; %}', ); This says that the named dimension C will be initialised from the value of the I C which is of integer type (I guess you have realised that we use the C named_dim> syntax). Now you can call this function in the usual way: setdim(($x=null),5); print $x; [ 0 1 2 3 4 ] Admittedly this function is not very useful but it demonstrates how it works. If you call the function with an existing pdl and you don't need to explicitly specify the size of C since PDL::PP can figure it out from the dimensions of the non-null pdl. In that case you just give the dimension parameter as C<-1>: $x = hist($y); setdim($x,-1); The default values available via C<$COMP()> are the C as noted above, which get copied in. However, this can be added to (previous to 2.058, replaced) by supplying C and/or C keys (the defaults will happen first): pp_def( 'diagonal', OtherPars => 'SV *list', Comp => 'PDL_Indx whichdims_count; PDL_Indx whichdims[$COMP(whichdims_count)];', MakeComp => ' PDL_Indx i; PDL_Indx *tmp= PDL->packdims(list,&($COMP(whichdims_count))); if (!tmp) $CROAK("Failed to packdims for creating"); if ($COMP(whichdims_count) < 1) $CROAK("Diagonal: must have at least 1 dimension"); $DOCOMPALLOC(); /* malloc()s the whichdims */ for(i=0; i<$COMP(whichdims_count); i++) $COMP(whichdims)[i] = tmp[i]; free(tmp); /* ... */ ', # ... ); The C code is placed in the C, so access to C (which will just be Cs)/C values is just via their names, not a macro. As of 2.058, you can instead give a C99 "incomplete array" type parameter as an C entry: pp_def( 'diagonal', OtherPars => 'PDL_Indx whichdims[]', MakeComp => ' if ($COMP(whichdims_count) < 1) $CROAK("Diagonal: must have at least 1 dimension"); /* ... */ ', # ... ); There is an XS F entry (only for C array types for now) that adds a C<(varname)_count> variable having extracted the index numbers from an array-ref parameter, and sets the count variable to the right value. PP then makes a copy of the data available. The C function (here, C)'s caller (here, the generated XS function) is responsible for freeing the array passed in (here, PDL's C function is used, so the user need do nothing different). =head2 Other functions in the Code section The only PP function that we have used in the examples so far is C. Additionally, there are currently two other functions which are recognised in the C section: =head3 threadloop As we heard above the signature of a PP defined function defines the dimensions of all the pdl arguments involved in a I operation. However, you often call the functions that you defined with PP with pdls that have more dimensions than those specified in the signature. In this case the primitive operation is performed on all subslices of appropriate dimensionality in what is called a I (see also overview above and L). Assuming you have some notion of this concept you will probably appreciate that the operation specified in the code section should be optimised since this is the tightest loop inside a thread loop. However, if you revisit the example where we define the C function, you will quickly realise that looking up the C file descriptor in the inner thread loop is not very efficient when writing a pdl with many rows. A better approach would be to look up the C descriptor once outside the thread loop and use its value then inside the tightest thread loop. This is exactly where the C function comes in handy. Here is an improved definition of C which uses this function: pp_def('pnmout', Pars => 'a(m)', OtherPars => "PerlIO *fp", GenericTypes => [qw(B U S L)], Code => ' int len; len = $SIZE(m) * sizeof($GENERIC()); threadloop %{ if (PerlIO_write($COMP(fp),$P(a),len) != len) $CROAK("Error writing pnm file"); %} '); This works as follows. Normally the C code you write inside the C section is placed inside a thread loop (i.e. PP generates the appropriate wrapping XS code around it). However, when you explicitly use the C function, PDL::PP recognises this and doesn't wrap your code with an additional thread loop. This has the effect that code you write outside the thread loop is only executed once per transformation and just the code with in the surrounding C<%{ ... %}> pair is placed within the tightest thread loop. This also comes in handy when you want to perform a decision (or any other code, especially CPU intensive code) only once per thread, i.e. pp_addhdr(' #define RAW 0 #define ASCII 1 '); pp_def('do_raworascii', Pars => 'a(); b(); [o]c()', OtherPars => 'int mode', Code => ' switch ($COMP(mode)) { case RAW: threadloop %{ /* do raw stuff */ %} break; case ASCII: threadloop %{ /* do ASCII stuff */ %} break; default: $CROAK("unknown mode"); }' ); =head3 types The types function works similar to the C<$T> macro. However, with the C function the code in the following block (delimited by C<%{> and C<%}> as usual) is executed for all those cases in which the datatype of the operation is I the types represented by the letters in the argument to C, e.g. Code => '... types(BSUL) %{ /* do integer type operation */ %} types(FD) %{ /* do floating point operation */ %} ...' You are encouraged to use this idiom (from L) in order to minimise effort needed to make your code work with new types: use PDL::Types qw(types); my @Rtypes = grep $_->real, types(); my @Ctypes = grep !$_->real, types(); # ... my $got_complex = PDL::Core::Dev::got_complex_version($name, 2); my $complex_bit = join "\n", map 'types('.$_->ppsym.') %{$'.$c.'() = c'.$name.$_->floatsuffix.'($'.$x.'(),$'.$y.'());%}', @Ctypes; my $real_bit = join "\n", map 'types('.$_->ppsym.') %{$'.$c.'() = '.$name.'($'.$x.'(),$'.$y.'());%}', @Rtypes; ($got_complex ? $complex_bit : '') . $real_bit; (although you should first check whether F already has a type-generic version of the function you want to call, in which case the above becomes unnecessary). =head2 The RedoDimsCode Section The C key is an optional key that is used to compute dimensions of ndarrays at runtime in case the standard rules for computing dimensions from the signature are not sufficient. The contents of the C entry is interpreted in the same way that the Code section is interpreted-- I, PP macros are expanded and the result is interpreted as C code. The purpose of the code is to set the size of some dimensions that appear in the signature. Storage allocation and threadloops and so forth will be set up as if the computed dimension had appeared in the signature. In your code, you first compute the desired size of a named dimension in the signature according to your needs and then assign that value to it via the $SIZE() macro. As an example, consider the following situation. You are interfacing an external library routine that requires an temporary array for workspace to be passed as an argument. Two input data arrays that are passed are C and C. The output data array is C. The routine requires a workspace array with a length of n+m*m, and you'd like the storage created automatically just like it would be for any ndarray flagged with [t] or [o]. What you'd like is to say something like pp_def( "myexternalfunc", Pars => " p(m); x(n); [o] y; [t] work(n+m*m); ", ... but that won't work, because PP can't interpret expressions with arithmetic in the signature. Instead you write pp_def( "myexternalfunc", Pars => ' p(m); x(n); [o] y(); [t] work(wn); ', RedoDimsCode => ' PDL_Indx im = $PDL(p)->dims[0]; PDL_Indx in = $PDL(x)->dims[0]; PDL_Indx min = in + im * im; PDL_Indx inw = $PDL(work)->dims[0]; $SIZE(wn) = inw >= min ? inw : min; ', Code => ' externalfunc( $P(p), $P(x), $SIZE(m), $SIZE(n), $P(work) ); ' ); This code works as follows: The macro $PDL(p) expands to a pointer to the pdl struct for the ndarray p. You don't want a pointer to the data ( ie $P ) in this case, because you want to access the methods for the ndarray on the C level. You get the first dimension of each of the ndarrays and store them in integers. Then you compute the minimum length the work array can be. If the user sent an ndarray C with sufficient storage, then leave it alone. If the user sent, say a null pdl, or no pdl at all, then the size of wn will be zero and you reset it to the minimum value. Before the code in the Code section is executed PP will create the proper storage for C if it does not exist. Note that you only took the first dimension of C