PDL-2.085/0000755000175000017500000000000014556074541012110 5ustar osboxesosboxesPDL-2.085/INSTALL0000644000175000017500000001427414014062163013133 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.085/DEPENDENCIES0000644000175000017500000002277214207703304013660 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::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.085/Basic/0000755000175000017500000000000014556074541013131 5ustar osboxesosboxesPDL-2.085/Basic/SourceFilter/0000755000175000017500000000000014556074541015537 5ustar osboxesosboxesPDL-2.085/Basic/SourceFilter/FilterUtilCall.pm0000644000175000017500000000240014205764737020754 0ustar osboxesosboxes# This original Filter::Util::Call-based # PDL::NiceSlice engine. # use strict; use warnings; use Filter::Util::Call; { no warnings 'redefine'; sub PDL::NiceSlice::FilterUtilCall::make_filter { my ($class,$file,$offset) = @_; my $terminator = terminator_regexp($class); 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 import { my ($class) = @_; my ($file,$offset) = (caller)[1,2]; # for error reporting ## Parse class name into a regexp suitable for filtration filter_add(PDL::NiceSlice::FilterUtilCall::make_filter($class, $file, $offset+1)); } sub unimport { filter_del(); } 1; PDL-2.085/Basic/SourceFilter/example0000644000175000017500000000171114014062163017077 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.085/Basic/SourceFilter/FilterSimple.pm0000644000175000017500000000104014205761625020464 0ustar osboxesosboxes# This is the new Filter::Simple engine for PDL::NiceSlice # use Filter::Simple; use strict; use warnings; { no warnings 'redefine'; sub PDL::NiceSlice::FilterSimple::code_no_comments { print STDERR "***** Input: \n$_\n" if $PDL::NiceSlice::debug_filter; $_ = perldlpp('PDL::NiceSlice', $_); print STDERR "***** Output: $_\n" if $PDL::NiceSlice::debug_filter; } } FILTER_ONLY code_no_comments => \&PDL::NiceSlice::FilterSimple::code_no_comments, all => sub { print STDERR "*** Final: $_\n" if $PDL::NiceSlice::debug_filter }; 1; PDL-2.085/Basic/SourceFilter/t/0000755000175000017500000000000014556074541016002 5ustar osboxesosboxesPDL-2.085/Basic/SourceFilter/t/niceslice-utilcall.t0000644000175000017500000000062014205755530021725 0ustar osboxesosboxesuse strict; use warnings; # Run niceslice.t with Filter::Util::Call engine BEGIN { $ENV{PDL_NICESLICE_ENGINE} = 'Filter::Util::Call'; $::UC = $::UC = 1; } use FindBin; open my $fh, "$FindBin::Bin/niceslice.t" or die "Cannot read $FindBin::Bin/niceslice.t: $!"; my $source = do { local $/; <$fh> }; close $fh; eval "#line 1 t/niceslice.t-run_by_niceslice-utilcall.t\n$source"; die $@ if $@; PDL-2.085/Basic/SourceFilter/t/niceslice.t0000644000175000017500000001301014244761216020114 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::LiteF; #BEGIN { $PDL::NiceSlice::debug = $PDL::NiceSlice::debug_filter = 1 } 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); require Filter::Simple; require PDL::NiceSlice::FilterSimple; my $fs_like = Filter::Simple::gen_std_filter_for(code_no_comments => \&PDL::NiceSlice::FilterSimple::code_no_comments); $fs_like = sub { $_ = PDL::NiceSlice::findslice($_, $PDL::NiceSlice::debug_filter) } if $::UC; sub translate_and_run { local $Test::Builder::Level = $Test::Builder::Level + 1; my ($txt, $expected_error) = @_; $expected_error ||= qr/^$/; my $retval = eval { local $_ = $txt; $fs_like->('main'); my $etxt = $_; # note "$txt -> \n\t$etxt\n"; $etxt =~ s/^\s*print\b/die/; my $retval = eval $etxt; die $@ if $@; $retval; }; like $@, $expected_error, 'error as expected'; $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/; $pa = sequence(3); translate_and_run 'my $x = 1 / 2; $pa = $pa((2)); $x =~ /\./;'; is $pa.'', '2', '/ not treated as starting a regex'; $pa = sequence(3); translate_and_run 'my $x = (0.5 + 0.5) / 2; $pa = $pa((2)); $x =~ /\./;'; is $pa.'', '2', '/ not treated as starting a regex even after paren'; # 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)); translate_and_run <<'EOF'; sub f { my ($pa, $pb) = @_; $pa <<= 2; $pb >>= 1; } EOF pass '<<= followed by >>= not blow up NiceSlice'; translate_and_run <<'EOF'; $pb = $pa << 1; $pb += $pa(0); EOF pass '<< followed by 1 then blank'; # # 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 ); translate_and_run <<'EOF'; my $p = {y => 1}; { $pa=ones(3,3,3); my $f = do { my $i=1; my $v=$$p{y}-$i; $pb = $pa(,$i,) }; } EOF pass 'obscure bug where "y" treated as tr/// in 2-deep {}'; if (!$::UC) { # this is broken in the FilterUtilCall module so don't test it my $expected = q{ CREATE TABLE $table ( CHECK ( yr = $yr ) ) INHERITS ($schema.master_table) }; my $got = translate_and_run 'q{ CREATE TABLE $table ( CHECK ( yr = $yr ) ) INHERITS ($schema.master_table) }'; is $got, $expected, 'NiceSlice leaves strings alone'; } { use PDL::NiceSlice; if (!$::UC) { my $data = join '', ; like $data, qr/we've got data/, "we've got data"; } } done_testing; __DATA__ we've got data PDL-2.085/Basic/SourceFilter/ModuleCompile.pm0000644000175000017500000000041414202424257020621 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.085/Basic/SourceFilter/local.perldlrc0000644000175000017500000000140714014062163020346 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.085/Basic/SourceFilter/NiceSlice.pm0000644000175000017500000010543514357654512017744 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 //= 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))'; use Text::Balanced; # used to find parenthesis-delimited blocks BEGIN { # fix for problem identified by Ingo, also EOP fix that needs propagating back my $ncws = qr/\s+/; my $comment = qr/(? [ { DONT_MATCH => $comment }, $ncws, { DONT_MATCH => $pod_or_DATA }, \&Text::Balanced::extract_variable, $id, { DONT_MATCH => \&Text::Balanced::extract_quotelike } ], ); use Filter::Simple (); my $orig_gen_std_filter_for = \&Filter::Simple::gen_std_filter_for; sub my_gen_std_filter_for { my ($type, $transform) = @_; goto &$orig_gen_std_filter_for if !$extractor_for{$type}; return sub { my $instr; my @components; for (Text::Balanced::extract_multiple($_,$extractor_for{$type})) { if (ref()) { push @components, $_; $instr=0 } elsif ($instr) { $components[-1] .= $_ } else { push @components, $_; $instr=1 } } my $count = 0; my $extractor = qr/\Q$;\E(.{4})\Q$;\E/s; $_ = join "", map { ref $_ ? $;.pack('N',$count++).$; : $_ } @components; @components = grep { ref $_ } @components; $transform->(@_); s/$extractor/${$components[unpack('N',$1)]}/g; } } # 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'; *Filter::Simple::gen_std_filter_for = \&my_gen_std_filter_for; } # 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 $wspat = qr/(?:\s|$RE_cmt|\Q$;\E.{4}\Q$;\E)*/; # last bit Filter::Simple my $prefixpat = qr/.*? # arbitrary leading stuff ((?) # or just '->' $wspat (?=\()/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::NiceSlice::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,$verbose) = @_; push @srcstr, \$src; $verbose //= 0; 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 $verbose; # Do final check for "for $var(LIST)" and "foreach $var(LIST)" syntax. # Process into a 'slice' call only if it's not that. if ($prefix =~ m/for(?:each)?\b(?:$wspat(?:my|our))?$wspat\$\w+$wspat$/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,$verbose); } 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,$verbose) . ")"; # $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 =~ /->$wspat$/ ? '' : '->'). $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::NiceSlice::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 $_, $PDL::NiceSlice::debug ; $_ .= "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::NiceSlice::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 SYNOPSIS 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.085/Basic/SourceFilter/Changes0000644000175000017500000000213314146003631017014 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.085/Basic/SourceFilter/Makefile.PL0000644000175000017500000000136414146003631017500 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.085/Basic/Ops/0000755000175000017500000000000014556074541013672 5ustar osboxesosboxesPDL-2.085/Basic/Ops/ops.pd0000644000175000017500000004476014555765371015042 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 #define 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)*((uint64_t)((X)/(N))) )) #define SPACE(A,B) ( ((A)<(B)) ? -1 : ((A)!=(B)) ) #define ABS(A) ( (A)>=0 ? (A) : -(A) ) '); my %char2escape = ('>'=>'E','<'=>'E'); my $chars = '(['.join('', map quotemeta, sort keys %char2escape).'])'; sub protect_chars { my ($txt) = @_; $txt =~ s/$chars/$char2escape{$1}/g; return $txt; } # simple binary operators pp_addhdr(pp_line_numbers(__LINE__, <<'EOF')); #define PDL_BADVAL_WARN(var) \ { \ PDL_Anyval bad_anyval = PDL->get_pdl_badvalue(var); \ if (bad_anyval.type < 0) \ barf("Error getting badvalue, type=%d", bad_anyval.type); \ complex double bad_c; \ ANYVAL_TO_CTYPE(bad_c, complex double, bad_anyval); \ if( bad_c == 0 || bad_c == 1 ) \ warn(#var " badvalue is set to 0 or 1. This will cause data loss when using badvalues for comparison operators."); \ } EOF 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'; if (swap) { pdl *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} .= " PDL_BADVAL_WARN(a)\n PDL_BADVAL_WARN(b)\n"; delete $extra{Comparison}; } pp_addpm(make_overload($op, $name, $mutator)); my $bitwise = delete $extra{Bitwise}; pp_def($name, Pars => 'a(); b(); [o]c();', OtherPars => 'int $swap'.($bitwise ? '; SV *$ign; int $ign2' : ''), OtherParsDefaults => { swap => 0, ($bitwise ? (ign=>'&PL_sv_undef', ign2=>0) : ()) }, ArgOrder => 1, HandleBad => 1, NoBadifNaN => 1, Inplace => [ 'a' ], # quick and dirty solution to get ->inplace do its job Code => pp_line_numbers(__LINE__-1, < << "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, $one_arg) = @_; my $ret; if ($one_arg) { $ret = pp_line_numbers(__LINE__, <[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'; if (swap) { pdl *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_' : '', 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', OtherParsDefaults => { swap => 0 }, ArgOrder => 1, Inplace => [ 'a' ], Code => pp_line_numbers(__LINE__-1, < << "EOD"); =for ref $doc =for example \$c = \$x->$name(\$y); # explicit call with default swap of 0 \$c = \$x->$name(\$y, 1); # explicit call with trailing 1 to swap args $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. As of 2.065, when calling this function explicitly you can omit the third argument (see first example), or supply it (see second one). =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, 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__-1, < << "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', 'fabs', 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{ char anybad = 0; broadcastloop %{ PDL_IF_BAD(if ( $ISBAD(a()) ) { anybad = 1; $SETBAD(b()); } else,) $b() = $a(); %} PDL_IF_BAD(if (anybad) $PDLSTATESETBAD(b);,) }), Doc => 'Plain numerical assignment. This is used to implement the ".=" operator', ); # 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 . (!$backcode ? '' : ' Flows data back & forth.'), ); } 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); # as method \$c = ipow \$x, \$y; \$x->inplace->ipow(\$y); # modify \$x inplace It can be made to work inplace with the C<\$x-Einplace> syntax. 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, 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 overload %OVERLOADS, "eq" => PDL::Ops::warn_non_numeric_op_wrapper(\&PDL::eq, 'eq'), ".=" => sub { my @args = !$_[2] ? @_[1,0] : @_[0,1]; PDL::Ops::assgn(@args); return $args[1]; }, '++' => sub { $_[0] += 1 }, '--' => sub { $_[0] -= 1 }, ; } EOF pp_done(); PDL-2.085/Basic/Ops/Makefile.PL0000644000175000017500000000043014112170343015622 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.085/Basic/Primitive/0000755000175000017500000000000014556074541015101 5ustar osboxesosboxesPDL-2.085/Basic/Primitive/primitive.pd0000644000175000017500000033262614547543564017460 0ustar osboxesosboxesuse strict; use warnings; use PDL::Types qw(ppdefs_all types); my $F = [map $_->ppsym, grep $_->real && !$_->integer, types()]; my $AF = [map $_->ppsym, grep !$_->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; int badflag = 0; loop(n) %{ PDL_IF_BAD(if (!($ISGOOD(a()) && $ISGOOD(b()))) { badflag = 1; break; } else,) { tmp += $a() * $b(); } %} PDL_IF_BAD(if (badflag) { $SETBAD(c()); $PDLSTATESETBAD(c); } else,) { $c() = tmp; }', Doc => ' =for ref Inner product over one dimension c = sum_i a_i * b_i ', 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. ', ); # pp_def( inner ) pp_def( 'outer', HandleBad => 1, Pars => 'a(n); b(m); [o]c(n,m);', GenericTypes => [ppdefs_all], Code => 'loop(n,m) %{ PDL_IF_BAD(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 broadcasting 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. Broadcasting 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 broadcast 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_def('matmult', HandleBad=>0, Pars => 'a(t,h); b(w,t); [o]c(w,h);', GenericTypes => [ppdefs_all], PMCode => pp_line_numbers(__LINE__, <<'EOPM'), sub PDL::matmult { my ($x,$y,$c) = @_; $y = PDL->topdl($y); $c = PDL->null unless do { local $@; 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) ); barf sprintf 'Dim mismatch in matmult of [%1$dx%2$d] x [%3$dx%4$d]: %1$d != %4$d',$x->dim(0),$x->dim(1),$y->dim(0),$y->dim(1) if $y->dim(1) != $x->dim(0); PDL::_matmult_int($x,$y,$c); $c; } EOPM Code => <<'EOC', PDL_Indx ih, iw, it, ow, oh, ot, wlim, hlim, tlim; PDL_Indx tsiz = 8 * sizeof(double) / sizeof($GENERIC()); // Cache the dimincs to avoid constant lookups PDL_Indx atdi = PDL_REPRINCS($PDL(a))[0]; PDL_Indx btdi = PDL_REPRINCS($PDL(b))[1]; // 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)); // Zero the output for this tile for( ih=oh; ihiw, h=>ih) = 0; for( ot=0; ot < $SIZE(t); ot += tsiz ) { tlim = PDLMIN(ot + tsiz, $SIZE(t)); for( ih=oh; ihiw, h=>ih); // Cache data pointers before 't' run through tile $GENERIC() *ad = &($a(t=>ot, h=>ih)); $GENERIC() *bd = &($b(w=>iw, t=>ot)); // 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 broadcasting 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 => 'long double tmp = 0; int flag = 0; loop(n) %{ PDL_IF_BAD(if ( $ISGOOD(a()) && $ISGOOD(b()) && $ISGOOD(c()) ),) { tmp += $a() * $b() * $c(); flag = 1; } %} PDL_IF_BAD(if (!flag) { $SETBAD(d()); } else,) { $d() = tmp; }', 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 => 'long double tmp = 0; int flag = 0; loop(n,m) %{ PDL_IF_BAD(if ( $ISGOOD(a()) && $ISGOOD(b()) && $ISGOOD(c()) ),) { tmp += $a() * $b() * $c(); flag = 1; } %} PDL_IF_BAD(if (!flag) { $SETBAD(d()); } else,) { $d() = tmp; }', 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 broadcast 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 => 'long double tmp = 0; int flag = 0; loop(n,m) %{ PDL_IF_BAD(if ( $ISGOOD(a()) && $ISGOOD(b()) ),) { tmp += $a() * $b(); flag = 1; } %} PDL_IF_BAD(if (!flag) { $SETBAD(c()); } else,) { $c() = tmp; }', 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) %{ long double tmp0 = 0; int flag = 0; loop(m) %{ PDL_IF_BAD(if ( $ISGOOD(b()) && $ISGOOD(c()) ),) { tmp0 += $b() * $c(); flag = 1; } %} PDL_IF_BAD(if (!flag) { $SETBAD(tmp()); } else,) { $tmp() = tmp0; } %} loop(j,k) %{ long double tmp1 = 0; int flag = 0; loop(n) %{ if ( $ISGOOD(a()) && $ISGOOD(tmp()) ) { tmp1 += $a() * $tmp(); flag = 1; } %} PDL_IF_BAD(if (!flag) { $SETBAD(d()); } else,) { $d() = tmp1; } %}', Doc => ' =for ref Efficient Triple matrix product C Efficiency comes from by using the temporary C. This operation only scales as C whereas broadcasting using L would scale as C. The reason for having this routine is that you do not need to have the same broadcast-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; } %} } 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 => 'input(n); indx ind(n); [io] sum(m)', GenericTypes => [ppdefs_all], Code => 'loop(n) %{ register PDL_Indx this_ind = $ind(); if ( PDL_IF_BAD($ISBADVAR(this_ind,ind) ||,) this_ind<0 || this_ind>=$SIZE(m) ) $CROAK("invalid index"); PDL_IF_BAD( if ( $ISBAD(input()) ) { $SETBAD(sum(m => this_ind)); } else,) { $sum(m => this_ind) += $input(); } %}', BadDoc => ' =for bad The routine barfs on bad indices, and bad inputs set target outputs bad. =cut ', Doc=>' =for ref Broadcasting index add: add C to the C element of C, i.e: sum(ind) += input =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] Broadcasting 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 broadcasted 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 broadcasted 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 => pp_line_numbers(__LINE__, <<'EOPM'), sub PDL::conv1d { my $opt = pop @_ if ref($_[-1]) eq 'HASH'; die 'Usage: conv1d( a(m), kern(p), [o]b(m), {Options} )' if @_<2 || @_>3; my($x,$kern) = @_; my $c = @_ == 3 ? $_[2] : PDL->null; PDL::_conv1d_int($x,$kern,$c, !(defined $opt && exists $$opt{Boundary}) ? 0 : lc $$opt{Boundary} eq "reflect"); return $c; } EOPM 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 broadcasting 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 { my ($arr) = @_; return $arr if($arr->nelem == 0); # The null list is unique (CED) return $arr->flat if($arr->nelem == 1); # singleton list is unique my $aflat = $arr->flat; my $srt = $aflat->where($aflat==$aflat)->qsort; # no NaNs or BADs for qsort my $nans = $aflat->where($aflat!=$aflat); my $uniq = ($srt->nelem > 1) ? $srt->where($srt != $srt->rotate(-1)) : $srt; # make sure we return something if there is only one value ( $uniq->nelem > 0 ? $uniq : $srt->nelem == 0 ? $srt : PDL::pdl( ref($srt), [$srt->index(0)] ) )->append($nans); } 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 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 => 'PDL_IF_BAD(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=>pp_line_numbers(__LINE__, <<"EOD"), sub PDL::$name { my (\$x,\$y) = \@_; my \$c; if (\$x->is_inplace) { \$x->set_inplace(0); \$c = \$x; } elsif (\@_ > 2) {\$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 => <<'EOBC', PDL_IF_BAD( if( $ISBAD(a()) || $ISBAD(l()) || $ISBAD(h()) ) { $SETBAD(c()); } else,) { $c() = PDLMIN($h(), PDLMAX($l(), $a())); } EOBC PMCode=>pp_line_numbers(__LINE__, <<'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 (@_ > 3) { $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; int flag = 0; loop(n) %{ PDL_IF_BAD(if ($ISGOOD(wt()) && $ISGOOD(a()) && $ISGOOD(avg())),) { long double tmp; PDL_Indx i; wtsum += $wt(); tmp=1; for(i=0; i<$COMP(deg); i++) tmp *= $a(); statsum += $wt() * (tmp - $avg()); flag = 1; } %} PDL_IF_BAD(if (!flag) { $SETBAD(b()); $PDLSTATESETBAD(b); } else,) { $b() = statsum / wtsum; }', 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(w) norm = 0; int flag = 0; loop(n) %{ /* Accumulate sum and summed weight. */ /* perhaps should check w() for bad values too ? */ PDL_IF_BAD(if ( $ISGOOD(a()) ),) { tmp += $a()*$w(); norm += ($GENERIC(avg)) $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 true */ PDL_IF_BAD(if ( !flag ) { $SETBAD(avg()); $PDLSTATESETBAD(avg); $SETBAD(rms()); $PDLSTATESETBAD(rms); $SETBAD(adev()); $PDLSTATESETBAD(adev); $SETBAD(min()); $PDLSTATESETBAD(min); $SETBAD(max()); $PDLSTATESETBAD(max); $SETBAD(prms()); $PDLSTATESETBAD(prms); } else,) { $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 += fabsl(diff) * $w(); } %} $rms() = sqrt( tmp/norm ); if(norm>1) $prms() = sqrt( tmp/(norm-1) ); else PDL_IF_BAD($SETBAD(prms()),$prms() = 0); $adev() = tmp1 / norm ; }', PMCode=>pp_line_numbers(__LINE__, <<'EOPM'), sub PDL::statsover { barf('Usage: ($mean,[$prms, $median, $min, $max, $adev, $rms]) = statsover($data,[$weights])') if @_>2; my ($data, $weights) = @_; $weights //= $data->ones(); 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); wantarray ? ($mean, $prms, $median, $min, $max, $adev, $rms) : $mean; } EOPM 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 @_>2; my ($data,$weights) = @_; # Ensure that $weights is properly broadcasted 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 broadcastloop 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 broadcastloop 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 $code = pp_line_numbers __LINE__-1, ' if ($SIZE(m) == 0) $CROAK("called with m dim of 0"); register int j; register int maxj = $SIZE(m)-1; register double min = $COMP(min); register double step = $COMP(step); broadcastloop %{ loop(m) %{ $hist() = 0; %} %} broadcastloop %{ loop(n) %{ PDL_IF_BAD(if ( $ISGOOD(in()) ),) { j = (int) (($in()-min)/step); if (j<0) j=0; if (j > maxj) j = maxj; ($hist(m => j))'.$_->{HistOp}.'; } %} %}'; 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 => $code, 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 $code = pp_line_numbers __LINE__-1, ' if ($SIZE(ma) == 0) $CROAK("called with ma dim of 0"); if ($SIZE(mb) == 0) $CROAK("called with mb dim of 0"); 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); broadcastloop %{ loop(ma,mb) %{ $hist() = 0; %} %} broadcastloop %{ loop(n) %{ PDL_IF_BAD(if ( $ISGOOD(ina()) && $ISGOOD(inb()) ),) { 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}.'; } %} %}'; 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 => $code, 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=>pp_line_numbers(__LINE__, <<'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], PMCode => pp_line_numbers(__LINE__-1, ' sub PDL::append { my ($i1, $i2, $o) = map PDL->topdl($_), @_; my $nempty = grep $_->isempty, $i1, $i2; if ($nempty == 2) { my @dims = $i1->dims; $dims[0] += $i2->dim(0); return PDL->zeroes($i1->type, @dims); } if ($nempty == 1) { if (!defined $o) { return $i2->isnull ? PDL->zeroes(0) : $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->convert($i1->type), $o); $o; } '), RedoDimsCode => '$SIZE(mn) = $SIZE(m)+$SIZE(n);', Code => 'register PDL_Indx mnp; PDL_Indx ns = $SIZE(n); broadcastloop %{ 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 broadcasting 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 broadcasting 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; ($dim, $x) = ($x, $dim) if defined $x && !ref $x; confess 'dimension must be Perl scalar' if ref $dim; 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_add_macros( CMPVEC => sub { my ($a, $b, $dim, $ret, $anybad) = @_; my $badbit = !defined $anybad ? '' : < 1, Pars => 'a(n); b(n); sbyte [o]c();', Code => ' char anybad = 0; broadcastloop %{ $CMPVEC($a(), $b(), n, $c(), anybad); %} PDL_IF_BAD(if (anybad) { $SETBAD(c()); $PDLSTATESETBAD(c); },) ', Doc => ' =for ref Compare two vectors lexicographically. Returns -1 if a is less, 1 if greater, 0 if equal. ', BadDoc => ' The output is bad if any input values up to the point of inequality are bad - any after are ignored. ', ); pp_def( 'eqvec', HandleBad => 1, Pars => 'a(n); b(n); sbyte [o]c();', Code => ' char anybad = 0; broadcastloop %{ $c() = 1; loop(n) %{ PDL_IF_BAD(if ($ISBAD(a()) || $ISBAD(b())) { $SETBAD(c()); anybad = 1; break; } else,) if ($a() != $b()) { $c() = 0; PDL_IF_BAD(,break;) } %} %} PDL_IF_BAD(if (anybad) $PDLSTATESETBAD(c);,) ', Doc => ' =for ref Compare two vectors, returning 1 if equal, 0 if not equal. ', BadDoc => 'The output is bad if any input values are bad.', ); pp_def('enumvec', Pars => 'v(M,N); indx [o]k(N)', Code =><<'EOC', PDL_Indx vn, kn, sn=$SIZE(N), matches; for (vn=0; vnkn) = kn-vn; ++kn; loop (M) %{ if ($v(N=>vn) != $v(N=>kn)) { matches=0; break; } %} } } EOC Doc =><<'EOD', =for ref Enumerate a list of vectors with locally unique keys. Given a sorted list of vectors $v, generate a vector $k containing locally unique keys for the elements of $v (where an "element" is a vector of length $M occurring in $v). Note that the keys returned in $k are only unique over a run of a single vector in $v, so that each unique vector in $v has at least one 0 (zero) index in $k associated with it. If you need global keys, see enumvecg(). Contributed by Bryan Jurish Emoocow@cpan.orgE. EOD ); ##------------------------------------------------------ ## enumvecg() pp_def('enumvecg', Pars => 'v(M,N); indx [o]k(N)', Code =><<'EOC', PDL_Indx vn, vnprev, sn=$SIZE(N), ki; if (sn > 0) { $k(N=>0) = ki = 0; for (vnprev=0, vn=1; vnvnprev) != $v(N=>vn)) { ++ki; break; } %} $k(N=>vn) = ki; } } EOC Doc =><<'EOD', =for ref Enumerate a list of vectors with globally unique keys. Given a sorted list of vectors $v, generate a vector $k containing globally unique keys for the elements of $v (where an "element" is a vector of length $M occurring in $v). Basically does the same thing as: $k = $v->vsearchvec($v->uniqvec); ... but somewhat more efficiently. Contributed by Bryan Jurish Emoocow@cpan.orgE. EOD ); pp_def('vsearchvec', Pars => 'find(M); which(M,N); indx [o]found();', Code => q( int carp=0; broadcastloop %{ PDL_Indx sizeM=$SIZE(M), sizeN=$SIZE(N), n1=sizeN-1; PDL_Indx nlo=-1, nhi=n1, nn; int cmpval, is_asc_sorted; // //-- get sort direction $CMPVEC($which(N=>n1),$which(N=>0),M,cmpval); is_asc_sorted = (cmpval > 0); // //-- binary search while (nhi-nlo > 1) { nn = (nhi+nlo) >> 1; $CMPVEC($find(),$which(N=>nn),M,cmpval); if (cmpval > 0 == is_asc_sorted) nlo=nn; else nhi=nn; } if (nlo==-1) { nhi=0; } else if (nlo==n1) { $CMPVEC($find(),$which(N=>n1),M,cmpval); if (cmpval != 0) carp = 1; nhi = n1; } else { nhi = nlo+1; } $found() = nhi; %} if (carp) warn("some values had to be extrapolated"); ), Doc=><<'EOD' =for ref Routine for searching N-dimensional values - akin to vsearch() for vectors. =for usage $found = vsearchvec($find, $which); $nearest = $which->dice_axis(1,$found); Returns for each row-vector in C<$find> the index along dimension N of the least row vector of C<$which> greater or equal to it. C<$which> should be sorted in increasing order. If the value of C<$find> is larger than any member of C<$which>, the index to the last element of C<$which> is returned. See also: L. Contributed by Bryan Jurish Emoocow@cpan.orgE. EOD ); pp_def('unionvec', Pars => 'a(M,NA); b(M,NB); [o]c(M,NC); indx [o]nc()', RedoDimsCode => '$SIZE(NC) = $SIZE(NA) + $SIZE(NB);', PMCode=>pp_line_numbers(__LINE__, <<'EOD'), sub PDL::unionvec { my ($a,$b,$c,$nc) = @_; $c = PDL->null if (!defined($nc)); $nc = PDL->null if (!defined($nc)); PDL::_unionvec_int($a,$b,$c,$nc); return ($c,$nc) if (wantarray); return $c->slice(",0:".($nc->max-1)); } EOD Code => q( PDL_Indx nai=0, nbi=0, nci=0, sizeNA=$SIZE(NA), sizeNB=$SIZE(NB), sizeNC=$SIZE(NC); int cmpval; for ( ; nci < sizeNC; nci++) { if (nai < sizeNA && nbi < sizeNB) { $CMPVEC($a(NA=>nai),$b(NB=>nbi),M,cmpval); } else if (nai < sizeNA) { cmpval = -1; } else if (nbi < sizeNB) { cmpval = 1; } else { break; } // if (cmpval < 0) { //-- CASE: a < b loop (M) %{ $c(NC=>nci) = $a(NA=>nai); %} nai++; } else if (cmpval > 0) { //-- CASE: a > b loop (M) %{ $c(NC=>nci) = $b(NB=>nbi); %} nbi++; } else { //-- CASE: a == b loop (M) %{ $c(NC=>nci) = $a(NA=>nai); %} nai++; nbi++; } } $nc() = nci; for ( ; nci < sizeNC; nci++) { //-- zero unpopulated outputs loop(M) %{ $c(NC=>nci) = 0; %} } ), Doc=><<'EOD' =for ref Union of two vector-valued PDLs. Input PDLs $a() and $b() B be sorted in lexicographic order. On return, $nc() holds the actual number of vector-values in the union. In scalar context, slices $c() to the actual number of elements in the union and returns the sliced PDL. Contributed by Bryan Jurish Emoocow@cpan.orgE. EOD ); pp_def('intersectvec', Pars => 'a(M,NA); b(M,NB); [o]c(M,NC); indx [o]nc()', RedoDimsCode => '$SIZE(NC) = PDLMIN($SIZE(NA),$SIZE(NB));', PMCode=>pp_line_numbers(__LINE__, <<'EOD'), sub PDL::intersectvec { my ($a,$b,$c,$nc) = @_; $c = PDL->null if (!defined($c)); $nc = PDL->null if (!defined($nc)); PDL::_intersectvec_int($a,$b,$c,$nc); return ($c,$nc) if (wantarray); my $nc_max = $nc->max; return ($nc_max > 0 ? $c->slice(",0:".($nc_max-1)) : $c->reshape($c->dim(0), 0, ($c->dims)[2..($c->ndims-1)])); } EOD Code => q( PDL_Indx nai=0, nbi=0, nci=0, sizeNA=$SIZE(NA), sizeNB=$SIZE(NB), sizeNC=$SIZE(NC); int cmpval; for ( ; nci < sizeNC && nai < sizeNA && nbi < sizeNB; ) { $CMPVEC($a(NA=>nai),$b(NB=>nbi),M,cmpval); // if (cmpval < 0) { //-- CASE: a < b nai++; } else if (cmpval > 0) { //-- CASE: a > b nbi++; } else { //-- CASE: a == b loop (M) %{ $c(NC=>nci) = $a(NA=>nai); %} nai++; nbi++; nci++; } } $nc() = nci; for ( ; nci < sizeNC; nci++) { //-- zero unpopulated outputs loop(M) %{ $c(NC=>nci) = 0; %} } ), Doc=><<'EOD' =for ref Intersection of two vector-valued PDLs. Input PDLs $a() and $b() B be sorted in lexicographic order. On return, $nc() holds the actual number of vector-values in the intersection. In scalar context, slices $c() to the actual number of elements in the intersection and returns the sliced PDL. Contributed by Bryan Jurish Emoocow@cpan.orgE. EOD ); pp_def('setdiffvec', Pars => 'a(M,NA); b(M,NB); [o]c(M,NC); indx [o]nc()', RedoDimsCode => '$SIZE(NC) = $SIZE(NA);', PMCode=>pp_line_numbers(__LINE__, <<'EOD'), sub PDL::setdiffvec { my ($a,$b,$c,$nc) = @_; $c = PDL->null if (!defined($c)); $nc = PDL->null if (!defined($nc)); PDL::_setdiffvec_int($a,$b,$c,$nc); return ($c,$nc) if (wantarray); my $nc_max = $nc->max; return ($nc_max > 0 ? $c->slice(",0:".($nc_max-1)) : $c->reshape($c->dim(0), 0, ($c->dims)[2..($c->ndims-1)])); } EOD Code => q( PDL_Indx nai=0, nbi=0, nci=0, sizeNA=$SIZE(NA), sizeNB=$SIZE(NB), sizeNC=$SIZE(NC); int cmpval; for ( ; nci < sizeNC && nai < sizeNA && nbi < sizeNB ; ) { $CMPVEC($a(NA=>nai),$b(NB=>nbi),M,cmpval); // if (cmpval < 0) { //-- CASE: a < b loop (M) %{ $c(NC=>nci) = $a(NA=>nai); %} nai++; nci++; } else if (cmpval > 0) { //-- CASE: a > b nbi++; } else { //-- CASE: a == b nai++; nbi++; } } for ( ; nci < sizeNC && nai < sizeNA ; nai++,nci++ ) { loop (M) %{ $c(NC=>nci) = $a(NA=>nai); %} } $nc() = nci; for ( ; nci < sizeNC; nci++) { //-- zero unpopulated outputs loop (M) %{ $c(NC=>nci) = 0; %} } ), Doc=><<'EOD' =for ref Set-difference ($a() \ $b()) of two vector-valued PDLs. Input PDLs $a() and $b() B be sorted in lexicographic order. On return, $nc() holds the actual number of vector-values in the computed vector set. In scalar context, slices $c() to the actual number of elements in the output vector set and returns the sliced PDL. Contributed by Bryan Jurish Emoocow@cpan.orgE. EOD ); pp_add_macros( CMPVAL => sub { my ($val1, $val2) = @_; "(($val1) < ($val2) ? -1 : ($val1) > ($val2) ? 1 : 0)"; }, ); pp_def('union_sorted', Pars => 'a(NA); b(NB); [o]c(NC); indx [o]nc()', RedoDimsCode => '$SIZE(NC) = $SIZE(NA) + $SIZE(NB);', PMCode=>pp_line_numbers(__LINE__, <<'EOD'), sub PDL::union_sorted { my ($a,$b,$c,$nc) = @_; $c = PDL->null if (!defined($c)); $nc = PDL->null if (!defined($nc)); PDL::_union_sorted_int($a,$b,$c,$nc); return ($c,$nc) if (wantarray); return $c->slice("0:".($nc->max-1)); } EOD Code => q( PDL_Indx nai=0, nbi=0, nci=0, sizeNA=$SIZE(NA), sizeNB=$SIZE(NB), sizeNC=$SIZE(NC); int cmpval; for ( ; nci < sizeNC; nci++) { if (nai < sizeNA && nbi < sizeNB) { cmpval = $CMPVAL($a(NA=>nai), $b(NB=>nbi)); } else if (nai < sizeNA) { cmpval = -1; } else if (nbi < sizeNB) { cmpval = 1; } else { break; } // if (cmpval < 0) { //-- CASE: a < b $c(NC=>nci) = $a(NA=>nai); nai++; } else if (cmpval > 0) { //-- CASE: a > b $c(NC=>nci) = $b(NB=>nbi); nbi++; } else { //-- CASE: a == b $c(NC=>nci) = $a(NA=>nai); nai++; nbi++; } } $nc() = nci; for ( ; nci < sizeNC; nci++) { //-- zero unpopulated outputs $c(NC=>nci) = 0; } ), Doc=><<'EOD' =for ref Union of two flat sorted unique-valued PDLs. Input PDLs $a() and $b() B be sorted in lexicographic order and contain no duplicates. On return, $nc() holds the actual number of values in the union. In scalar context, reshapes $c() to the actual number of elements in the union and returns it. Contributed by Bryan Jurish Emoocow@cpan.orgE. EOD ); pp_def('intersect_sorted', Pars => 'a(NA); b(NB); [o]c(NC); indx [o]nc()', RedoDimsCode => '$SIZE(NC) = PDLMIN($SIZE(NA),$SIZE(NB));', PMCode=>pp_line_numbers(__LINE__, <<'EOD'), sub PDL::intersect_sorted { my ($a,$b,$c,$nc) = @_; $c = PDL->null if (!defined($c)); $nc = PDL->null if (!defined($nc)); PDL::_intersect_sorted_int($a,$b,$c,$nc); return ($c,$nc) if (wantarray); my $nc_max = $nc->max; return ($nc_max > 0 ? $c->slice("0:".($nc_max-1)) : $c->reshape(0, ($c->dims)[1..($c->ndims-1)])); } EOD Code => q( PDL_Indx nai=0, nbi=0, nci=0, sizeNA=$SIZE(NA), sizeNB=$SIZE(NB), sizeNC=$SIZE(NC); int cmpval; for ( ; nci < sizeNC && nai < sizeNA && nbi < sizeNB; ) { cmpval = $CMPVAL($a(NA=>nai),$b(NB=>nbi)); // if (cmpval < 0) { //-- CASE: a < b nai++; } else if (cmpval > 0) { //-- CASE: a > b nbi++; } else { //-- CASE: a == b $c(NC=>nci) = $a(NA=>nai); nai++; nbi++; nci++; } } $nc() = nci; for ( ; nci < sizeNC; nci++) { //-- zero unpopulated outputs $c(NC=>nci) = 0; } ), Doc=><<'EOD' =for ref Intersection of two flat sorted unique-valued PDLs. Input PDLs $a() and $b() B be sorted in lexicographic order and contain no duplicates. On return, $nc() holds the actual number of values in the intersection. In scalar context, reshapes $c() to the actual number of elements in the intersection and returns it. Contributed by Bryan Jurish Emoocow@cpan.orgE. EOD ); pp_def('setdiff_sorted', Pars => 'a(NA); b(NB); [o]c(NC); indx [o]nc()', RedoDimsCode => '$SIZE(NC) = $SIZE(NA);', PMCode=>pp_line_numbers(__LINE__, <<'EOD'), sub PDL::setdiff_sorted { my ($a,$b,$c,$nc) = @_; $c = PDL->null if (!defined($c)); $nc = PDL->null if (!defined($nc)); PDL::_setdiff_sorted_int($a,$b,$c,$nc); return ($c,$nc) if (wantarray); my $nc_max = $nc->max; return ($nc_max > 0 ? $c->slice("0:".($nc_max-1)) : $c->reshape(0, ($c->dims)[1..($c->ndims-1)])); } EOD Code => q( PDL_Indx nai=0, nbi=0, nci=0, sizeNA=$SIZE(NA), sizeNB=$SIZE(NB), sizeNC=$SIZE(NC); int cmpval; for ( ; nci < sizeNC && nai < sizeNA && nbi < sizeNB ; ) { cmpval = $CMPVAL($a(NA=>nai),$b(NB=>nbi)); // if (cmpval < 0) { //-- CASE: a < b $c(NC=>nci) = $a(NA=>nai); nai++; nci++; } else if (cmpval > 0) { //-- CASE: a > b nbi++; } else { //-- CASE: a == b nai++; nbi++; } } for ( ; nci < sizeNC && nai < sizeNA ; nai++,nci++ ) { $c(NC=>nci) = $a(NA=>nai); } $nc() = nci; for ( ; nci < sizeNC; nci++) { //-- zero unpopulated outputs $c(NC=>nci) = 0; } ), Doc=><<'EOD' =for ref Set-difference ($a() \ $b()) of two flat sorted unique-valued PDLs. Input PDLs $a() and $b() B be sorted in lexicographic order and contain no duplicate values. On return, $nc() holds the actual number of values in the computed vector set. In scalar context, reshapes $c() to the actual number of elements in the difference set and returns it. Contributed by Bryan Jurish Emoocow@cpan.orgE. EOD ); 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, HaveBroadcasting => 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=>pp_line_numbers(__LINE__, <<'EOD'), *srand = \&PDL::srand; sub PDL::srand { PDL::_srand_int($_[0] // PDL::Core::seed()) } EOD ); pp_def( 'random', Pars=>'[o] a();', GenericTypes => [ppdefs_all], PMFunc => '', Code => <<'EOF', PDL_MAYBE_SRAND int rand_offset = -1; broadcastloop %{ PDL_RAND_SET_OFFSET(rand_offset, $PRIV(broadcast), $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=>pp_line_numbers(__LINE__, <<'EOD'), sub random { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->random : PDL->random(@_) } sub PDL::random { my $class = shift; unshift @_, double() if !ref($class) and !@_; my $x = scalar(@_)? $class->new_from_specification(@_) : $class->new_or_inplace; PDL::_random_int($x); return $x; } EOD ); pp_def( 'randsym', Pars=>'[o] a();', GenericTypes => [ppdefs_all], PMFunc => '', Code => <<'EOF', PDL_MAYBE_SRAND int rand_offset = -1; broadcastloop %{ PDL_RAND_SET_OFFSET(rand_offset, $PRIV(broadcast), $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=>pp_line_numbers(__LINE__, <<'EOD'), sub randsym { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->randsym : PDL->randsym(@_) } sub PDL::randsym { my $class = shift; unshift @_, double() if !ref($class) and !@_; my $x = scalar(@_)? $class->new_from_specification(@_) : $class->new_or_inplace; PDL::_randsym_int($x); return $x; } EOD ); pp_add_exported('','grandom'); 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 ############################################################### # binary searches in an ndarray; various forms ############################################################### # generic front end; defaults to vsearch_sample for backwards compatibility pp_add_exported('','vsearch'); 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[ if ( $SIZE(n) == 0 ){ broadcastloop %{ loop(n) %{ $SETBAD(idx()); %} %} } else { broadcastloop %{ loop(n) %{ if ( $ISGOOD(vals()) ) { 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% } else { $SETBAD(idx()); } %} %} } ---- ]; 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. if C<$x> is empty, then all values in C<$idx> will be set to the bad value. %PRE% %BODY% %POST% ---- ]; # redo until nothing changes for my $tref ( \$code, \$doc ) { 1 while $$tref =~ s/(%[\w_]+%)/$replace{$1}/ge; } pp_def( $func, HandleBad => 1, BadDoc => 'bad values in vals() result in bad values in idx()', 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 => 'real xi(); real x(n); y(n); [o] yi(); int [o] err()', GenericTypes => $AF, PMCode=>pp_line_numbers(__LINE__, <<'EOD'), sub PDL::interpolate { my ($xi, $x, $y, $yi, $err) = @_; croak "x must be real" if (ref($x) && ! $x->type->real); croak "xi must be real" if (ref($xi) && ! $xi->type->real); $yi //= PDL->null; $err //= PDL->null; PDL::_interpolate_int($xi, $x, $y, $yi, $err); ($yi, $err); } EOD 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; broadcastloop %{ 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. Note that C can use complex values for C<$y> and C<$yi> but C<$x> and C<$xi> must be real. =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 = @_ == 1 ? $_[0] : 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 @_ == 0; } # 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 broadcast; cth = cube broadcast; sth = source broadcast) 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) { local $@; 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 @_ != 2; 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 nonzero and zero values in the mask. L returns separately slices of both nonzero and zero 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 nonzero and zero 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> p $x = sequence(10) [0 1 2 3 4 5 6 7 8 9] pdl> ($big, $small) = which_both($x >= 5); p "$big\n$small" [5 6 7 8 9] [0 1 2 3 4] =cut EOD for ( {Name=>'which', Pars => 'mask(n); indx [o] inds(n); indx [o]lastout()', Variables => 'PDL_Indx dm=0;', Elseclause => "", Outclause => '$lastout() = dm; while (dm < $SIZE(n)) $inds(n=>dm++) = -1;', Doc => $doc_which, PMCode=>pp_line_numbers(__LINE__, <<'EOD'), sub which { my ($this,$out) = @_; $this = $this->flat; $out //= $this->nullcreate; PDL::_which_int($this,$out,my $lastout = $this->nullcreate); my $lastoutmax = $lastout->max->sclr; $lastoutmax ? $out->slice('0:'.($lastoutmax-1))->sever : empty(indx); } *PDL::which = \&which; EOD }, {Name => 'which_both', Pars => 'mask(n); indx [o] inds(n); indx [o]notinds(n); indx [o]lastout(); indx [o]lastoutn()', Variables => 'PDL_Indx dm=0; int dm2=0;', Elseclause => "else { \n \$notinds(n => dm2)=n; \n dm2++;\n }", Outclause => '$lastout() = dm; $lastoutn() = dm2; while (dm < $SIZE(n)) $inds(n=>dm++) = -1; while (dm2 < $SIZE(n)) $notinds(n=>dm2++) = -1;', Doc => $doc_which_both, PMCode=>pp_line_numbers(__LINE__, <<'EOD'), sub which_both { my ($this,$outi,$outni) = @_; $this = $this->flat; $outi //= $this->nullcreate; $outni //= $this->nullcreate; PDL::_which_both_int($this,$outi,$outni,my $lastout = $this->nullcreate,my $lastoutn = $this->nullcreate); my $lastoutmax = $lastout->max->sclr; $outi = $lastoutmax ? $outi->slice('0:'.($lastoutmax-1))->sever : empty(indx); return $outi if !wantarray; my $lastoutnmax = $lastoutn->max->sclr; ($outi, $lastoutnmax ? $outni->slice('0:'.($lastoutnmax-1))->sever : empty(indx)); } *PDL::which_both = \&which_both; EOD } ) { pp_def($_->{Name}, HandleBad => 1, Doc => $_->{Doc}, Pars => $_->{Pars}, GenericTypes => [ppdefs_all], PMCode => $_->{PMCode}, Code => $_->{Variables} .' loop(n) %{ if ( $mask() PDL_IF_BAD(&& $ISGOOD($mask()),) ) { $inds(n => dm) = n; dm++; }'.$_->{Elseclause}.' %}'.$_->{Outclause}, ); } pp_add_exported("", 'where'); 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 broadcast 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* broadcast over a smaller mask, for example. =cut sub PDL::where { barf "Usage: where( \$pdl1, ..., \$pdlN, \$mask )\n" if @_ == 1; if(@_ == 2) { 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_both'); pp_addpm(<<'EOD'); =head2 where_both =for ref Returns slices (non-zero in mask, zero) of an ndarray according to a mask =for usage ($match_vals, $non_match_vals) = where_both($pdl, $mask); This works like L, but (flattened) data-flowing slices rather than index-sets are returned. =for example pdl> p $x = sequence(10) + 2 [2 3 4 5 6 7 8 9 10 11] pdl> ($big, $small) = where_both($x, $x > 5); p "$big\n$small" [6 7 8 9 10 11] [2 3 4 5] pdl> p $big += 2, $small -= 1 [8 9 10 11 12 13] [1 2 3 4] pdl> p $x [1 2 3 4 8 9 10 11 12 13] =cut sub PDL::where_both { barf "Usage: where_both(\$pdl, \$mask)\n" if @_ != 2; my ($arr, $mask) = @_; # $mask has 0==false, 1==true my $arr_flat = $arr->clump(-1); map $arr_flat->index1d($_), PDL::which_both($mask); } *where_both = \&PDL::where_both; EOD pp_add_exported("", 'whereND'); pp_addpm(<<'EOD'); =head2 whereND =for ref C with support for ND masks and broadcasting 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 broadcasting 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 broadcasting 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 @_ == 1; my $mask = pop @_; # $mask has 0==false, 1==true my @to_return; my $n = PDL::sum($mask); my $maskndims = $mask->ndims; foreach my $arr (@_) { # count the number of dims in $mask and $arr # $mask = a b c d e f..... my @idims = dims($arr); splice @idims, 0, $maskndims; # pop off the number of dims in $mask if (!$n or $arr->isempty) { push @to_return, PDL->zeroes($arr->type, $n, @idims); next; } my $sub_i = $mask * ones($arr); my $where_sub_i = PDL::where($arr, $sub_i); 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("", 'whichND'); 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, broadcasting-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 # # Set operations suited for manipulation of the operations above. # pp_add_exported("", 'setops'); 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. return $x if $x->isempty; return $y if $y->isempty; # Make ordered list of set union. my $union = append($x, $y)->qsort; return $union->where($union == rotate($union, -1))->uniq; } else { print "The operation $op is not known!"; return -1; } } EOD pp_add_exported("", 'intersect'); 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_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.085/Basic/Primitive/xoshiro256plus.c0000644000175000017500000001037214202424257020073 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.085/Basic/Primitive/Makefile.PL0000644000175000017500000000057214202424257017046 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.085/Basic/LiteF.pm0000644000175000017500000000156014146003631014457 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.085/Basic/Reduce.pm0000644000175000017500000001210014202424257014657 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 broadcasting 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.085/Basic/Core/0000755000175000017500000000000014556074541014021 5ustar osboxesosboxesPDL-2.085/Basic/Core/Core.pm0000644000175000017500000033662414555537050015263 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 broadcastids topdl); my @exports_normal = (@EXPORT, @convertfuncs, qw(nelem dims shape null empty dup dupN inflateN badflag convert inplace zeroes zeros ones nan inf i list listindices unpdl set at flows broadcast_define over reshape dog cat barf type thread_define 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 *thread_define = *broadcast_define; *PDL::threadover_n = *PDL::broadcastover_n; 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 { for (qw( inflateN badflag dup dupN howbig unpdl nelem inplace dims list broadcastids listindices null set at flows sclr shape broadcast_define convert over dog cat mslice type approx dummy isempty string )) { no strict 'refs'; *{$_} = \&{"PDL::$_"}; } } =head1 NAME PDL::Core - fundamental PDL functionality and vectorization/broadcasting =head1 DESCRIPTION Methods and functions for type conversions, PDL creation, type conversion, broadcasting etc. =head1 SYNOPSIS use PDL::Core; # Normal routines use PDL::Core ':Internal'; # Hairy routines =head1 VECTORIZATION/BROADCASTING: METHOD AND NOMENCLATURE PDL provides vectorized operations via a built-in engine. Vectorization in PDL is called "broadcasting" (formerly, up to 2.074, "threading"). The broadcasting 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 Broadcasting 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 "broadcast dims". The broadcast 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 broadcasting 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 broadcasting rules -- a dim with size 0 can only match a corresponding dim of size 0 or 1. =head2 Broadcast rules and assignments Versions of PDL through 2.4.10 have some irregularity with broadcasting and assignments. Currently the broadcasting 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 * 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 = PDL->new([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 empty =for ref Returns an empty ndarray, with a single zero-length dimension. Only available as a function, not a method. =for usage $x = empty; # defaults to lowest type so it can always be promoted up $x = empty(float); =cut sub empty { my ($type) = @_; $type //= 0; PDL->new_from_specification(PDL::Type->new($type), 0); } =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 broadcasting 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 set_datatype =for ref Sets the ndarray's data type to the given value (the integer identifier for the type, see L). See L. Internal function. =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 Carp; use overload '""' => \&PDL::Core::string, "=" => sub {$_[0]}, # Don't deep copy, just copy reference 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; confess("bad value ndarray in conditional expression") if $_[0]->badflag and $_[0].'' eq 'BAD'; $_[0]->clump(-1)->at(0); }, ; } ##################### Data type/conversion stuff ######################## 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 broadcastids =for ref Returns the ndarray broadcast 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 = broadcastids $ndarray; =cut ################# Creation/copying functions ####################### sub piddle {PDL->pdl(@_)} sub pdl {PDL->pdl(@_)} sub PDL::pdl { shift->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 fflows =for ref Returns whether the ndarray's C flag is set. =head2 bflows =for ref Returns whether the ndarray's C flag is set. =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 $y = PDL->new(@list_of_vals); # new from Perl list $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 = PDL->new(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 { return $_[0]->copy if ref($_[0]); my $this = shift; my $type = ref($_[0]) eq 'PDL::Type' ? shift->enum : undef; my $value = (@_ > 1 ? [@_] : shift); 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); return $value->nullcreate if $value->isnull; # broadcastI(-1,[]) is just an identity vafftrans with broadcastid copying ;) $value->broadcastI(-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 broadcastids have been removed. =for usage $y = $x->unwind; =cut sub PDL::unwind { my $value = shift; my $foo = $value->null(); $foo .= $value->unbroadcast(); return $foo; } =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). =head2 make_physvaffine =for ref A more "careful" function than C. For ndarrays without a vaffine transformations as parent, it will just call C. Otherwise, it will update the vaffine transformation bookkeeping. =head2 make_physdims =for ref Ensures the ndarray's dimensions are up to date including changes in parent's dimensions, and calling C. =head2 trans_parent =for ref Returns a PDL::Trans object representing the transformation (PDL operation) that is the "parent" of this ndarray, or C if none. Such objects have these methods: =over =item parents Returns a list of ndarrays that are inputs to this trans. =item children Returns a list of ndarrays that are outputs to this trans (specified as C<[o]>, C<[oca]>, C<[io]>, or C<[t]> in C). =item address The memory address of the struct. =item name The function name from the vtable. =item flags List of strings of flags set for this trans. =item flags_vtable List of strings of flags set for this trans's vtable. =item vaffine Whether the trans is affine. =item offs Affine-only: the offset into the parent's data. =item incs Affine-only: the dimincs for each of the child's dims. =item ind_sizes The size of each named dim. =item inc_sizes The size of the inc for each use of a named dim. =back =head2 trans_children =for ref Returns a list of PDL::Trans objects (see L) representing each transformation that has this ndarray as an input. =head2 address =for ref Returns the memory address of the ndarray's C. =head2 address_data =for ref Returns the value of the ndarray C's C member. =head2 freedata =for ref Frees the C if possible. Useful in memory-mapping functionality. =head2 set_donttouchdata =for ref Sets the C flag and the C to the given value. Useful in memory-mapping functionality. =head2 set_data_by_offset =for ref Sets the ndarray's C and C to those of the given ndarray, but the C points to the other ndarray's C plus the given offset. Sets the C flag. Useful in memory-mapping functionality. =head2 nbytes =for ref Returns the ndarray's C. =head2 seed =for ref Returns the random seed being used by PDL's RNG. =head2 set_debugging =for ref Sets whether PDL operations print lots of debugging info to standard output. Returns the old value. =for example PDL::Core::set_debugging(1); # ... these operations will have debugging info printed to stdout PDL::Core::set_debugging(0); # turn it off again =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 dup =for ref Duplicates an ndarray along a dimension =for example $x = sequence(3); $y = $x->dup(0, 2); # doubles along first dimension # $y now [0 1 2 0 1 2] =cut sub PDL::dup { my ($this, $dim, $times) = @_; return $this->copy if $times == 1; $this->dummy($dim+1, $times)->clump($dim, $dim+1); } =head2 dupN =for ref Duplicates an ndarray along several dimensions =for example $x = sequence(3,2); $y = $x->dupN(2, 3); # doubles along first dimension, triples along second # [ # [0 1 2 0 1 2] # [3 4 5 3 4 5] # [0 1 2 0 1 2] # [3 4 5 3 4 5] # [0 1 2 0 1 2] # [3 4 5 3 4 5] # ] =cut sub PDL::dupN { my ($this, @times) = @_; return $this->copy if !grep $_ != 1, @times; my $sl = join ',', map ":,*$_", @times; # insert right-size dummy after each real $this = $this->slice($sl); $this = $this->clump($_, $_+1) for 0..$#times; $this; } =head2 inflateN =for ref Inflates an ndarray along several dimensions, useful for e.g. Kronecker products cf L =for example $x = sequence(3,2); $y = $x->inflateN(2, 2); # doubles along first two dimensions # [ # [0 0 1 1 2 2] # [0 0 1 1 2 2] # [3 3 4 4 5 5] # [3 3 4 4 5 5] # ] =cut sub PDL::inflateN { my ($this, @times) = @_; return $this->copy if !grep $_ != 1, @times; my $sl = join ',', map "*$_,:", @times; $this = $this->slice($sl); $this = $this->clump($_, $_+1) for 0..$#times; $this; } =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->broadcast(@dims)->unbroadcast(0)->clump(scalar @dims); $clumped = $clumped->mv(0,$targd) if $targd > 0; return $clumped; } =head2 broadcast_define =for ref define functions that support broadcasting at the perl level =for example broadcast_define 'tline(a(n);b(n))', over { line $_[0], $_[1]; # make line compliant with broadcasting }; C provides some support for broadcasting (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 broadcasting. 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 broadcasting, 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::broadcast_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::broadcast_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::broadcastover($others,@_,$sig->realdims,$sig->creating,$sub); }; } =head2 broadcast =for ref Use explicit broadcasting over specified dimensions (see also L) =for usage $y = $x->broadcast($dim,[$dim1,...]) =for example $x = zeroes 3,4,5; $y = $x->broadcast(2,0); Same as L, i.e. uses broadcast id 1. =cut sub PDL::broadcast { my $var = shift; $var->broadcastI(1,\@_); } =head2 broadcast1 =for ref Explicit broadcasting over specified dims using broadcast id 1. =for usage $xx = $x->broadcast1(3,1) =for example Wibble Convenience function interfacing to L. =cut sub PDL::broadcast1 { my $var = shift; $var->broadcastI(1,\@_); } =head2 broadcast2 =for ref Explicit broadcasting over specified dims using broadcast id 2. =for usage $xx = $x->broadcast2(3,1) =for example Wibble Convenience function interfacing to L. =cut sub PDL::broadcast2 { my $var = shift; $var->broadcastI(2,\@_); } =head2 broadcast3 =for ref Explicit broadcasting over specified dims using broadcast id 3. =for usage $xx = $x->broadcast3(3,1) =for example Wibble Convenience function interfacing to L. =cut sub PDL::broadcast3 { my $var = shift; $var->broadcastI(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->broadcastids; 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 pdump =for ref Returns a close analogue of the output of C<< $pdl->dump >> as a string. Like that C function, it will not cause any physicalisation of the ndarray. Not exported, and not inserted into the C namespace. =for example print PDL::Core::pdump($pdl); =cut sub pdump { my ($pdl) = @_; my @dims = $pdl->dims_nophys; my @lines = ( "State: ${\join '|', $pdl->flags}", "Dims: (@dims)", "BroadcastIds: (@{[$pdl->broadcastids_nophys]})", ); push @lines, sprintf "Vaffine: 0x%x (parent)", $pdl->vaffine_from if $pdl->vaffine; push @lines, !$pdl->allocated ? '(not allocated)' : join "\n ", sprintf("data: 0x%x, nbytes: %d, nvals: %d", $pdl->address_data, $pdl->nbytes, $pdl->nelem_nophys), "First values: (@{[$pdl->firstvals_nophys]})", ; if (my $trans = $pdl->trans_parent) { push @lines, grep length, split "\n", pdump_trans($trans); } if (my @trans_children = $pdl->trans_children) { push @lines, "CHILDREN:"; push @lines, map " $_", grep length, split "\n", pdump_trans($_) for @trans_children; } join '', "PDUMPING 0x${\sprintf '%x', $pdl->address}, datatype: ${\$pdl->get_datatype}\n", map " $_\n", @lines; } =head2 pdump_trans =for ref Returns a string representation of a C object, a close analogue of part of the output of C<< $pdl->dump >>. Not exported, and not inserted into the C namespace. =for example print PDL::Core::pdump_trans($pdl_trans); =cut sub pdump_trans { my ($trans) = @_; my @lines = ( "State: ${\join '|', $trans->flags}", "vtable flags: ${\join '|', $trans->flags_vtable}", ); my @ins = $trans->parents; my @outs = $trans->children; push @lines, "AFFINE, " . ($outs[0]->dimschgd ? "BUT DIMSCHANGED" : "o:".$trans->offs." i:(@{[$trans->incs]}) d:(@{[$outs[0]->dims_nophys]})") if $trans->vaffine; push @lines, "ind_sizes: (@{[$trans->ind_sizes]})", "inc_sizes: (@{[$trans->inc_sizes]})", "INPUTS: (@{[map sprintf('0x%x', $_->address), @ins]}) OUTPUTS: (@{[map sprintf('0x%x', $_->address), @outs]})", ; join '', "PDUMPTRANS 0x${\sprintf '%x', $trans->address} (${\$trans->name})\n", map " $_\n", @lines; } =head2 pdumphash =for ref Returns a hash-ref representing the information about a given object (C or ndarray) and all the objects of either type it is connected to. Includes similar information to that shown by L and L. Not exported, and not inserted into the C namespace. =for example $hashref = PDL::Core::pdumphash($pdl_trans); # or $hashref = PDL::Core::pdumphash($pdl); =cut # only look at each obj once, mutates the hash sub pdumphash { my ($obj, $sofar) = @_; confess "expected object but got '$obj'" if !ref $obj; $sofar ||= {}; my $addr = sprintf '0x%x', $obj->address; # both ndarray and trans return $sofar if $sofar->{$addr}; if ($obj->isa('PDL::Trans')) { my @ins = $obj->parents; my @outs = $obj->children; $sofar->{$addr} = { kind => 'trans', name => $obj->name, flags => [$obj->flags], vtable_flags => [$obj->flags_vtable], !($obj->vaffine && !$outs[0]->dimschgd) ? () : ( affine => "o:".$obj->offs." i:(@{[$obj->incs]}) d:(@{[$outs[0]->dims_nophys]})" ), ins => [map sprintf('0x%x', $_->address), @ins], outs => [map sprintf('0x%x', $_->address), @outs], }; pdumphash($_, $sofar) for @ins, @outs; } else { my @ins = grep defined, $obj->trans_parent; my @outs = $obj->trans_children; $sofar->{$addr} = { kind => 'ndarray', datatype => $obj->get_datatype, flags => [$obj->flags], !$obj->vaffine ? () : ( vaffine_from => sprintf("0x%x", $obj->vaffine_from), ), !$obj->allocated ? () : ( data => sprintf("0x%x", $obj->address_data), nbytes => $obj->nbytes, nelem_nophys => $obj->nelem_nophys, firstvals => [$obj->firstvals_nophys], ), ins => [map sprintf('0x%x', $_->address), @ins], outs => [map sprintf('0x%x', $_->address), @outs], }; pdumphash($_, $sofar) for @ins, @outs; } $sofar; } =head2 pdumpgraph =for ref Given a hash-ref returned by L, returns a L object representing the same information. Not exported, and not inserted into the C namespace. =for example $g = PDL::Core::pdumphash($hashref); =cut sub pdumpgraph { my ($hash) = @_; require Graph; my $g = Graph->new(multiedged=>1); for my $addr (keys %$hash) { $g->set_vertex_attributes($addr, my $props = $hash->{$addr}); $g->add_edge_by_id($_, $addr, 'normal') for @{ $props->{ins} }; $g->add_edge_by_id($addr, $_, 'normal') for @{ $props->{outs} }; if (my $from = $props->{vaffine_from}) { $g->add_edge_by_id($addr, $from, 'vaffine_from'); } } $g; } =head2 pdumpgraphvizify =for ref Given a L object returned by L, modifies it suitable for input to L, then returns it. See example for how to use. Not exported, and not inserted into the C namespace. =for example $g = PDL::Core::pdumpgraphvizify($g); # full example: $count = 1; $format = 'png'; sub output { $g = PDL::Core::pdumpgraph(PDL::Core::pdumphash($_[0])); require GraphViz2; $gv = GraphViz2->from_graph(PDL::Core::pdumpgraphvizify($g)); $gv->run(format => $format, output_file => 'output'.$count++.".$format"); } # keep changing ndarray, then calling this to show each state: output($pdl); # run the above script, then show the ndarray evolve over time, in a # left-to-right montage using ImageMagick tools: perl myscript.pl montage output* -tile "$(echo output*|wc -w)"x1 -geometry '1x1<' final.png display final.png =cut sub pdumpgraphvizify { my ($g) = @_; for my $v ($g->vertices) { my $kind = $g->get_vertex_attribute($v, 'kind'); if (my $from = $g->get_vertex_attribute($v, 'vaffine_from')) { $g->set_edge_attribute_by_id( $v, $from, 'vaffine_from', graphviz => { style => 'dashed', constraint => 'false' }, ); } my @blocks; push @blocks, $g->get_vertex_attribute($v, 'name') if $kind eq 'trans'; push @blocks, join '', map "$_\\l", @{$g->get_vertex_attribute($v, 'flags')}; if ($kind eq 'trans') { my @vflags = @{$g->get_vertex_attribute($v, 'vtable_flags')}; push @blocks, join '', map "$_\\l", @vflags ? @vflags : '(no vtable flags)'; my $affine = $g->get_vertex_attribute($v, 'affine'); push @blocks, $affine if $affine; } else { my $firstvals = $g->get_vertex_attribute($v, 'firstvals'); $firstvals = ", (".($firstvals ? "@$firstvals" : 'not allocated').")"; push @blocks, 'datatype: '.$g->get_vertex_attribute($v, 'datatype'). $firstvals; } $g->set_vertex_attribute($v, graphviz => { shape => 'record', color => $kind eq 'ndarray' ? 'blue' : 'red', label => [\@blocks], }); } $g->set_graph_attribute(graphviz => { global => {directed => 1, combine_node_and_port => 0}, graph => {concentrate => 'true', rankdir => 'TB'}, }); $g; } =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 tracedebug =for ref Sets whether an ndarray will have debugging info printed during use if a (Boolean) value is given. Returns the new value. =head2 donttouch =for ref Returns whether the ndarray's C flag is set. =head2 allocated =for ref Returns whether the ndarray's C flag is set. =head2 vaffine =for ref Returns whether the ndarray's C flag is set. =head2 anychgd =for ref Returns whether the ndarray's C flag is set. =head2 dimschgd =for ref Returns whether the ndarray's C flag is set. =head2 inplace =for ref Flag an ndarray so that the next operation is done 'in place', returning the ndarray. =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 Sets whether an ndarray will operate "in-place" for the next operation if a (Boolean) value is given. Returns the old value. =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 barf "Tried to convert(null)" if $pdl->isnull; $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 ldouble Convert to long double datatype =head2 cfloat Convert to complex float datatype =head2 cdouble Convert to complex double datatype =head2 cldouble Convert to complex long 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/broadcasting. 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 broadcasting, 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)-1>. 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/broadcasting. 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. =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(max(map $_->get_datatype, @_)); 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; } } }; $@ = $old_err, return $res if !$@; # Restore the old error and return # 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 #################### # 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)=@_; 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; } ########## 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. =cut # # Sleazy hcpy saves me time typing # sub PDL::hcpy { $_[0]->hdrcpy($_[1]); $_[0]; } =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 $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 = Astro::FITS::Header->new(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(1); 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.085/Basic/Core/pdlcore.h0000644000175000017500000002041714434666551015631 0ustar osboxesosboxes#ifndef __PDLCORE_H #define __PDLCORE_H /* version 20: memory-management changes */ /* on 21, unify pdl_broadcast per_pdl_flags, par_flags; remove threadloop #defines; change creating to char; relocate struct pdl.value appropriately, remove pdl_null, safe_indterm */ #define PDL_CORE_VERSION 20 #define startbroadcastloop startthreadloop #define pdl_startbroadcastloop pdl_startthreadloop #define iterbroadcastloop iterthreadloop #define pdl_iterbroadcastloop pdl_iterthreadloop #define get_broadcastdims get_threaddims #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_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); pdl_error pdl_dim_checks(pdl_transvtable *vtable, pdl **pdls, pdl_broadcast *broadcast, PDL_Indx *creating, PDL_Indx *ind_sizes, char load_only); /* 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_broadcast(pdl_broadcast *broadcast); void pdl_dump_broadcasting_info( int npdls, PDL_Indx* creating, int target_pthread, PDL_Indx *nbroadcastedDims, PDL_Indx **broadcastedDims, PDL_Indx **broadcastedDimSizes, int maxPthreadPDL, int maxPthreadDim, int maxPthread ); void pdl_broadcast_mismatch_msg( char *s, pdl **pdls, pdl_broadcast *broadcast, 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(reallocbroadcastids, pdl_error, ( pdl *it,PDL_Indx ndims )) \ X(resize_defaultincs, void, ( pdl *it )) /* Make incs out of dims */ \ X(clearbroadcaststruct, void, (pdl_broadcast *it)) \ X(initbroadcaststruct, pdl_error, (int nobl,pdl **pdls,PDL_Indx *realdims, \ PDL_Indx *creating,PDL_Indx npdls,pdl_transvtable *transvtable, \ pdl_broadcast *broadcast,PDL_Indx *ind_sizes,PDL_Indx *inc_sizes, \ char *flags, int noPthreadFlag)) \ X(redodims_default, pdl_error, (pdl_trans *)) \ X(startbroadcastloop, int, (pdl_broadcast *broadcast,pdl_error (*func)(pdl_trans *), \ pdl_trans *, pdl_error *)) \ X(get_threadoffsp, PDL_Indx*, (pdl_broadcast *broadcast)) /* For pthreading */ \ X(get_broadcastdims, PDL_Indx*, (pdl_broadcast *broadcast)) /* For pthreading */ \ X(iterbroadcastloop, int, (pdl_broadcast *broadcast, PDL_Indx which)) \ X(freebroadcaststruct, void, (pdl_broadcast *broadcast)) \ X(broadcast_create_parameter, pdl_error, (pdl_broadcast *broadcast,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)) \ X(packpdls, pdl **, ( SV* sv, PDL_Indx *npdls )) \ X(unpackpdls, SV*, ( pdl **, PDL_Indx npdls )) /*************** 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_Indx ndims, PDL_Indx 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, nullcheck) \ type *name ## _datap = ((type *)(PDL_REPRP_TRANS(pdlname, flag))); \ type *name ## _physdatap = ((type *)(pdlname->data)); \ if ((nullcheck) && pdlname->nvals > 0 && !name ## _datap) \ return PDL_CORE_(make_error_simple)(PDL_EUSERERROR, "parameter " #name " got NULL data"); \ (void)name ## _physdatap; #define PDL_DECLARE_PARAMETER_BADVAL(type, flag, name, pdlname, nullcheck) \ PDL_DECLARE_PARAMETER(type, flag, name, pdlname, nullcheck) \ 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.085/Basic/Core/pdl.h.PL0000644000175000017500000006141014556032063015256 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_complex); print OUT makelister('COMPLEX', 1, 0, @generics_complex); 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; #define PDL_CHKMAGIC_GENERAL(it,this_magic,type) \ if((it)->magicno != this_magic) \ return pdl_make_error(PDL_EFATAL, \ "INVALID " type " MAGICNO, got hex=%p (%lu)%s\n", \ it,(unsigned long)((it)->magicno), \ ((it)->magicno) == PDL_CLEARED_MAGICNO ? " (cleared)" : "" \ ); \ else (void)0 #define PDL_CLEARED_MAGICNO 0x99876134 /* value once "cleared" */ #define PDL_CLRMAGIC(it) (it)->magicno = PDL_CLEARED_MAGICNO #include "pdlbroadcast.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_NBROADCASTIDS 4 /* Number of different broadcastids/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_BROADCAST 0x0001 #define PDL_TRANS_BADPROCESS 0x0002 #define PDL_TRANS_BADIGNORE 0x0004 #define PDL_TRANS_NO_PARALLEL 0x0008 #define PDL_TRANS_OUTPUT_OTHERPAR 0x0010 #define PDL_LIST_FLAGS_PDLVTABLE(X) \ X(PDL_TRANS_DO_BROADCAST) \ 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_broadcast broadcast; \ 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_TR_MAGICNO 0x91827364 #define PDL_TR_CHKMAGIC(it) PDL_CHKMAGIC_GENERAL(it, PDL_TR_MAGICNO, "TRANS") #define PDL_TR_SETMAGIC(it) (it)->magicno = PDL_TR_MAGICNO // 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_CHKMAGIC(it) PDL_CHKMAGIC_GENERAL(it,PDL_MAGICNO,"PDL") #define PDL_SETMAGIC(it) (it)->magicno = 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 *broadcastids; /* Starting index of the broadcast index set n */ PDL_Indx nbroadcastids; 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_broadcastids[PDL_NBROADCASTIDS]; struct pdl_magic *magic; void *hdrsv; /* "header", settable from Perl */ PDL_Value value; /* to store at least one value */ }; 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 PDL_USESTRUCTVALUE(it) \ (it->nbytes <= sizeof(it->value)) #define PDLMAX(a,b) ((a) > (b) ? (a) : (b)) #define PDLMIN(a,b) ((a) < (b) ? (a) : (b)) #define PDL_RETERROR2(rv, expr, iferr) \ do { rv = expr; if (rv.error) { iferr } } while (0) #define PDL_RETERROR(rv, expr) PDL_RETERROR2(rv, expr, return rv;) #define PDL_ACCUMERROR(rv, expr) rv = pdl_error_accumulate(rv, expr) #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_BROADCASTLOOP_START(funcName, brc, vtable, ptrStep1, ptrStep2, ptrStep3) \ __brcloopval = PDL->startbroadcastloop(&(brc),(vtable)->funcName, __privtrans, &PDL_err); \ if (PDL_err.error) return PDL_err; \ if ( __brcloopval < 0 ) return PDL->make_error_simple(PDL_EFATAL, "Error starting broadcastloop"); \ if ( __brcloopval ) return PDL_err; \ do { \ PDL_Indx *__tdims = PDL->get_broadcastdims(&(brc)); \ if (!__tdims) return PDL->make_error_simple(PDL_EFATAL, "Error in get_broadcastdims"); \ register PDL_Indx __tdims0 = __tdims[0]; \ register PDL_Indx __tdims1 = __tdims[1]; \ register PDL_Indx *__offsp = PDL->get_threadoffsp(&(brc)); \ 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 loop. Make sure inside is optimal.") #define PDL_BROADCASTLOOP_END(brc, ptrStep1) \ } \ } \ PDL_COMMENT("undo outer-loop of tinc1*tdims1, and original per-pthread offset") \ ptrStep1 \ __brcloopval = PDL->iterbroadcastloop(&(brc),2); \ if ( __brcloopval < 0 ) return PDL->make_error_simple(PDL_EFATAL, "Error in iterbroadcastloop"); \ } while(__brcloopval); /* __PDL_H */ #endif !NO!SUBS! PDL-2.085/Basic/Core/pdlcore.c0000644000175000017500000013076014556007514015620 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 } /* "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 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; int 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; ENTER ; SAVETMPS ; PUSHMARK(sp) ; int 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. */ int datalevel = -1; AV *av = (AV *)SvRV(sv); AV *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)); if (!ret) croak("Fatal error: ndarray address is NULL"); /* 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; } /* Pack array of pdl* - returns pdls[] (pdl_smalloced) and npdls */ pdl ** pdl_packpdls( SV* sv, PDL_Indx *npdls ) { if (!SvOK(sv)) { /* undef is OK, treat as empty */ *npdls = 0; return NULL; } if (!SvROK(sv)) pdl_pdl_barf("Gave a non-reference as array-ref of PDLs"); if (SvTYPE(SvRV(sv))!=SVt_PVAV) pdl_pdl_barf("Gave a non-array-reference as array-ref of PDLs"); AV *array = (AV *) SvRV(sv); if (!array) pdl_pdl_barf("Failed to get AV from reference"); *npdls = (PDL_Indx) av_len(array) + 1; if (!*npdls) return NULL; pdl **pdls = (pdl **) pdl_smalloc( (*npdls) * sizeof(*pdls) ); if (!pdls) pdl_pdl_barf("Failed to allocate memory for pointers to PDLs"); PDL_Indx i; for(i=0; i<(*npdls); i++) { SV **s = av_fetch( array, i, 0 ); if (!s) pdl_pdl_barf("Failed to fetch SV #%"IND_FLAG, i); pdls[i] = pdl_SvPDLV(*s); } return pdls; } /* Unpack array of pdl* into SV* */ SV* pdl_unpackpdls( pdl **pdls, PDL_Indx npdls ) { AV *array = newAV(); if (!array) return NULL; av_extend(array, npdls + 1); PDL_Indx i; for(i=0; i= 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 broadcastloops 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 */ \ PDL_Indx level, /* Recursion level */ \ PDL_Indx stride, /* Stride through memory for the current dim */ \ pdl* source_pdl, /* pointer to the source pdl */ \ PDL_Indx 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=%"IND_FLAG"; 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. */ \ PDL_Indx 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 \ ); \ if(i >= dest_dims[ndims - 1 - level]) return undef_count; \ /* pad the rest of this dim to zero if there are not enough elements in the source PDL... */ \ PDL_Indx cursor, target; \ cursor = i * stride; \ target = dest_dims[ndims-1-level]*stride; \ undef_count += target - cursor; \ for (; cursor < target; cursor++) dest_data[cursor] = undefval; \ 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, PDL_Indx ndims, PDL_Indx 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; \ 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 */ dSP; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs( hdrp ); PUTBACK; int 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)."); SV *retval = (SV *) POPs ; if (SvROK(retval)) (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; 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) return; SV *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) */ SV **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 ((s*181)*((pid-83)*359))%104729; } PDL-2.085/Basic/Core/IFiles.pm0000644000175000017500000000303614202424257015523 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.085/Basic/Core/pdlutil.c0000644000175000017500000003726014556023410015637 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 = broadcast->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,broadcast->npdls); printf("\n"); } psp; printf("Flags: "); found=0; sz=0; for (i=0;flagval[i]!=0; i++) if (broadcast->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", broadcast->ndims,broadcast->nimpl,broadcast->npdls,broadcast->nextra); psp; printf("Mag_nth: %"IND_FLAG", Mag_nthpdl: %"IND_FLAG", Mag_nthr: %"IND_FLAG", Mag_skip: %"IND_FLAG", Mag_stride: %"IND_FLAG"\n", broadcast->mag_nth,broadcast->mag_nthpdl,broadcast->mag_nthr,broadcast->mag_skip,broadcast->mag_stride); if (broadcast->mag_nthr <= 0) { psp; printf("Dims: "); pdl_print_iarr(broadcast->dims,broadcast->ndims); printf("\n"); psp; printf("Inds: "); pdl_print_iarr(broadcast->inds,broadcast->ndims); printf("\n"); psp; printf("Offs: "); pdl_print_iarr(broadcast->offs,broadcast->npdls); printf("\n"); } else { psp; printf("Dims (per thread):\n"); for (i=0;imag_nthr;i++) { psp; psp; pdl_print_iarr(broadcast->dims + i*broadcast->ndims,broadcast->ndims); printf("\n"); } psp; printf("Inds (per thread):\n"); for (i=0;imag_nthr;i++) { psp; psp; pdl_print_iarr(broadcast->inds + i*broadcast->ndims,broadcast->ndims); printf("\n"); } psp; printf("Offs (per thread):\n"); for (i=0;imag_nthr;i++) { psp; psp; pdl_print_iarr(broadcast->offs + i*broadcast->npdls,broadcast->npdls); printf("\n"); } } psp; printf("Incs (per dim):\n"); for (i=0;indims;i++) { psp; psp; pdl_print_iarr(&PDL_BRC_INC(broadcast->incs, broadcast->npdls, 0, i),broadcast->npdls); printf("\n"); } psp; printf("Realdims: "); pdl_print_iarr(broadcast->realdims,broadcast->npdls); printf("\n"); psp; printf("Pdls: ("); for (i=0;inpdls;i++) printf("%s%p",(i?" ":""),(void*)(broadcast->pdls[i])); printf(")\n"); psp; printf("Per pdl flags: ("); for (i=0;inpdls;i++) printf("%s%d",(i?" ":""),broadcast->flags[i]); printf(")\n"); } void pdl_dump_broadcasting_info( int npdls, PDL_Indx* creating, int target_pthread, PDL_Indx *nbroadcastedDims, PDL_Indx **broadcastedDims, PDL_Indx **broadcastedDimSizes, int maxPthreadPDL, int maxPthreadDim, int maxPthread ) { PDL_Indx j, k; for(j=0; jdims[i],pdls[j]->dims[i+realdims[j]], broadcast->npdls,nimpl,(nimpl==1)?"":"s" ); s += strlen(s); for(ii=maxrealdims=0; iinpdls; ii++) if(broadcast->realdims[ii]>maxrealdims) maxrealdims=broadcast->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,"BROADCAST 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 - broadcast->realdims[ii]; jj++) { sprintf(s,"%8s"," "); s += strlen(s); } for(jj=0; jj< broadcast->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+broadcast->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("(%d) ",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%s Flags: ",spaces,(void*)it,it->vtable->name,spaces); 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>it->vtable->nparents?" ":""),(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%s State: ",spaces,(void*)it,it->datatype,spaces); 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 BroadcastIds: %p ",spaces,(void*)(it->broadcastids)); pdl_print_iarr(it->broadcastids, it->nbroadcastids); 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); fflush(stdout); } 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.085/Basic/Core/Core.xs0000644000175000017500000006231314553552765015300 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 PDL_FLAG_COMMA(f) f, #define PDL_FLAG_STRCOMMA(f) #f, #define PDL_FLAG_DUMP(macro, flagvar) \ int flagval[] = { \ macro(PDL_FLAG_COMMA) \ 0 \ }; \ char *flagchar[] = { \ macro(PDL_FLAG_STRCOMMA) \ NULL \ }; \ int i, f = flagvar; \ for (i=0; flagval[i]!=0; i++) \ if (f & flagval[i]) \ XPUSHs(sv_2mortal(newSVpv(flagchar[i], 0))); #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) return; 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()" IV address(self) pdl *self; CODE: RETVAL = PTR2IV(self); OUTPUT: RETVAL IV address_data(self) pdl *self; CODE: RETVAL = PTR2IV(self->data); OUTPUT: RETVAL PDL_Indx nelem_nophys(x) pdl *x CODE: RETVAL = x->nvals; OUTPUT: RETVAL # only returns list, not context-aware void dims_nophys(x) pdl *x PPCODE: EXTEND(sp, x->ndims); PDL_Indx i; for(i=0; indims; i++) mPUSHi(x->dims[i]); # only returns list, not context-aware void broadcastids_nophys(x) pdl *x PPCODE: EXTEND(sp, x->nbroadcastids); PDL_Indx i; for(i=0; inbroadcastids; i++) mPUSHi(x->broadcastids[i]); void firstvals_nophys(x) pdl *x PPCODE: if (!(x->state & PDL_ALLOCATED)) barf("firstvals_nophys called on non-ALLOCATED", x); PDL_Indx i, maxvals = PDLMIN(10, x->nvals); EXTEND(sp, maxvals); for(i=0; ivafftrans) barf("vaffine_from called on %p with NULL vafftrans", self); RETVAL = PTR2IV(self->vafftrans->from); OUTPUT: RETVAL void flags(x) pdl *x PPCODE: PDL_FLAG_DUMP(PDL_LIST_FLAGS_PDLSTATE, x->state) 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) { PDLDEBUG_f(printf("pdl=%p SvREFCNT_dec datasv=%p\n",it,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) IV address(self) pdl_trans *self; CODE: RETVAL = PTR2IV(self); OUTPUT: RETVAL char * name(self) pdl_trans *self; CODE: if (!self->vtable) barf("%p has NULL vtable", self); RETVAL = self->vtable->name; OUTPUT: RETVAL void flags(x) pdl_trans *x PPCODE: PDL_FLAG_DUMP(PDL_LIST_FLAGS_PDLTRANS, x->flags) void flags_vtable(x) pdl_trans *x PPCODE: if (!x->vtable) barf("%p has NULL vtable", x); PDL_FLAG_DUMP(PDL_LIST_FLAGS_PDLVTABLE, x->vtable->flags) int vaffine(x) pdl_trans *x CODE: RETVAL= !!(x->flags & PDL_ITRANS_ISAFFINE); OUTPUT: RETVAL IV offs(self) pdl_trans *self; CODE: RETVAL = PTR2IV(self->offs); OUTPUT: RETVAL void incs(x) pdl_trans *x; PPCODE: if (!(x->flags & PDL_ITRANS_ISAFFINE)) barf("incs called on non-vaffine trans %p", x); PDL_Indx i, max = x->incs ? x->pdls[1]->ndims : 0; EXTEND(sp, max); for(i=0; iincs[i]); void ind_sizes(x) pdl_trans *x; PPCODE: PDL_Indx i, max = x->vtable->ninds; EXTEND(sp, max); for(i=0; iind_sizes[i]); void inc_sizes(x) pdl_trans *x; PPCODE: PDL_Indx i, max = x->vtable->nind_ids; EXTEND(sp, max); for(i=0; iinc_sizes[i]); 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 * at_bad_c(x,pos) pdl* x PDL_Indx pos_count=0; 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 { RETVAL = newSV(0); ANYVAL_TO_SV(RETVAL, result); } } else { RETVAL = newSV(0); 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 { sv = newSV(0); ANYVAL_TO_SV(sv, pdl_val); } } else { sv = newSV(0); 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_count=0; 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) */ ENTER; SAVETMPS; 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 ;) */ } FREETMPS; LEAVE; 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); if (!RETVAL) barf("convert error"); 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 PDL_Anyval sclr(it) pdl* it CODE: /* get the first element of an ndarray and return as * Perl scalar (autodetect suitable type IV or NV) */ pdl_barf_if_error(pdl_make_physdims(it)); if (it->nvals > 1) barf("multielement ndarray in 'sclr' call"); RETVAL = pdl_at0(it); if (RETVAL.type < 0) croak("Position out of range"); OUTPUT: RETVAL SV * initialize(class) SV *class 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"); PDLDEBUG_f(printf("get_dataref %p\n", self)); pdl_barf_if_error(pdl_make_physical(self)); /* XXX IS THIS MEMLEAK WITHOUT MORTAL? */ if (!self->datasv) { PDLDEBUG_f(printf("get_dataref no datasv\n")); self->datasv = newSVpvn("", 0); (void)SvGROW((SV *)self->datasv, self->nbytes); SvCUR_set((SV *)self->datasv, self->nbytes); memmove(SvPV_nolen((SV*)self->datasv), self->data, self->nbytes); } RETVAL = newRV(self->datasv); PDLDEBUG_f(printf("get_dataref end: "); pdl_dump(self)); OUTPUT: RETVAL void upd_data(self, keep_datasv=0) pdl *self IV keep_datasv CODE: if(self->state & PDL_DONTTOUCHDATA) croak("Trying to touch dataref of magical (mmaped?) pdl"); PDLDEBUG_f(printf("upd_data: "); pdl_dump(self)); if (keep_datasv || !PDL_USESTRUCTVALUE(self)) { self->data = SvPV_nolen((SV*)self->datasv); } else if (self->datasv) { PDLDEBUG_f(printf("upd_data zap datasv\n")); memmove(self->data, SvPV_nolen((SV*)self->datasv), self->nbytes); SvREFCNT_dec(self->datasv); self->datasv = NULL; } else { PDLDEBUG_f(printf("upd_data datasv gone, maybe reshaped\n")); } PDLDEBUG_f(printf("upd_data end: "); pdl_dump(self)); int badflag(x,newval=0) pdl *x int newval CODE: if (items>1) pdl_propagate_badflag( x, newval ); RETVAL = ((x->state & PDL_BADVAL) > 0); OUTPUT: RETVAL 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(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 getnbroadcastids(x) pdl *x CODE: pdl_barf_if_error(pdl_make_physdims(x)); RETVAL = x->nbroadcastids; OUTPUT: RETVAL void broadcastids(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->nbroadcastids); for(i=0; inbroadcastids; i++) mPUSHi(x->broadcastids[i]); } else if (gimme == G_SCALAR) { mXPUSHu(x->nbroadcastids); } int getbroadcastid(x,y) pdl *x int y CODE: RETVAL = x->broadcastids[y]; OUTPUT: RETVAL void setdims(x,dims) pdl *x PDL_Indx dims_count=0; 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 broadcastover_n(...) PREINIT: int npdls; SV *sv; CODE: npdls = items - 1; if(npdls <= 0) croak("Usage: broadcastover_n(pdl[,pdl...],sub)"); int i,sd; pdl *pdls[npdls]; PDL_Indx realdims[npdls]; pdl_broadcast pdl_brc; SV *code = ST(items-1); for(i=0; i 0) nothers = SvIV(ST(0)); if(targs <= 0 || nothers < 0 || nothers >= targs) croak("Usage: broadcastover(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_broadcast pdl_brc; 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"); if (nd2 < npdls) croak("broadcastover: need at least one creating flag per pdl: %d pdls, %"IND_FLAG" flags", npdls, nd2); PDL_Indx *realdims = pdl_packdims(rdimslist,&nd1); if (!realdims) croak("Failed to packdims for realdims"); if (nd1 != npdls) croak("broadcastover: need one realdim flag per pdl: %d pdls, %"IND_FLAG" flags", npdls, nd1); 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_broadcast_create_parameter(&pdl_brc,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_startbroadcastloop(&pdl_brc,NULL,NULL,&error_ret) < 0) croak("Error starting broadcastloop"); 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_brc.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 brcloopval; ENTER; SAVETMPS; do { /* the actual broadcastloop */ pdl_trans *traff; dSP; PUSHMARK(sp); EXTEND(sp,npdls); for(i=0; itrans_parent; traff->offs = pdl_brc.offs[i]; child[i]->vafftrans->offs = pdl_brc.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. 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, except that as of 2.064, the returned ndarray will default to at least type C. As of 2.085, this will respect a given type as in the second or third form below. =for usage $x = xvals($somearray); # at least type double $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 { my $type_given = grep +(ref($_[$_])||'') eq 'PDL::Type', 0..1; axisvals2(&PDL::Core::_construct,0,$type_given); } sub PDL::yvals { my $type_given = grep +(ref($_[$_])||'') eq 'PDL::Type', 0..1; axisvals2(&PDL::Core::_construct,1,$type_given); } sub PDL::zvals { my $type_given = grep +(ref($_[$_])||'') eq 'PDL::Type', 0..1; axisvals2(&PDL::Core::_construct,2,$type_given); } 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.085/Basic/Core/Dbg.pm0000644000175000017500000001124414202424257015044 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 $package .= "::" unless $package =~ /::$/; my $stab = \%main::; $stab = $stab->{$_.'::'} 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 $npdls = 0; foreach my $key ( sort { lc($a) cmp lc($b) } keys %$stab ) { my $pdl = do { no strict 'refs'; ${"$package$key"} }; next if !UNIVERSAL::isa($pdl,$classname); # print info for all objects derived from this class $npdls++; my $info = $pdl->info($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.085/Basic/Core/typemap0000644000175000017500000000154214415317170015415 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 pdl ** T_PDL_LIST 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 $var = PDL_CORE_(packdims)($arg, &${var}_count) T_PDL_LIST $var = PDL_CORE_(packpdls)($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); T_PDL_LIST if ($var) { $arg = PDL_CORE_(unpackpdls)($var, ${var}_count); free($var); } PDL-2.085/Basic/Core/pdlbroadcast.h0000644000175000017500000000522014202440313016611 0ustar osboxesosboxes#ifndef __PDLTHREAD_H #define __PDLTHREAD_H #define PDL_BROADCAST_MAGICKED 0x0001 #define PDL_BROADCAST_MAGICK_BUSY 0x0002 #define PDL_BROADCAST_INITIALIZED 0x0004 #define PDL_LIST_FLAGS_PDLBROADCAST(X) \ X(PDL_BROADCAST_MAGICKED) \ X(PDL_BROADCAST_MAGICK_BUSY) \ X(PDL_BROADCAST_INITIALIZED) #define PDL_BRC_MAGICNO 0x92314764 #define PDL_BRC_CHKMAGIC(it) PDL_CHKMAGIC_GENERAL(it, PDL_BRC_MAGICNO, "BROADCAST") #define PDL_BRC_SETMAGIC(it) (it)->magicno = PDL_BRC_MAGICNO /* XXX To avoid mallocs, these should also have "default" values */ typedef struct pdl_broadcast { struct pdl_transvtable *transvtable; unsigned int magicno; int gflags; /* Flags about this struct */ PDL_Indx ndims; /* Number of dimensions broadcasted 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_BRC_OFFSET */ } pdl_broadcast; #define PDL_BRC_OFFSET(thr, broadcast) ((thr)*((broadcast)->mag_stride) + PDLMIN((thr),(broadcast)->mag_skip)) #define PDL_BRC_INC(incs, npdls, p, d) ((incs)[(d)*(npdls) + (p)]) /* Broadcast per pdl flags */ #define PDL_BROADCAST_VAFFINE_OK 0x01 #define PDL_BROADCAST_TEMP 0x02 #define PDL_BVAFFOK(flag) (flag & PDL_BROADCAST_VAFFINE_OK) #define PDL_BISTEMP(flag) (flag & PDL_BROADCAST_TEMP) #define PDL_BREPRINC(pdl,flag,which) (PDL_BVAFFOK(flag) ? \ pdl->vafftrans->incs[which] : pdl->dimincs[which]) #define PDL_BREPROFFS(pdl,flag) (PDL_BVAFFOK(flag) ? pdl->vafftrans->offs : 0) /* __PDLTHREAD_H */ #endif PDL-2.085/Basic/Core/pdlbroadcast.c0000644000175000017500000005756314556052733016646 0ustar osboxesosboxes/* XXX NOTE THAT IT IS NOT SAFE TO USE ->pdls MEMBER OUTSIDE INITBROADCASTSTRUCT! */ #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_broadcastdims - get the pthread-specific broadcasting dims from a PDL * Input: broadcast structure * Outputs: see above (returned by function) */ PDL_Indx *pdl_get_broadcastdims(pdl_broadcast *broadcast) { /* The non-multithreaded case: return just the usual value */ if (!(broadcast->gflags & PDL_BROADCAST_MAGICKED)) return broadcast->dims; int thr = pdl_magic_get_thread(broadcast->pdls[broadcast->mag_nthpdl]); if (thr < 0) return NULL; return broadcast->dims + thr * broadcast->ndims; } /******* * pdl_get_threadoffsp - get the pthread-specific offset arrays from a PDL * Input: broadcast structure * Outputs: Pointer to pthread-specific offset array (returned by function) */ PDL_Indx *pdl_get_threadoffsp(pdl_broadcast *broadcast) { /* The non-multithreaded case: return just the usual offsets */ if (!(broadcast->gflags & PDL_BROADCAST_MAGICKED)) return broadcast->offs; int thr = pdl_magic_get_thread(broadcast->pdls[broadcast->mag_nthpdl]); if (thr < 0) return NULL; return broadcast->offs + thr * broadcast->npdls; } /* Function to get the pthread-specific offset, indexes and pthread number for the supplied broadcast structure Input: broadcast 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_broadcast *broadcast, int *pthr, PDL_Indx **inds, PDL_Indx **dims) { if(broadcast->gflags & PDL_BROADCAST_MAGICKED) { int thr = pdl_magic_get_thread(broadcast->pdls[broadcast->mag_nthpdl]); if (thr < 0) return NULL; *pthr = thr; *inds = broadcast->inds + thr * broadcast->ndims; *dims = broadcast->dims + thr * broadcast->ndims; return broadcast->offs + thr * broadcast->npdls; } *pthr = 0; /* The non-multithreaded case: return just the usual offsets */ *dims = broadcast->dims; *inds = broadcast->inds; return broadcast->offs; } void pdl_freebroadcaststruct(pdl_broadcast *broadcast) { PDLDEBUG_f(printf("freebroadcaststruct(%p, %p %p %p %p %p %p)\n", (void*)broadcast, (void*)(broadcast->inds), (void*)(broadcast->dims), (void*)(broadcast->offs), (void*)(broadcast->incs), (void*)(broadcast->flags), (void*)(broadcast->pdls))); if(!broadcast->inds) {return;} Safefree(broadcast->inds); Safefree(broadcast->dims); Safefree(broadcast->offs); Safefree(broadcast->incs); Safefree(broadcast->flags); Safefree(broadcast->pdls); pdl_clearbroadcaststruct(broadcast); } void pdl_clearbroadcaststruct(pdl_broadcast *it) { PDLDEBUG_f(printf("clearbroadcaststruct(%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_BROADCAST_INITIALIZED among others */ PDL_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 broadcasted dim numbers and sizes for each pdl */ PDL_Indx max_remainder = 0; PDL_Indx nbroadcastedDims[npdls]; PDL_Indx *broadcastedDims[npdls]; PDL_Indx *broadcastedDimSizes[npdls]; for(j=0; jndims); if (!broadcastedDims[j]) return pdl_make_error_simple(PDL_EFATAL, "Out of Memory\n"); broadcastedDimSizes[j] = (PDL_Indx*) malloc(sizeof(PDL_Indx) * pdls[j]->ndims); if (!broadcastedDimSizes[j]) return pdl_make_error_simple(PDL_EFATAL, "Out of Memory\n"); } for(j=0; jndims; t++, k++ ){ broadcastedDimSizes[j][k] = pdls[j]->dims[t]; broadcastedDims[j][k] = t; } nbroadcastedDims[j] = pdls[j]->ndims - realdims[j]; } /* Go through each broadcasted 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 = broadcastedDims[j][k]; } } /* Don't go any further if target pthread achieved */ if( *p_maxPthread == target_pthread ) break; } PDLDEBUG_f(pdl_dump_broadcasting_info( npdls, creating, target_pthread, nbroadcastedDims, broadcastedDims, broadcastedDimSizes, *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 threshold */ 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_broadcast *broadcast, PDL_Indx *creating, PDL_Indx *ind_sizes, char load_only ) { pdl_error PDL_err = {0, NULL, 0}; PDL_Indx i, j, ind_id; PDLDEBUG_f(printf("pdl_dim_checks(load_only=%d) %p:\n", load_only, ind_sizes); printf(" ind_sizes: "); pdl_print_iarr(ind_sizes, vtable->ninds);printf("\n")); for (i=0; inpdls; i++) { pdl *pdl = pdls[i]; PDL_Indx ninds = vtable->par_realdims[i], ndims = pdl->ndims; PDLDEBUG_f(printf("pdl_dim_checks pdl %"IND_FLAG" (creating=%"IND_FLAG" ninds=%"IND_FLAG"): ", i, creating ? creating[i] : -99, ninds)); PDLDEBUG_f(pdl_dump(pdl)); if (!load_only && 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_broadcast_create_parameter( broadcast,i,dims, vtable->par_flags[i] & PDL_PARAM_ISTEMP )); } else { PDL_Indx *dims = pdl->dims; if ((load_only || (creating && !creating[i])) && ninds > PDLMAX(0,ndims)) { /* Dimensional promotion when number of dims is less than required: */ for (j=0; jpar_flags[i] & PDL_PARAM_ISCREAT) && (pdl->state & PDL_MYDIMS_TRANS))) || (creating && !creating[i]) ) { if (ind_sz == -1 || (ndims > j && ind_sz == 1)) ind_sizes[ind_id] = dims[j]; else if (ndims > j && ind_sz != dims[j] && ( (i < vtable->nparents && dims[j] != 1) || (i >= vtable->nparents) )) 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_sz, dims[j] ); } } if (!load_only && (vtable->par_flags[i] & PDL_PARAM_ISPHYS)) PDL_RETERROR(PDL_err, pdl_make_physical(pdl)); } } if (!load_only) 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_sz != 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_sz, 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 trans is not pthreading safe * (i.e. don't attempt to create multiple posix threads to execute) */ pdl_error pdl_initbroadcaststruct(int nobl, pdl **pdls,PDL_Indx *realdims,PDL_Indx *creating,PDL_Indx npdls, pdl_transvtable *vtable,pdl_broadcast *broadcast, 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("initbroadcaststruct(%p)\n", (void*)broadcast)); char already_alloced = (broadcast->magicno == PDL_BRC_MAGICNO && broadcast->gflags & PDL_BROADCAST_INITIALIZED); PDL_Indx already_nthr = already_alloced ? broadcast->mag_nthr : -1; PDL_Indx already_ndims = already_alloced ? broadcast->ndims : -1; PDL_BRC_SETMAGIC(broadcast); broadcast->gflags = 0; broadcast->npdls = npdls; broadcast->realdims = realdims; broadcast->transvtable = vtable; /* Accumulate the maximum number of broadcast dims across the collection of PDLs */ nids=mx=0; for(j=0; jnbroadcastids); MAX2(mx,pdls[j]->broadcastids[0] - realdims[j]); } ndims += broadcast->nimpl = nimpl = mx; PDL_RETERROR(PDL_err, pdl_autopthreadmagic(pdls, npdls, realdims, creating, noPthreadFlag)); broadcast->mag_nth = -1; broadcast->mag_nthpdl = -1; broadcast->mag_nthr = -1; PDL_Indx nbroadcastids[nids]; for(j=0; jmagic && (nthr = pdl_magic_thread_nthreads(pdls[j],&nthrd))) { broadcast->mag_nthpdl = j; broadcast->mag_nth = nthrd - realdims[j]; broadcast->mag_nthr = nthr; if(broadcast->mag_nth < 0) { return pdl_croak_param(vtable,j,"Cannot magick non-broadcasted dims \n\t"); } } for(i=0; inbroadcastids <= nids ? pdls[j]->broadcastids[i+1] - pdls[j]->broadcastids[i] : 0); } } if(nthr) { broadcast->gflags |= PDL_BROADCAST_MAGICKED; } ndims += broadcast->nextra = PDLMAX(0, nobl - ndims); /* If too few, add enough implicit dims */ broadcast->ndims = ndims; broadcast->nimpl = nimpl; PDL_Indx nthr1 = PDLMAX(nthr, 1); if (!already_alloced || already_nthr != nthr1 || ndims != already_ndims) { if (already_alloced) { Safefree(broadcast->inds); Safefree(broadcast->dims); Safefree(broadcast->offs); } Newxz(broadcast->inds, ndims * nthr1, PDL_Indx); /* Create space for pthread-specific inds (i.e. copy for each pthread)*/ if(broadcast->inds == NULL) return pdl_make_error_simple(PDL_EFATAL, "Failed to allocate memory for broadcast->inds in pdlbroadcast.c"); Newxz(broadcast->dims, ndims * nthr1, PDL_Indx); if(broadcast->dims == NULL) return pdl_make_error_simple(PDL_EFATAL, "Failed to allocate memory for broadcast->dims in pdlbroadcast.c"); Newxz(broadcast->offs, npdls * nthr1, PDL_Indx); /* Create space for pthread-specific offs */ if(broadcast->offs == NULL) return pdl_make_error_simple(PDL_EFATAL, "Failed to allocate memory for broadcast->offs in pdlbroadcast.c"); } for(nth=0; nthdims[nth]=1; // all start size 1 if (!already_alloced) { broadcast->pdls = copy_pdl_array(pdls,npdls); Newxz(broadcast->incs, ndims * npdls, PDL_Indx); if(broadcast->incs == NULL) return pdl_make_error_simple(PDL_EFATAL, "Failed to allocate memory for broadcast->incs in pdlbroadcast.c"); Newxz(broadcast->flags, npdls, char); if(broadcast->flags == NULL) return pdl_make_error_simple(PDL_EFATAL, "Failed to allocate memory for broadcast->flags in pdlbroadcast.c"); } /* populate the per_pdl_flags */ for (i=0;iflags[i] |= PDL_BROADCAST_VAFFINE_OK; if (vtable && vtable->par_flags[i] & PDL_PARAM_ISTEMP) broadcast->flags[i] |= PDL_BROADCAST_TEMP; } flags = broadcast->flags; /* shortcut for the remainder */ /* Make implicit inds */ for(nth=0; nthbroadcastids[0]- // If we're off the end of the current PDLs dimlist, realdims[j] <= nth) // then just skip it. continue; PDL_Indx cur_pdl_dim = pdls[j]->dims[nth+realdims[j]]; if (vtable && j >= vtable->nparents && cur_pdl_dim == 1 && cur_pdl_dim != broadcast->dims[nth]) return pdl_make_error(PDL_EUSERERROR, "Error in %s: output parameter '%s' implicit dim %"IND_FLAG" size %"IND_FLAG", but dim has size %"IND_FLAG"\n", vtable->name, vtable->par_names[j], nth, broadcast->dims[nth], cur_pdl_dim ); if(cur_pdl_dim != 1) { // If the current dim in the current PDL is not 1, if(broadcast->dims[nth] != 1) { // ... and the current planned size isn't 1, if(broadcast->dims[nth] != cur_pdl_dim) { // ... then check to make sure they're the same. char buf0[BUFSIZ]; buf0[0] = '\0'; pdl_broadcast_mismatch_msg( buf0, pdls, broadcast, 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 broadcast->dims[nth] = cur_pdl_dim; } PDL_BRC_INC(broadcast->incs, npdls, j, nth) = // Update the corresponding data stride PDL_BREPRINC(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]->nbroadcastids < nthid) continue; if(pdls[j]->broadcastids[nthid+1]- pdls[j]->broadcastids[nthid] <= i) continue; mydim = i+pdls[j]->broadcastids[nthid]; if(pdls[j]->dims[mydim] != 1) { if(broadcast->dims[nth] != 1) { if(broadcast->dims[nth] != pdls[j]->dims[mydim]) { return pdl_croak_param(vtable,j,"Mismatched Implicit broadcast dimension %d: should be %d, is %d", i, broadcast->dims[nth], pdls[j]->dims[i+realdims[j]]); } } else { broadcast->dims[nth] = pdls[j]->dims[mydim]; } PDL_BRC_INC(broadcast->incs, npdls, j, nth) = PDL_BREPRINC(pdls[j],flags[j],mydim); } } nth++; } } /* If threading, make the true offsets and dims.. */ broadcast->mag_skip = 0; broadcast->mag_stride = 0; if(nthr > 0) { int n1 = broadcast->dims[broadcast->mag_nth] / nthr; int n2 = broadcast->dims[broadcast->mag_nth] % nthr; broadcast->mag_stride = n1; if(n2) { n1++; broadcast->mag_skip = n2; } broadcast->dims[broadcast->mag_nth] = n1; for(i=1; idims[j + i*ndims] = broadcast->dims[j]; if (n2) for(i=n2; idims[broadcast->mag_nth + i*ndims]--; } if (ind_sizes) PDL_RETERROR(PDL_err, pdl_dim_checks(vtable, pdls, broadcast, creating, ind_sizes, 0)); 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); } broadcast->gflags |= PDL_BROADCAST_INITIALIZED; PDLDEBUG_f(pdl_dump_broadcast(broadcast)); return PDL_err; } pdl_error pdl_broadcast_create_parameter(pdl_broadcast *broadcast, PDL_Indx j,PDL_Indx *dims, int temp) { pdl_error PDL_err = {0, NULL, 0}; PDL_Indx i; PDL_Indx td = temp ? 0 : broadcast->nimpl; if(!temp && broadcast->nimpl != broadcast->ndims - broadcast->nextra) { return pdl_croak_param(broadcast->transvtable,j, "Trying to create parameter while explicitly broadcasting.\ See the manual for why this is impossible"); } if (!broadcast->pdls[j] && !(broadcast->pdls[j] = pdl_pdlnew())) return pdl_make_error_simple(PDL_EFATAL, "Error in pdlnew"); PDL_RETERROR(PDL_err, pdl_reallocdims(broadcast->pdls[j], broadcast->realdims[j] + td + (temp ? 1 : 0))); for(i=0; irealdims[j] + (temp ? 1 : 0); i++) broadcast->pdls[j]->dims[i] = dims[i]; if (!temp) for(i=0; inimpl; i++) broadcast->pdls[j]->dims[i+broadcast->realdims[j]] = (i == broadcast->mag_nth && broadcast->mag_nthr > 0) ? PDL_BRC_OFFSET(broadcast->mag_nthr, broadcast) : broadcast->dims[i]; broadcast->pdls[j]->broadcastids[0] = td + broadcast->realdims[j]; pdl_resize_defaultincs(broadcast->pdls[j]); for(i=0; inimpl; i++) { PDL_BRC_INC(broadcast->incs, broadcast->npdls, j, i) = temp ? 0 : PDL_REPRINC(broadcast->pdls[j],i+broadcast->realdims[j]); } return PDL_err; } int pdl_startbroadcastloop(pdl_broadcast *broadcast,pdl_error (*func)(pdl_trans *), pdl_trans *t, pdl_error *error_ret) { PDL_Indx j, npdls = broadcast->npdls; PDL_Indx *offsp; int thr; PDL_Indx *inds, *dims; if( (broadcast->gflags & (PDL_BROADCAST_MAGICKED | PDL_BROADCAST_MAGICK_BUSY)) == PDL_BROADCAST_MAGICKED ) { /* If no function supplied (i.e. being called from PDL::broadcast_over), don't run in parallel */ if(!func) { broadcast->gflags &= ~PDL_BROADCAST_MAGICKED; /* Cancel thread_magicked */ } else{ broadcast->gflags |= PDL_BROADCAST_MAGICK_BUSY; /* Do the broadcastloop magically (i.e. in parallel) */ for(j=0; jvtable->par_flags[j] & PDL_PARAM_ISTEMP)) continue; pdl *it = broadcast->pdls[j]; it->dims[it->ndims-1] = broadcast->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(broadcast->pdls[broadcast->mag_nthpdl], func,t, broadcast); if (PDL_err.error) { *error_ret = PDL_err; return 1; } broadcast->gflags &= ~PDL_BROADCAST_MAGICK_BUSY; return 1; /* DON'T DO BROADCASTLOOP AGAIN */ } } offsp = pdl_get_threadoffsp_int(broadcast,&thr, &inds, &dims); if (!offsp) return -1; for(j=0; jndims; j++) if (!dims[j]) return 1; /* do nothing if empty */ for(j=0; jpdls[j],broadcast->flags[j]); } if (thr) for(j=0; jflags[j]) ? thr * broadcast->pdls[j]->dimincs[broadcast->pdls[j]->ndims-1] : PDL_BRC_OFFSET(thr, broadcast) * PDL_BRC_INC(broadcast->incs, broadcast->npdls, j, broadcast->mag_nth); return 0; } /* nth is how many dims are done inside the broadcastloop itself */ /* inds is how far along each non-broadcastloop dim we are */ int pdl_iterbroadcastloop(pdl_broadcast *broadcast,PDL_Indx nth) { PDL_Indx i,j; int another_broadcastloop = 0; PDL_Indx *offsp; int thr; PDL_Indx *inds, *dims; offsp = pdl_get_threadoffsp_int(broadcast,&thr, &inds, &dims); if (!offsp) return -1; for(i=nth; indims; i++) { inds[i] ++; if( inds[i] >= dims[i]) inds[i] = 0; else { another_broadcastloop = 1; break; } } if (another_broadcastloop) for(j=0; jnpdls; j++) { offsp[j] = PDL_BREPROFFS(broadcast->pdls[j],broadcast->flags[j]); if (thr) offsp[j] += PDL_BISTEMP(broadcast->flags[j]) ? thr * broadcast->pdls[j]->dimincs[broadcast->pdls[j]->ndims-1] : PDL_BRC_OFFSET(thr, broadcast) * PDL_BRC_INC(broadcast->incs, broadcast->npdls, j, broadcast->mag_nth); for(i=nth; indims; i++) { offsp[j] += PDL_BRC_INC(broadcast->incs, broadcast->npdls, j, i) * inds[i]; } } return another_broadcastloop; } PDL-2.085/Basic/Core/pdlconv.c0000644000175000017500000001021114224375413015617 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 to %d: ", targtype); pdl_dump(a)); 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); PDL_Value value; char diffsize = ncurr != nbytes, was_useheap = (ncurr > sizeof(value)), will_useheap = (nbytes > sizeof(value)); void *data_from_void = a->data, *data_to_void = a->data; if (diffsize) data_to_void = will_useheap ? pdl_smalloc(nbytes) : &value; #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 *data_from_typed = (ctype_from *) data_from_void; \ 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 *data_to_typed = (ctype_to *) data_to_void; \ data_to_typed += i-1; data_from_typed += i-1; \ if (a->state & PDL_BADVAL) { \ ctype_to to_badval = defbval_to; \ a->has_badvalue = 0; \ while (i--) { \ *data_to_typed-- = THIS_ISBAD(from_badval_isnan, from_badval, *data_from_typed) \ ? to_badval : (ctype_to) *data_from_typed; \ data_from_typed--; \ } \ } else \ while (i--) \ *data_to_typed-- = (ctype_to) *data_from_typed--; 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) { if (!was_useheap && !will_useheap) { memmove(&a->value, data_to_void, nbytes); } else if (!will_useheap) { /* was heap, now not */ memmove(a->data = &a->value, data_to_void, nbytes); SvREFCNT_dec((SV*)a->datasv); a->datasv = NULL; } else { /* now change to be heap */ if (a->datasv == NULL) a->datasv = newSVpvn("", 0); (void)SvGROW((SV*)a->datasv, nbytes); SvCUR_set((SV*)a->datasv, nbytes); memmove(a->data = SvPV_nolen((SV*)a->datasv), data_to_void, nbytes); } } a->datatype = targtype; PDLDEBUG_f(printf("pdl_converttype after: "); pdl_dump(a)); return PDL_err; } PDL-2.085/Basic/Core/pdlapi.c0000644000175000017500000013003414554032465015434 0ustar osboxesosboxes/* pdlapi.c - functions for manipulating pdl structs */ #include "pdl.h" /* Data structure declarations */ #include "pdlcore.h" /* Core declarations */ #define VTABLE_OR_DEFAULT(what, trans, is_fwd, func, default_func) \ do { \ PDLDEBUG_f(printf("VTOD call " #func "(%p=%s)\n", trans, trans->vtable->name)); \ what(PDL_err, ((trans)->vtable->func \ ? (trans)->vtable->func \ : pdl_ ## default_func)(trans)); \ pdl **pdls = trans->pdls; \ PDL_Indx i, istart = is_fwd ? trans->vtable->nparents : 0, iend = is_fwd ? trans->vtable->npdls : trans->vtable->nparents; \ for (i = istart; i < iend; i++) \ if (pdls[i] && (pdls[i]->state & PDL_BADVAL)) \ pdl_propagate_badflag(pdls[i], !!(pdls[i]->state & PDL_BADVAL)); \ } while (0) #define REDODIMS(what, trans) do { \ if ((trans)->vtable->redodims) \ what(PDL_err, pdl_dim_checks( \ (trans)->vtable, (trans)->pdls, \ NULL, NULL, \ (trans)->ind_sizes, 1)); \ if (trans->dims_redone) { \ FREETRANS(trans, 0); \ if (PDL_err.error) return PDL_err; \ trans->dims_redone = 0; \ } \ what(PDL_err, ((trans)->vtable->redodims \ ? (trans)->vtable->redodims \ : pdl_redodims_default)(trans)); \ } while (0) #define READDATA(trans) VTABLE_OR_DEFAULT(PDL_ACCUMERROR, trans, 1, readdata, readdata_affine) #define WRITEDATA(trans) VTABLE_OR_DEFAULT(PDL_ACCUMERROR, trans, 0, writebackdata, writebackdata_affine) #define FREETRANS(trans, destroy) \ if(trans->vtable->freetrans) { \ PDLDEBUG_f(printf("call freetrans\n")); \ PDL_ACCUMERROR(PDL_err, trans->vtable->freetrans(trans, destroy)); \ /* ignore error for now as need to still free rest */ \ if (destroy) PDL_CLRMAGIC(trans); \ } #define CHANGED(...) \ PDL_ACCUMERROR(PDL_err, pdl_changed(__VA_ARGS__)) extern Core PDL; pdl_error pdl__make_physvaffine_recprotect(pdl *it, int recurse_count); /* Make sure transformation is done */ pdl_error pdl__ensure_trans(pdl_trans *trans,int what,int *wd, int recurse_count) { pdl_error PDL_err = {0, NULL, 0}; PDLDEBUG_f(printf("pdl__ensure_trans %p what=", trans); pdl_dump_flags_fixspace(what, 0, PDL_FLAGS_PDL)); PDL_TR_CHKMAGIC(trans); PDL_Indx j, flag=what, par_pvaf=0; pdl_transvtable *vtable = trans->vtable; /* Make parents physical */ for(j=0; jnpdls; j++) { if(VAFFINE_FLAG_OK(vtable->per_pdl_flags,j)) par_pvaf++; PDL_RETERROR(PDL_err, pdl__make_physvaffine_recprotect(trans->pdls[j], recurse_count+1)); } for(j=vtable->nparents; jnpdls; j++) flag |= trans->pdls[j]->state & PDL_ANYCHANGED; PDLDEBUG_f(printf("pdl__ensure_trans after accum, par_pvaf=%"IND_FLAG" flag=", par_pvaf); pdl_dump_flags_fixspace(what, 0, PDL_FLAGS_PDL)); if (flag & PDL_PARENTDIMSCHANGED) REDODIMS(PDL_RETERROR, trans); for(j=vtable->nparents; 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 */ PDLDEBUG_f(printf("pdl__ensure_trans vaffine output turning off dimschanged, before="); pdl_dump_flags_fixspace(trans->pdls[1]->state, 0, PDL_FLAGS_PDL)); trans->pdls[1]->state &= ~PDL_PARENTDIMSCHANGED; PDL_RETERROR(PDL_err, pdl__make_physvaffine_recprotect(trans->pdls[1], recurse_count+1)); PDL_ACCUMERROR(PDL_err, pdl_readdata_vaffine(trans->pdls[1])); } else READDATA(trans); } for(j=vtable->nparents; jnpdls; j++) { pdl *child = trans->pdls[j]; PDLDEBUG_f(printf("pdl__ensure_trans child=%p turning off all changed, before=", child); pdl_dump_flags_fixspace(child->state, 0, PDL_FLAGS_PDL)); child->state &= ~PDL_ANYCHANGED; if (!wd) continue; PDLDEBUG_f(printf(" pdl__ensure_trans wd="); pdl_dump_flags_fixspace(wd[j], 0, PDL_FLAGS_PDL)); char isvaffine = (PDL_VAFFOK(child) && VAFFINE_FLAG_OK(vtable->per_pdl_flags,j)); if (!isvaffine || (wd[j] & PDL_PARENTDIMSCHANGED)) CHANGED(child,wd[j],0); if (isvaffine) CHANGED(child->vafftrans->from,PDL_PARENTDATACHANGED,0); } return PDL_err; } pdl *pdl_null() { PDLDEBUG_f(printf("pdl_null\n")); return pdl_pdlnew(); } 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; it->datatype = anyval.type; it->broadcastids[0] = it->ndims = 0; /* 0 dims in a scalar */ pdl_resize_defaultincs(it); pdl_error PDL_err = pdl_allocdata(it); if (PDL_err.error) { pdl_destroy(it); return NULL; } it->value = anyval.value; it->state &= ~(PDL_NOMYDIMS); /* has dims */ 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_pdlnew(); 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)); if(it->nvals < 0) return pdl_make_error(PDL_EUSERERROR, "Tried to allocdata with %"IND_FLAG" values", it->nvals); 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"); char was_useheap = (ncurr > sizeof(it->value)), will_useheap = (nbytes > sizeof(it->value)); if (!was_useheap && !will_useheap) { it->data = &it->value; } else if (!will_useheap) { /* was heap, now not */ void *data_old = it->data; memmove(it->data = &it->value, data_old, PDLMIN(ncurr, nbytes)); SvREFCNT_dec((SV*)it->datasv); it->datasv = NULL; } else { /* now change to be heap */ if (it->datasv == NULL) it->datasv = newSVpvn("", 0); (void)SvGROW((SV*)it->datasv, nbytes); SvCUR_set((SV*)it->datasv, nbytes); if (it->data && !was_useheap) memmove(SvPV_nolen((SV*)it->datasv), it->data, PDLMIN(ncurr, nbytes)); it->data = SvPV_nolen((SV*)it->datasv); } 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->nbroadcastids = 1; it->broadcastids = it->def_broadcastids; it->broadcastids[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->broadcastids != it->def_broadcastids) free((void*)it->broadcastids); 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) { PDLDEBUG_f(printf("SvREFCNT_dec datasv=%p\n",it->datasv);) SvREFCNT_dec(it->datasv); it->data=0; } else if(it->data && it->data != &it->value) { pdl_pdl_warn("Warning: special data without datasv is not freed currently!!"); } if(it->hdrsv) { PDLDEBUG_f(printf("SvREFCNT_dec hdrsv=%p\n",it->hdrsv);) SvREFCNT_dec(it->hdrsv); it->hdrsv = 0; } free(it); PDLDEBUG_f(printf("pdl__free end %p\n",(void*)it)); return PDL_err; } /* NULL out the pdl from the trans's inputs, and the trans from the pdl's trans_children */ void pdl__removetrans_children(pdl *it,pdl_trans *trans) { PDLDEBUG_f(printf("pdl__removetrans_children(%s=%p): %p\n", trans->vtable->name, trans, 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 %p, trans %p\n",it, trans); } /* NULL out the trans's nth pdl in/output, and this trans as pdl's trans_parent */ void pdl__removetrans_parent(pdl *it, pdl_trans *trans, PDL_Indx nth) { PDLDEBUG_f(printf("pdl__removetrans_parent from %p (%s=%p): %"IND_FLAG"\n", it, trans->vtable->name, trans, nth)); trans->pdls[nth] = 0; if (it->trans_parent != trans) return; /* only do rest if trans is parent */ it->trans_parent = 0; it->state &= ~PDL_MYDIMS_TRANS; } pdl_error pdl_trans_finaldestroy(pdl_trans *trans) { pdl_error PDL_err = {0, NULL, 0}; PDLDEBUG_f(printf("pdl_trans_finaldestroy %p\n", trans)); FREETRANS(trans, 1); if(trans->vtable->flags & PDL_TRANS_DO_BROADCAST) pdl_freebroadcaststruct(&trans->broadcast); 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); return PDL_err; } pdl_error pdl__destroy_recprotect(pdl *it, int recurse_count); pdl_error pdl_destroytransform(pdl_trans *trans,int ensure,int *wd, int recurse_count) { 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]) return pdl_make_error(PDL_EFATAL, "NULL pdls[%td] in %s", j, trans->vtable->name); else 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->name, (void*)trans,ensure,ismutual)); if(ensure) PDL_ACCUMERROR(PDL_err, pdl__ensure_trans(trans,ismutual ? 0 : PDL_PARENTDIMSCHANGED,wd, recurse_count+1)); pdl *destbuffer[trans->vtable->npdls]; int ndest = 0; for(j=0; jvtable->nparents; j++) { pdl *parent = trans->pdls[j]; if(!parent) continue; PDL_CHKMAGIC(parent); pdl__removetrans_children(parent,trans); if (!(parent->state & PDL_DESTROYING) && !parent->sv) { parent->state |= PDL_DESTROYING; /* so no mark twice */ destbuffer[ndest++] = parent; } } for(j=trans->vtable->nparents; jvtable->npdls; j++) { pdl *child = trans->pdls[j]; PDL_CHKMAGIC(child); pdl__removetrans_parent(child,trans,j); if (ismutual && child->vafftrans) pdl_vafftrans_remove(child); if ((!(child->state & PDL_DESTROYING) && !child->sv) || (trans->vtable->par_flags[j] & PDL_PARAM_ISTEMP)) { child->state |= PDL_DESTROYING; /* so no mark twice */ destbuffer[ndest++] = child; } } PDL_ACCUMERROR(PDL_err, pdl_trans_finaldestroy(trans)); for(j=0; jstate &= ~PDL_DESTROYING; /* safe, set by us */ PDL_ACCUMERROR(PDL_err, pdl__destroy_recprotect(destbuffer[j], recurse_count+1)); } PDLDEBUG_f(printf("pdl_destroytransform leaving %p\n", (void*)trans)); return PDL_err; } /* A ndarray may be - a parent of something - just ensure & destroy - a child of something - just ensure & destroy - parent of two pdls which both propagate backwards - mustn't destroy. - both parent and child at same time, to something that propagates. Therefore, simple rules: - allowed to destroy if 1. a parent with max. 1 backwards propagating transformation 2. a child with no trans_children When an ndarray is destroyed, it must tell its trans_children and/or parent. */ pdl_error pdl__destroy_recprotect(pdl *it, int recurse_count) { pdl_error PDL_err = {0, NULL, 0}; int nback=0,nback2=0,nforw=0; int nafn=0; PDL_DECL_CHILDLOOP(it); PDL_CHKMAGIC(it); PDLDEBUG_f(printf("pdl_destroy: ");pdl_dump(it)); if(it->state & 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) { mg_free((SV *)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, recurse_count+1)); 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, recurse_count+1)); /* 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=%s), nafn(%d)\n", it, nback, nback2, nforw, it->trans_parent, it->trans_parent?it->trans_parent->vtable->name:"", nafn)); it->state &= ~PDL_DESTROYING; return PDL_err; } pdl_error pdl_destroy(pdl *it) { return pdl__destroy_recprotect(it, 0); } /* Straight copy, no dataflow */ pdl *pdl_hard_copy(pdl *src) { PDLDEBUG_f(printf("pdl_hard_copy (src=%p): ", src)); pdl_error PDL_err = pdl_make_physical(src); /* Wasteful XXX... should be lazier */ if (PDL_err.error) return NULL; int i; pdl *it = pdl_pdlnew(); if (!it) return it; it->state = 0; PDLDEBUG_f(printf("pdl_hard_copy (src=%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_reallocbroadcastids(it,src->nbroadcastids); if (PDL_err.error) { pdl_destroy(it); return NULL; } for(i=0; inbroadcastids; i++) { it->broadcastids[i] = src->broadcastids[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 broadcastids. Set the new extra ones to the end */ pdl_error pdl_reallocbroadcastids(pdl *it, PDL_Indx n) { pdl_error PDL_err = {0, NULL, 0}; PDL_Indx i; PDL_Indx *olds; PDL_Indx nold; if(n <= it->nbroadcastids) { it->nbroadcastids = n; it->broadcastids[n-1] = it->ndims; return PDL_err; } nold = it->nbroadcastids; olds = it->broadcastids; if(n > PDL_NBROADCASTIDS) { it->broadcastids = malloc(sizeof(*(it->broadcastids))*n); if (!it->broadcastids) return pdl_make_error_simple(PDL_EFATAL, "Out of Memory\n"); } else { it->broadcastids = it->def_broadcastids; } it->nbroadcastids = n; if(it->broadcastids != olds) { for(i=0; ibroadcastids[i] = olds[i]; } if(olds != it->def_broadcastids) { free(olds); } for(i=nold; inbroadcastids; i++) { it->broadcastids[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_reallocbroadcastids(it,1)); it->broadcastids[0] = ndims; it->state &= ~PDL_NOMYDIMS; 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_reallocbroadcastids(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 add to %p trans=%s\n", it, trans->vtable?trans->vtable->name:"")); 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}; if (!it) return pdl_make_error_simple(PDL_EFATAL, "make_physdims called with NULL"); PDL_Indx i; int c = (it->state & PDL_PARENTDIMSCHANGED); PDLDEBUG_f(printf("make_physdims %p (dimschanged=%X)\n",(void*)it, c)); PDL_CHKMAGIC(it); if(!c) { PDLDEBUG_f(printf("make_physdims exit (NOP) %p\n",(void*)it)); return PDL_err; } PDLDEBUG_f(printf("make_physdims turning off dimschanged, before="); pdl_dump_flags_fixspace(it->state, 0, PDL_FLAGS_PDL)); it->state &= ~PDL_PARENTDIMSCHANGED; pdl_trans *trans = it->trans_parent; PDLDEBUG_f(printf("make_physdims %p TRANS:\n",it); pdl_dump_trans_fixspace(trans,3)); for(i=0; ivtable->nparents; i++) { PDL_RETERROR(PDL_err, pdl_make_physdims(trans->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", trans,it)); REDODIMS(PDL_RETERROR, trans); /* why this one? will the old allocated data be freed correctly? */ if((c & PDL_PARENTDIMSCHANGED) && (it->state & PDL_ALLOCATED)) { PDLDEBUG_f(printf("make_physdims turning off allocated, before="); pdl_dump_flags_fixspace(it->state, 0, PDL_FLAGS_PDL)); it->state &= ~PDL_ALLOCATED; } PDLDEBUG_f(printf("make_physdims exit %p\n",(void*)it)); return PDL_err; } static inline pdl_error pdl_trans_flow_null_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++) { int state = trans->pdls[i]->state; if (state & PDL_NOMYDIMS) return pdl_make_error(PDL_EUSERERROR, "Error in %s: input parameter '%s' is null", vtable->name, vtable->par_names[i] ); if(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 **pdls = trans->pdls; PDL_Indx i, npdls=vtable->npdls, nparents=vtable->nparents; PDL_Indx nchildren = npdls - nparents; /* copy the converted outputs from the end-area to use as actual outputs - cf type_coerce */ for (i=vtable->nparents; inpdls; i++) pdls[i] = pdls[i+nchildren]; PDL_TR_CHKMAGIC(trans); int pfflag=0; PDL_err = pdl_trans_flow_null_checks(trans, &pfflag); if (PDL_err.error) { PDL_ACCUMERROR(PDL_err, pdl_trans_finaldestroy(trans)); return PDL_err; } char dataflow = !!(pfflag || (trans->flags & PDL_ITRANS_DO_DATAFLOW_ANY)); PDLDEBUG_f(printf("make_trans_mutual dataflow=%d\n", (int)dataflow)); for(i=0; istate & PDL_DATAFLOW_F) trans->flags |= PDL_ITRANS_DO_DATAFLOW_F; } int wd[npdls]; for(i=nparents; istate & PDL_NOMYDIMS); wd[i]=(isnull ? PDL_PARENTDIMSCHANGED : PDL_PARENTDATACHANGED); PDLDEBUG_f(printf("make_trans_mutual wd[%"IND_FLAG"]=", i); pdl_dump_flags_fixspace(wd[i], 0, PDL_FLAGS_PDL)); if (dataflow) { /* This is because for "+=" (a = a + b) we must check for previous parent transformations and mutate if they exist if no dataflow. */ PDLDEBUG_f(printf("make_trans_mutual turning on allchanged, before="); pdl_dump_flags_fixspace(child->state, 0, PDL_FLAGS_PDL)); 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_ACCUMERROR(PDL_err, pdl_destroytransform(trans,1,wd,0)); 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]); } if (vtable->flags & PDL_TRANS_DO_BROADCAST) PDL_RETERROR(PDL_err, pdl_initbroadcaststruct(2, pdls, vtable->par_realdims, creating, vtable->npdls, vtable, &trans->broadcast, 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_recprotect(pdl *it, int recurse_count) { pdl_error PDL_err = {0, NULL, 0}; int i, vaffinepar=0; if(recurse_count > 1000) 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"); PDLDEBUG_f(printf("make_physical %p\n",(void*)it)); PDL_CHKMAGIC(it); 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) { return pdl_make_error_simple(PDL_EFATAL, "PDL Not physical but doesn't have parent"); } if((it->trans_parent->flags & PDL_ITRANS_ISAFFINE) && !PDL_VAFFOK(it)) PDL_RETERROR(PDL_err, pdl__make_physvaffine_recprotect(it, recurse_count+1)); if(PDL_VAFFOK(it)) { PDLDEBUG_f(printf("make_physical: VAFFOK\n")); PDL_RETERROR(PDL_err, pdl_readdata_vaffine(it)); PDLDEBUG_f(printf("make_physical turning off anychanged, before="); pdl_dump_flags_fixspace(it->state, 0, PDL_FLAGS_PDL)); 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_recprotect(it->trans_parent->pdls[i], recurse_count+1)); /* 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_recprotect(it->trans_parent->pdls[i], recurse_count+1)); } /* XXX The real question is: why do we need another call to * redodims if !(it->state & PDL_ALLOCATED)?????? */ PDLDEBUG_f(printf("make_physical vaffinepar=%d, state=", vaffinepar); pdl_dump_flags_fixspace(it->state, 0, PDL_FLAGS_PDL)); if((!(it->state & PDL_ALLOCATED) && vaffinepar) || it->state & PDL_PARENTDIMSCHANGED) REDODIMS(PDL_RETERROR, it->trans_parent); if(!(it->state & PDL_ALLOCATED)) { PDL_RETERROR(PDL_err, pdl_allocdata(it)); } READDATA(it->trans_parent); PDLDEBUG_f(printf("make_physical turning off anychanged and OPTs, before="); pdl_dump_flags_fixspace(it->state, 0, PDL_FLAGS_PDL)); it->state &= ~(PDL_ANYCHANGED | PDL_OPT_ANY_OK); mkphys_end: PDLDEBUG_f(printf("make_physical exit %p\n",(void*)it)); return PDL_err; } pdl_error pdl_make_physical(pdl *it) { return pdl__make_physical_recprotect(it, 0); } 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) { PDLDEBUG_f(printf("pdl_changed: adding what to state, currently="); pdl_dump_flags_fixspace(it->state,0,PDL_FLAGS_PDL)); 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_ACCUMERROR(PDL_err, pdl_writebackdata_vaffine(it)); 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]; 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++) if (trans->pdls[j] != it && (trans->pdls[j]->state & what) != what) 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_recprotect(pdl *it, int recurse_count) { 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 || !(it->trans_parent->flags & PDL_ITRANS_ISAFFINE)) { PDL_RETERROR(PDL_err, pdl__make_physical_recprotect(it, recurse_count+1)); 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_recprotect(current, recurse_count+1)); mkphys_vaff_end: PDLDEBUG_f(printf("make_physvaffine exit %p\n",(void*)it)); return PDL_err; } pdl_error pdl_make_physvaffine(pdl *it) { return pdl__make_physvaffine_recprotect(it, 0); } 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,0)); 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,0)); return PDL_err; } #define PDL_MAYBE_PROPAGATE_BADFLAG(t, newval) \ for( i = 0; i < (t)->vtable->npdls; i++ ) { \ pdl *tpdl = (t)->pdls[i]; \ /* make sure we propagate if changed */ \ if (!!newval != !!(tpdl->state & PDL_BADVAL)) \ pdl_propagate_badflag( tpdl, newval ); \ } /* newval = 1 means set flag, 0 means clear it */ void pdl_propagate_badflag( pdl *it, int newval ) { PDLDEBUG_f(printf("pdl_propagate_badflag pdl=%p newval=%d\n", it, newval)); PDL_Indx i; if (newval) it->state |= PDL_BADVAL; else it->state &= ~PDL_BADVAL; if (it->trans_parent) PDL_MAYBE_PROPAGATE_BADFLAG(it->trans_parent, newval) PDL_DECL_CHILDLOOP(it) PDL_START_CHILDLOOP(it) pdl_trans *trans = PDL_CHILDLOOP_THISCHILD(it); trans->bvalflag = !!newval; PDL_MAYBE_PROPAGATE_BADFLAG(trans, newval) PDL_END_CHILDLOOP(it) } void pdl_propagate_badvalue( pdl *it ) { PDL_DECL_CHILDLOOP(it) PDL_START_CHILDLOOP(it) pdl_trans *trans = PDL_CHILDLOOP_THISCHILD(it); PDL_Indx 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 + (vtable->npdls - vtable->nparents) /* outputs twice */ ); 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_CLRMAGIC(&it->broadcast); it->broadcast.inds = 0; it->broadcast.gflags = 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 p2child_has_badvalue = (vtable->npdls == 2 && pdls[0]->has_badvalue && (vtable->par_flags[1] & PDL_PARAM_ISCREATEALWAYS)); PDL_Anyval parent_badvalue = p2child_has_badvalue ? pdls[0]->badvalue : (PDL_Anyval){PDL_INVALID, {0}}; PDL_Indx nchildren = vtable->npdls - vtable->nparents; /* copy the "real" (passed-in) outputs to the end-area to use as actual outputs, possibly after being converted, leaving the passed-in ones alone to be picked up for use in CopyBadStatusCode */ for (i=vtable->nparents; inpdls; i++) pdls[i+nchildren] = pdls[i]; 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 = p2child_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"); /* if type-convert output, put in end-area */ pdls[i + (i >= vtable->nparents ? nchildren : 0)] = 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]); } if (vtable->flags & PDL_TRANS_OUTPUT_OTHERPAR) for (i = 0; i < vtable->npdls; i++) if (!(trans->pdls[i]->state & PDL_NOMYDIMS) && trans->pdls[i]->ndims > vtable->par_realdims[i]) return pdl_make_error(PDL_EUSERERROR, "Can't broadcast with output OtherPars but par '%s' has %"IND_FLAG" dims, > %"IND_FLAG"!", vtable->par_names[i], trans->pdls[i]->ndims, vtable->par_realdims[i] ); return PDL_err; } PDL-2.085/Basic/Core/Types.pm.PL0000644000175000017500000006076614415347333016010 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 each real and complex version # 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 sprintf qq{#line %d "%s"\n}, __LINE__ + 2, 'Basic/Core/Types.pm.PL'; 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 sprintf qq{#line %d "%s"\n}, __LINE__ + 2, 'Basic/Core/Types.pm.PL'; 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 sprintf qq{#line %d "%s"\n}, __LINE__ + 2, 'Basic/Core/Types.pm.PL'; 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 as shown in the synopsis. 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_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 =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 A B S U L K N P Q F D E =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 H =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 A B S U L K N P Q F D E G C H =cut my @PPDEFS_ALL = map $_->{ppsym}, @HASHES; sub ppdefs_all { @PPDEFS_ALL } 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}; } 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 TYPES OVERVIEW As of 2.065, PDL supports these types: =over =item SByte Signed 8-bit value. =item Byte Unsigned 8-bit value. =item Short Signed 16-bit value. =item UShort Unsigned 16-bit value. =item Long Signed 32-bit value. =item ULong Unsigned 32-bit value. =item Indx Signed value, same size as a pointer on the system in use. =item ULongLong Unsigned 64-bit value. =item LongLong Signed 64-bit value. =item Float L single-precision real floating-point value. =item Double IEEE 754 double-precision real value. =item LDouble A C99 "long double", defined as "at least as precise as a double", but often more precise. =item CFloat A C99 complex single-precision floating-point value. =item CDouble A C99 complex double-precision floating-point value. =item CLDouble A C99 complex "long double" - see above for description. =back =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_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', or 'PDL_CLD'. =item ctype Returns the macro used to represent this type in C code (eg 'PDL_Long'). =item convertfunc Synonym for C. =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); =item real Returns whether the type is real-only (true) or can hold complex values (false). die "Real data only!" if !$pdl->type->real; =item unsigned Returns whether the type can hold signed values (false) or not (true). =item integer Returns whether the type can hold non-integer, a.k.a. floating-point, values (false) or not (true). =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 sprintf qq{#line %d "%s"\n}, __LINE__ + 2, 'Basic/Core/Types.pm.PL'; print OUT <<'!NO!SUBS!'; sub badvalue { PDL::Bad::_badvalue_int( $_[1], $_[0][0] ); } sub orig_badvalue { PDL::Bad::_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 DEVELOPER NOTES ON 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 uppercase 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 - see L. =item * pdlctype I. The Ced 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.085/Basic/Core/Exporter.pm0000644000175000017500000000405514202424257016162 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.085/Basic/Core/pdlmagic.c0000644000175000017500000003662714415317170015753 0ustar osboxesosboxes#include "pdlcore.h" /* Variable storing 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; ENTER; SAVETMPS; PUSHMARK(sp); perl_call_sv(magp->sv, G_DISCARD | G_NOARGS); FREETMPS; LEAVE; 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_broadcast *broadcast) { 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, broadcast->mag_nth, broadcast->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[broadcast->mag_nthr]; ptarg tparg[broadcast->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 if (add_newline) extralen += 1; extralen += 1; /* +1 for '\0' at end */ *p = realloc(*p, *len + extralen); vsnprintf(*p + *len, extralen, pat, *args); *len += extralen; /* update the length-so-far, includes '\0' */ if (add_newline) (*p)[*len-2] = '\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_broadcast *broadcast) {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.085/Basic/Core/Dev.pm0000644000175000017500000004073014552766312015101 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 */ 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)); SV* CoreSV = perl_get_sv("PDL::SHARE",FALSE); /* var with core structure */ if (!CoreSV) 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 = $internal ? '$(PERLRUNINST)' : "\$(PERL) \"-I$w\""; my ($pmdep, $install, $cdep) = ($src, '', ''); my @cbase = $multi_c ? map "pp-$_", _pp_list_functions($src, $internal) : (); my @objs = map "$_\$(OBJ_EXT)", $pref, @cbase; 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 ' ', @objs, ':', map File::Spec::Functions::catfile($core, $_), qw(pdl.h pdlcore.h pdlbroadcast.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", map "$_.c", @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) $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 # - it relies on finding "=head1 NAME" and the module name in *.pd, though can be in comment # 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, '', 0); # 0 so guarantee not create pp-*.c 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: $!"; unlink $basefile; # Transform::Proj4.pm is wrong without GIS::Proj built unlink "$basename.xs"; # since may have been recreated wrong 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 = ExtUtils::MakeMaker->new({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 }, set_dataflow_f => { FLAG => "DATAFLOW_F", noret => 1 }, fflows => { FLAG => "DATAFLOW_F" }, bflows => { FLAG => "DATAFLOW_B" }, is_inplace => { FLAG => "INPLACE", postset => 1 }, set_inplace => { FLAG => "INPLACE", noret => 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 $ref = $flags{$name}; my $with_mode = grep $ref->{$_}, qw(set postset noret); my $mode_dflt = (grep $ref->{$_}, qw(set postset)) ? "=0" : ""; my @mode = $with_mode ? (",mode$mode_dflt", "\n int mode") : ('', ''); printf <<'EOF', $ref->{noret} ? 'void' : 'int', $name, @mode; %s %s(x%s) pdl *x%s CODE: EOF my $cond = $ref->{noret} ? "" : "if (items>1) "; my $set = " ${cond}setflag(x->state,$flag,mode);\n"; my $ret = " RETVAL = ((x->state & $flag) > 0);\n"; print $set if $ref->{set} || $ref->{noret}; print $ret if !$ref->{noret}; print $set if $ref->{postset}; print " OUTPUT:\n RETVAL\n" if !$ref->{noret}; print "\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.085/Basic/Core/pdlmagic.h0000644000175000017500000000711114202424257015741 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_broadcast *broadcast); 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.085/Basic/Core/pdlsimple.h.PL0000644000175000017500000000513314202424257016466 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.085/Basic/Core/ppport.h0000644000175000017500000042156614547543564015542 0ustar osboxesosboxes#if 0 my $void = <<'SKIP'; #endif /* ---------------------------------------------------------------------- ppport.h -- Perl/Pollution/Portability Version 3.71 Automatically created by Devel::PPPort running under perl 5.038000. Version 3.x, Copyright (c) 2004-2013, 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. ---------------------------------------------------------------------- SKIP if (@ARGV && $ARGV[0] eq '--unstrip') { eval { require Devel::PPPort }; $@ and die "Cannot require Devel::PPPort, please install.\n"; if (eval $Devel::PPPort::VERSION < 3.71) { die "ppport.h was originally generated with Devel::PPPort 3.71.\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 < #endif #if ! defined(PERL_VERSION) \ && ! defined(PERL_VERSION_MAJOR) \ && ( ! defined(SUBVERSION) || ! defined(PATCHLEVEL) ) #include #endif #endif #ifdef PERL_VERSION_MAJOR #define D_PPP_MAJOR PERL_VERSION_MAJOR #elif defined(PERL_REVISION) #define D_PPP_MAJOR PERL_REVISION #else #define D_PPP_MAJOR 5 #endif #ifdef PERL_VERSION_MINOR #define D_PPP_MINOR PERL_VERSION_MINOR #elif defined(PERL_VERSION) #define D_PPP_MINOR PERL_VERSION #elif defined(PATCHLEVEL) #define D_PPP_MINOR PATCHLEVEL #define PERL_VERSION PATCHLEVEL #else #error Could not find a source for PERL_VERSION_MINOR #endif #ifdef PERL_VERSION_PATCH #define D_PPP_PATCH PERL_VERSION_PATCH #elif defined(PERL_SUBVERSION) #define D_PPP_PATCH PERL_SUBVERSION #elif defined(SUBVERSION) #define D_PPP_PATCH SUBVERSION #define PERL_SUBVERSION SUBVERSION #else #error Could not find a source for PERL_VERSION_PATCH #endif #if D_PPP_MAJOR < 5 || D_PPP_MAJOR == 6 #error Devel::PPPort works only on Perl 5, Perl 7, ... #elif D_PPP_MAJOR != 5 #undef PERL_REVISION #undef PERL_VERSION #undef PERL_SUBVERSION #define D_PPP_REVISION 5 #define D_PPP_VERSION 201 #define D_PPP_SUBVERSION 201 #if (defined(__clang__) \ && ( (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) \ || defined(_STDC_C99) \ || defined(__c99))) #define D_PPP_STRINGIFY(x) #x #define D_PPP_deprecate(xyz) _Pragma(D_PPP_STRINGIFY(GCC warning(D_PPP_STRINGIFY(xyz) " is deprecated"))) #define PERL_REVISION (D_PPP_REVISION D_PPP_deprecate(PERL_REVISION)) #define PERL_VERSION (D_PPP_REVISION D_PPP_deprecate(PERL_VERSION)) #define PERL_SUBVERSION (D_PPP_SUBVERSION D_PPP_deprecate(PERL_SUBVERSION)) #else #define PERL_REVISION D_PPP_REVISION #define PERL_VERSION D_PPP_REVISION #define PERL_SUBVERSION D_PPP_SUBVERSION #endif #endif #define D_PPP_DEC2BCD(dec) ((((dec)/100)<<8)|((((dec)%100)/10)<<4)|((dec)%10)) #define D_PPP_JNP_TO_BCD(j,n,p) ((D_PPP_DEC2BCD(j)<<24)|(D_PPP_DEC2BCD(n)<<12)|D_PPP_DEC2BCD(p)) #define PERL_BCDVERSION D_PPP_JNP_TO_BCD(D_PPP_MAJOR, \ D_PPP_MINOR, \ D_PPP_PATCH) #undef PERL_VERSION_EQ #undef PERL_VERSION_NE #undef PERL_VERSION_LT #undef PERL_VERSION_GE #undef PERL_VERSION_LE #undef PERL_VERSION_GT #ifndef PERL_VERSION_EQ #define PERL_VERSION_EQ(j,n,p) \ (((p) == '*') ? ( (j) == D_PPP_VERSION_MAJOR \ && (n) == D_PPP_VERSION_MINOR) \ : (PERL_BCDVERSION == D_PPP_JNP_TO_BCD(j,n,p))) #endif #ifndef PERL_VERSION_NE #define PERL_VERSION_NE(j,n,p) (! PERL_VERSION_EQ(j,n,p)) #endif #ifndef PERL_VERSION_LT #define PERL_VERSION_LT(j,n,p) \ (PERL_BCDVERSION < D_PPP_JNP_TO_BCD( (j), \ (n), \ (((p) == '*') ? 0 : (p)))) #endif #ifndef PERL_VERSION_GE #define PERL_VERSION_GE(j,n,p) (! PERL_VERSION_LT(j,n,p)) #endif #ifndef PERL_VERSION_LE #define PERL_VERSION_LE(j,n,p) \ (PERL_BCDVERSION < D_PPP_JNP_TO_BCD( (j), \ (((p) == '*') ? ((n)+1) : (n)), \ (((p) == '*') ? 0 : (p)))) #endif #ifndef PERL_VERSION_GT #define PERL_VERSION_GT(j,n,p) (! PERL_VERSION_LE(j,n,p)) #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 #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 #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 #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 #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 LONGSIZE #define LONGSIZE 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 LONGSIZE #define LONGSIZE 4 #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 #endif #endif #ifndef UVTYPE #define UVTYPE unsigned IVTYPE #endif #ifndef UVSIZE #define UVSIZE IVSIZE #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 #if (PERL_BCDVERSION <= 0x5005005) #define PL_ppaddr ppaddr #define PL_no_modify no_modify #endif #if (PERL_BCDVERSION <= 0x5004005) #define PL_DBsignal DBsignal #define PL_DBsingle DBsingle #define PL_DBsub DBsub #define PL_DBtrace DBtrace #define PL_Sv Sv #define PL_Xpv Xpv #define PL_bufend bufend #define PL_bufptr bufptr #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_error_count error_count #define PL_expect expect #define PL_hexdigit hexdigit #define PL_hints hints #define PL_in_my in_my #define PL_laststatval laststatval #define PL_lex_state lex_state #define PL_lex_stuff lex_stuff #define PL_linestr linestr #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 #define PL_tokenbuf tokenbuf #define PL_mess_sv mess_sv #endif #if (PERL_BCDVERSION >= 0x5009005) #ifdef DPPP_PL_parser_NO_DUMMY #define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ (croak("panic: PL_parser == NULL in %s:%d", \ __FILE__, __LINE__), (yy_parser *) NULL))->var) #else #ifdef DPPP_PL_parser_NO_DUMMY_WARNING #define D_PPP_parser_dummy_warning(var) #else #define D_PPP_parser_dummy_warning(var) \ warn("warning: dummy PL_" #var " used in %s:%d", __FILE__, __LINE__), #endif #define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ (D_PPP_parser_dummy_warning(var) &DPPP_(dummy_PL_parser)))->var) #if defined(NEED_PL_parser) static yy_parser DPPP_(dummy_PL_parser); #elif defined(NEED_PL_parser_GLOBAL) yy_parser DPPP_(dummy_PL_parser); #else extern yy_parser DPPP_(dummy_PL_parser); #endif #endif #define PL_expect D_PPP_my_PL_parser_var(expect) #define PL_copline D_PPP_my_PL_parser_var(copline) #define PL_rsfp D_PPP_my_PL_parser_var(rsfp) #define PL_rsfp_filters D_PPP_my_PL_parser_var(rsfp_filters) #define PL_linestr D_PPP_my_PL_parser_var(linestr) #define PL_bufptr D_PPP_my_PL_parser_var(bufptr) #define PL_bufend D_PPP_my_PL_parser_var(bufend) #define PL_lex_state D_PPP_my_PL_parser_var(lex_state) #define PL_lex_stuff D_PPP_my_PL_parser_var(lex_stuff) #define PL_tokenbuf D_PPP_my_PL_parser_var(tokenbuf) #define PL_in_my D_PPP_my_PL_parser_var(in_my) #define PL_in_my_stash D_PPP_my_PL_parser_var(in_my_stash) #define PL_error_count D_PPP_my_PL_parser_var(error_count) #else #define PL_parser ((void *) 1) #endif #if (PERL_BCDVERSION <= 0x5003022) #undef start_subparse #if (PERL_BCDVERSION < 0x5003022) #ifndef start_subparse #define start_subparse(a, b) Perl_start_subparse() #endif #else #ifndef start_subparse #define start_subparse(a, b) Perl_start_subparse(b) #endif #endif #if (PERL_BCDVERSION < 0x5003007) foo #endif #endif #if (PERL_BCDVERSION < 0x5004063) && (PERL_BCDVERSION != 0x5004005) #define NEED_newCONSTSUB #if defined(NEED_newCONSTSUB) static CV * DPPP_(my_newCONSTSUB)(HV * stash, const char * name, SV * sv); static #else extern CV * DPPP_(my_newCONSTSUB)(HV * stash, const char * name, SV * sv); #endif #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) #ifdef newCONSTSUB #undef newCONSTSUB #endif #define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c) #define Perl_newCONSTSUB DPPP_(my_newCONSTSUB) #define D_PPP_PL_copline PL_copline CV * DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv) { CV *cv; 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 = D_PPP_PL_copline; PL_hints &= ~HINT_BLOCK_SCOPE; if (stash) PL_curstash = PL_curcop->cop_stash = stash; cv = newSUB( start_subparse(FALSE, 0), newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)), newSVOP(OP_CONST, 0, &PL_sv_no), 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; return cv; } #endif #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 #if defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L #ifndef PERL_STATIC_INLINE #define PERL_STATIC_INLINE static inline #endif #else #ifndef PERL_STATIC_INLINE #define PERL_STATIC_INLINE static #endif #endif #ifndef cBOOL #define cBOOL(cbool) ((cbool) ? (bool)1 : (bool)0) #endif #ifndef OpHAS_SIBLING #define OpHAS_SIBLING(o) (cBOOL((o)->op_sibling)) #endif #ifndef OpSIBLING #define OpSIBLING(o) (0 + (o)->op_sibling) #endif #ifndef OpMORESIB_set #define OpMORESIB_set(o, sib) ((o)->op_sibling = (sib)) #endif #ifndef OpLASTSIB_set #define OpLASTSIB_set(o, parent) ((o)->op_sibling = NULL) #endif #ifndef OpMAYBESIB_set #define OpMAYBESIB_set(o, sib, parent) ((o)->op_sibling = (sib)) #endif #ifndef HEf_SVKEY #define HEf_SVKEY -2 #endif #if defined(DEBUGGING) && !defined(__COVERITY__) #ifndef __ASSERT_ #define __ASSERT_(statement) assert(statement), #endif #else #ifndef __ASSERT_ #define __ASSERT_(statement) #endif #endif #ifndef __has_builtin #define __has_builtin(x) 0 #endif #if __has_builtin(__builtin_unreachable) #define D_PPP_HAS_BUILTIN_UNREACHABLE #elif (defined(__GNUC__) && ( __GNUC__ > 4 \ || __GNUC__ == 4 && __GNUC_MINOR__ >= 5)) #define D_PPP_HAS_BUILTIN_UNREACHABLE #endif #ifndef ASSUME #ifdef DEBUGGING #define ASSUME(x) assert(x) #elif defined(_MSC_VER) #define ASSUME(x) __assume(x) #elif defined(__ARMCC_VERSION) #define ASSUME(x) __promise(x) #elif defined(D_PPP_HAS_BUILTIN_UNREACHABLE) #define ASSUME(x) ((x) ? (void) 0 : __builtin_unreachable()) #else #define ASSUME(x) assert(x) #endif #endif #ifndef NOT_REACHED #ifdef D_PPP_HAS_BUILTIN_UNREACHABLE #define NOT_REACHED \ STMT_START { \ ASSUME(!"UNREACHABLE"); __builtin_unreachable(); \ } STMT_END #elif ! defined(__GNUC__) && (defined(__sun) || defined(__hpux)) #define NOT_REACHED #else #define NOT_REACHED ASSUME(!"UNREACHABLE") #endif #endif #ifndef WIDEST_UTYPE #ifdef QUADKIND #ifdef U64TYPE #define WIDEST_UTYPE U64TYPE #else #define WIDEST_UTYPE unsigned Quad_t #endif #else #define WIDEST_UTYPE U32 #endif #endif #ifndef withinCOUNT #define withinCOUNT(c, l, n) \ (((WIDEST_UTYPE) (((c)) - ((l) | 0))) <= (((WIDEST_UTYPE) ((n) | 0)))) #endif #ifndef inRANGE #define inRANGE(c, l, u) \ ( (sizeof(c) == sizeof(U8)) ? withinCOUNT(((U8) (c)), (l), ((u) - (l))) \ : (sizeof(c) == sizeof(U32)) ? withinCOUNT(((U32) (c)), (l), ((u) - (l))) \ : (withinCOUNT(((WIDEST_UTYPE) (c)), (l), ((u) - (l))))) #endif #undef FITS_IN_8_BITS #ifndef FITS_IN_8_BITS #define FITS_IN_8_BITS(c) ( (sizeof(c) == 1) \ || !(((WIDEST_UTYPE)((c) | 0)) & ~0xFF)) #endif #define D_PPP_IS_GENERIC_UTF8_SAFE(s, e, macro) \ (((e) - (s)) <= 0 \ ? 0 \ : UTF8_IS_INVARIANT((s)[0]) \ ? is ## macro ## _L1((s)[0]) \ : (((e) - (s)) < UTF8SKIP(s)) \ ? 0 \ : UTF8_IS_DOWNGRADEABLE_START((s)[0]) \ \ ? is ## macro ## _L1((WIDEST_UTYPE) LATIN1_TO_NATIVE( \ UTF8_ACCUMULATE(NATIVE_UTF8_TO_I8((s)[0]) \ & UTF_START_MASK(2), \ (s)[1]))) \ : is ## macro ## _utf8(s)) #define D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, macro) \ (((e) - (s)) <= 0 \ ? 0 \ : UTF8_IS_INVARIANT((s)[0]) \ ? is ## macro ## _LC((s)[0]) \ : (((e) - (s)) < UTF8SKIP(s)) \ ? 0 \ : UTF8_IS_DOWNGRADEABLE_START((s)[0]) \ \ ? is ## macro ## _LC((WIDEST_UTYPE) LATIN1_TO_NATIVE( \ UTF8_ACCUMULATE(NATIVE_UTF8_TO_I8((s)[0]) \ & UTF_START_MASK(2), \ (s)[1]))) \ : is ## macro ## _utf8(s)) #define D_PPP_IS_GENERIC_LC_UTF8_SAFE_BROKEN(s, e, macro) \ (((e) - (s)) <= 0 \ ? 0 \ : UTF8_IS_INVARIANT((s)[0]) \ ? is ## macro ## _LC((s)[0]) \ : (((e) - (s)) < UTF8SKIP(s)) \ ? 0 \ : UTF8_IS_DOWNGRADEABLE_START((s)[0]) \ \ ? is ## macro ## _LC((WIDEST_UTYPE) LATIN1_TO_NATIVE( \ UTF8_ACCUMULATE(NATIVE_UTF8_TO_I8((s)[0]) \ & UTF_START_MASK(2), \ (s)[1]))) \ : is ## macro ## _utf8_safe(s, e)) #ifndef SvRX #define SvRX(rv) (SvROK((rv)) ? (SvMAGICAL(SvRV((rv))) ? (mg_find(SvRV((rv)), PERL_MAGIC_qr) ? mg_find(SvRV((rv)), PERL_MAGIC_qr)->mg_obj : NULL) : NULL) : NULL) #endif #ifndef SvRXOK #define SvRXOK(sv) (!!SvRX(sv)) #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) #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 PERL_UNUSED_RESULT #if defined(__GNUC__) && defined(HASATTRIBUTE_WARN_UNUSED_RESULT) #define PERL_UNUSED_RESULT(v) STMT_START { __typeof__(v) z = (v); (void)sizeof(z); } STMT_END #else #define PERL_UNUSED_RESULT(v) ((void)(v)) #endif #endif #ifndef NOOP #define NOOP (void)0 #endif #if (PERL_BCDVERSION < 0x5006001) && (PERL_BCDVERSION < 0x5027007) #undef dNOOP #ifndef dNOOP #define dNOOP struct Perl___notused_struct #endif #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 #endif #ifndef PTR2ul #if PTRSIZE == LONGSIZE #define PTR2ul(p) (unsigned long)(p) #else #define PTR2ul(p) INT2PTR(unsigned long,p) #endif #endif #ifndef PTR2nat #define PTR2nat(p) (PTRV)(p) #endif #ifndef NUM2PTR #define NUM2PTR(any,d) (any)PTR2nat(d) #endif #ifndef PTR2IV #define PTR2IV(p) INT2PTR(IV,p) #endif #ifndef PTR2UV #define PTR2UV(p) INT2PTR(UV,p) #endif #ifndef PTR2NV #define PTR2NV(p) NUM2PTR(NV,p) #endif #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 (PERL_BCDVERSION < 0x5004000) || defined(PERL_GCC_PEDANTIC) #ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN #ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN #define PERL_GCC_BRACE_GROUPS_FORBIDDEN #endif #endif #endif #if ! defined(__GNUC__) || defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) || defined(__cplusplus) #undef PERL_USE_GCC_BRACE_GROUPS #else #ifndef PERL_USE_GCC_BRACE_GROUPS #define PERL_USE_GCC_BRACE_GROUPS #endif #endif #undef STMT_START #undef STMT_END #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 #ifndef boolSV #define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) #endif #ifndef DEFSV #define DEFSV GvSV(PL_defgv) #endif #ifndef SAVE_DEFSV #define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) #endif #ifndef DEFSV_set #define DEFSV_set(sv) (DEFSV = (sv)) #endif #ifndef AvFILLp #define AvFILLp AvFILL #endif #ifndef av_tindex #define av_tindex AvFILL #endif #ifndef av_top_index #define av_top_index AvFILL #endif #ifndef av_count #define av_count(av) (AvFILL(av)+1) #endif #ifndef ERRSV #define ERRSV get_sv("@",FALSE) #endif #ifndef gv_stashpvn #define gv_stashpvn(str,len,create) gv_stashpv(str,create) #endif #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 #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; \ 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 XSPROTO #define XSPROTO(name) void name(pTHX_ CV* cv) #endif #ifndef SVfARG #define SVfARG(p) ((void*)(p)) #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 CPERLscope #define CPERLscope(x) x #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 PERLIO_FUNCS_DECL #ifdef PERLIO_FUNCS_CONST #define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs #define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs) #else #define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs #define PERLIO_FUNCS_CAST(funcs) (funcs) #endif #endif #if (PERL_BCDVERSION < 0x5009003) #ifdef ARGSproto typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto); #else typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX); #endif typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*); #endif #if defined(EBCDIC) && defined(NATIVE_TO_ASCI) #ifndef NATIVE_TO_LATIN1 #define NATIVE_TO_LATIN1(c) NATIVE_TO_ASCII(c) #endif #ifndef LATIN1_TO_NATIVE #define LATIN1_TO_NATIVE(c) ASCII_TO_NATIVE(c) #endif #ifndef NATIVE_TO_UNI #define NATIVE_TO_UNI(c) ((c) > 255 ? (c) : NATIVE_TO_LATIN1(c)) #endif #ifndef UNI_TO_NATIVE #define UNI_TO_NATIVE(c) ((c) > 255 ? (c) : LATIN1_TO_NATIVE(c)) #endif #else #ifndef NATIVE_TO_LATIN1 #define NATIVE_TO_LATIN1(c) (c) #endif #ifndef LATIN1_TO_NATIVE #define LATIN1_TO_NATIVE(c) (c) #endif #ifndef NATIVE_TO_UNI #define NATIVE_TO_UNI(c) (c) #endif #ifndef UNI_TO_NATIVE #define UNI_TO_NATIVE(c) (c) #endif #endif #undef isPSXSPC #undef isPSXSPC_A #undef isPSXSPC_L1 #ifdef EBCDIC #if (PERL_BCDVERSION < 0x5022000) #undef isALNUM #undef isALNUM_A #undef isALNUM_L1 #undef isALNUMC #undef isALNUMC_A #undef isALNUMC_L1 #undef isALPHA #undef isALPHA_A #undef isALPHA_L1 #undef isALPHANUMERIC #undef isALPHANUMERIC_A #undef isALPHANUMERIC_L1 #undef isASCII #undef isASCII_A #undef isASCII_L1 #undef isBLANK #undef isBLANK_A #undef isBLANK_L1 #undef isCNTRL #undef isCNTRL_A #undef isCNTRL_L1 #undef isDIGIT #undef isDIGIT_A #undef isDIGIT_L1 #undef isGRAPH #undef isGRAPH_A #undef isGRAPH_L1 #undef isIDCONT #undef isIDCONT_A #undef isIDCONT_L1 #undef isIDFIRST #undef isIDFIRST_A #undef isIDFIRST_L1 #undef isLOWER #undef isLOWER_A #undef isLOWER_L1 #undef isOCTAL #undef isOCTAL_A #undef isOCTAL_L1 #undef isPRINT #undef isPRINT_A #undef isPRINT_L1 #undef isPUNCT #undef isPUNCT_A #undef isPUNCT_L1 #undef isSPACE #undef isSPACE_A #undef isSPACE_L1 #undef isUPPER #undef isUPPER_A #undef isUPPER_L1 #undef isWORDCHAR #undef isWORDCHAR_A #undef isWORDCHAR_L1 #undef isXDIGIT #undef isXDIGIT_A #undef isXDIGIT_L1 #endif #ifndef isASCII #define isASCII(c) (isCNTRL(c) || isPRINT(c)) #endif #ifndef isCNTRL #define isCNTRL(c) ( (c) == '\0' || (c) == '\a' || (c) == '\b' \ || (c) == '\f' || (c) == '\n' || (c) == '\r' \ || (c) == '\t' || (c) == '\v' \ || ((c) <= 3 && (c) >= 1) \ || (c) == 7 \ || ((c) <= 0x13 && (c) >= 0x0E) \ \ || (c) == 0x18 \ || (c) == 0x19 \ || ((c) <= 0x1F && (c) >= 0x1C) \ || (c) == 0x26 \ || (c) == 0x27 \ || (c) == 0x2D \ || (c) == 0x2E \ || (c) == 0x32 \ || (c) == 0x37 \ || (c) == 0x3C \ || (c) == 0x3D \ || (c) == 0x3F \ ) #endif #if '^' == 106 #define D_PPP_OUTLIER_CONTROL 0x5F #else #define D_PPP_OUTLIER_CONTROL 0xFF #endif #ifndef isCNTRL_L1 #define isCNTRL_L1(c) ((WIDEST_UTYPE) (c) < ' ' \ || (WIDEST_UTYPE) (c) == D_PPP_OUTLIER_CONTROL) #endif #ifndef isLOWER #define isLOWER(c) ( (c) >= 'a' && (c) <= 'z' \ && ( (c) <= 'i' \ || ((c) >= 'j' && (c) <= 'r') \ || (c) >= 's')) #endif #ifndef isUPPER #define isUPPER(c) ( (c) >= 'A' && (c) <= 'Z' \ && ( (c) <= 'I' \ || ((c) >= 'J' && (c) <= 'R') \ || (c) >= 'S')) #endif #else #if (PERL_BCDVERSION < 0x5004000) #undef isALNUM #undef isALNUM_A #undef isALPHA #undef isALPHA_A #undef isDIGIT #undef isDIGIT_A #undef isIDFIRST #undef isIDFIRST_A #undef isLOWER #undef isLOWER_A #undef isUPPER #undef isUPPER_A #endif #if (PERL_BCDVERSION == 0x5007000) #undef isGRAPH #endif #if (PERL_BCDVERSION < 0x5008000) #undef isCNTRL #endif #if (PERL_BCDVERSION < 0x5010000) #undef isPRINT #undef isPRINT_A #endif #if (PERL_BCDVERSION < 0x5014000) #undef isASCII #undef isASCII_A #endif #if (PERL_BCDVERSION < 0x5017008) #undef isPUNCT_L1 #endif #if (PERL_BCDVERSION < 0x5013007) #undef isALNUMC_L1 #endif #if (PERL_BCDVERSION < 0x5020000) #undef isSPACE #undef isSPACE_A #undef isSPACE_L1 #endif #ifndef isASCII #define isASCII(c) ((WIDEST_UTYPE) (c) <= 127) #endif #ifndef isCNTRL #define isCNTRL(c) ((WIDEST_UTYPE) (c) < ' ' || (c) == 127) #endif #ifndef isCNTRL_L1 #define isCNTRL_L1(c) ( (WIDEST_UTYPE) (c) < ' ' \ || inRANGE((c), 0x7F, 0x9F)) #endif #ifndef isLOWER #define isLOWER(c) inRANGE((c), 'a', 'z') #endif #ifndef isUPPER #define isUPPER(c) inRANGE((c), 'A', 'Z') #endif #endif #ifndef isASCII_L1 #define isASCII_L1(c) isASCII(c) #endif #ifndef isASCII_LC #define isASCII_LC(c) isASCII(c) #endif #ifndef isALNUM #define isALNUM(c) isWORDCHAR(c) #endif #ifndef isALNUMC #define isALNUMC(c) isALPHANUMERIC(c) #endif #ifndef isALNUMC_L1 #define isALNUMC_L1(c) isALPHANUMERIC_L1(c) #endif #ifndef isALPHA #define isALPHA(c) (isUPPER(c) || isLOWER(c)) #endif #ifndef isALPHA_L1 #define isALPHA_L1(c) (isUPPER_L1(c) || isLOWER_L1(c)) #endif #ifndef isALPHANUMERIC #define isALPHANUMERIC(c) (isALPHA(c) || isDIGIT(c)) #endif #ifndef isALPHANUMERIC_L1 #define isALPHANUMERIC_L1(c) (isALPHA_L1(c) || isDIGIT(c)) #endif #ifndef isALPHANUMERIC_LC #define isALPHANUMERIC_LC(c) (isALPHA_LC(c) || isDIGIT_LC(c)) #endif #ifndef isBLANK #define isBLANK(c) ((c) == ' ' || (c) == '\t') #endif #ifndef isBLANK_L1 #define isBLANK_L1(c) ( isBLANK(c) \ || ( FITS_IN_8_BITS(c) \ && NATIVE_TO_LATIN1((U8) c) == 0xA0)) #endif #ifndef isBLANK_LC #define isBLANK_LC(c) isBLANK(c) #endif #ifndef isDIGIT #define isDIGIT(c) inRANGE(c, '0', '9') #endif #ifndef isDIGIT_L1 #define isDIGIT_L1(c) isDIGIT(c) #endif #ifndef isGRAPH #define isGRAPH(c) (isWORDCHAR(c) || isPUNCT(c)) #endif #ifndef isGRAPH_L1 #define isGRAPH_L1(c) ( isPRINT_L1(c) \ && (c) != ' ' \ && NATIVE_TO_LATIN1((U8) c) != 0xA0) #endif #ifndef isIDCONT #define isIDCONT(c) isWORDCHAR(c) #endif #ifndef isIDCONT_L1 #define isIDCONT_L1(c) isWORDCHAR_L1(c) #endif #ifndef isIDCONT_LC #define isIDCONT_LC(c) isWORDCHAR_LC(c) #endif #ifndef isIDFIRST #define isIDFIRST(c) (isALPHA(c) || (c) == '_') #endif #ifndef isIDFIRST_L1 #define isIDFIRST_L1(c) (isALPHA_L1(c) || (U8) (c) == '_') #endif #ifndef isIDFIRST_LC #define isIDFIRST_LC(c) (isALPHA_LC(c) || (U8) (c) == '_') #endif #ifndef isLOWER_L1 #define isLOWER_L1(c) ( isLOWER(c) \ || ( FITS_IN_8_BITS(c) \ && ( ( NATIVE_TO_LATIN1((U8) c) >= 0xDF \ && NATIVE_TO_LATIN1((U8) c) != 0xF7) \ || NATIVE_TO_LATIN1((U8) c) == 0xAA \ || NATIVE_TO_LATIN1((U8) c) == 0xBA \ || NATIVE_TO_LATIN1((U8) c) == 0xB5))) #endif #ifndef isOCTAL #define isOCTAL(c) (((WIDEST_UTYPE)((c)) & ~7) == '0') #endif #ifndef isOCTAL_L1 #define isOCTAL_L1(c) isOCTAL(c) #endif #ifndef isPRINT #define isPRINT(c) (isGRAPH(c) || (c) == ' ') #endif #ifndef isPRINT_L1 #define isPRINT_L1(c) (FITS_IN_8_BITS(c) && ! isCNTRL_L1(c)) #endif #ifndef isPSXSPC #define isPSXSPC(c) isSPACE(c) #endif #ifndef isPSXSPC_L1 #define isPSXSPC_L1(c) isSPACE_L1(c) #endif #ifndef isPUNCT #define isPUNCT(c) ( (c) == '-' || (c) == '!' || (c) == '"' \ || (c) == '#' || (c) == '$' || (c) == '%' \ || (c) == '&' || (c) == '\'' || (c) == '(' \ || (c) == ')' || (c) == '*' || (c) == '+' \ || (c) == ',' || (c) == '.' || (c) == '/' \ || (c) == ':' || (c) == ';' || (c) == '<' \ || (c) == '=' || (c) == '>' || (c) == '?' \ || (c) == '@' || (c) == '[' || (c) == '\\' \ || (c) == ']' || (c) == '^' || (c) == '_' \ || (c) == '`' || (c) == '{' || (c) == '|' \ || (c) == '}' || (c) == '~') #endif #ifndef isPUNCT_L1 #define isPUNCT_L1(c) ( isPUNCT(c) \ || ( FITS_IN_8_BITS(c) \ && ( NATIVE_TO_LATIN1((U8) c) == 0xA1 \ || NATIVE_TO_LATIN1((U8) c) == 0xA7 \ || NATIVE_TO_LATIN1((U8) c) == 0xAB \ || NATIVE_TO_LATIN1((U8) c) == 0xB6 \ || NATIVE_TO_LATIN1((U8) c) == 0xB7 \ || NATIVE_TO_LATIN1((U8) c) == 0xBB \ || NATIVE_TO_LATIN1((U8) c) == 0xBF))) #endif #ifndef isSPACE #define isSPACE(c) ( isBLANK(c) || (c) == '\n' || (c) == '\r' \ || (c) == '\v' || (c) == '\f') #endif #ifndef isSPACE_L1 #define isSPACE_L1(c) ( isSPACE(c) \ || (FITS_IN_8_BITS(c) \ && ( NATIVE_TO_LATIN1((U8) c) == 0x85 \ || NATIVE_TO_LATIN1((U8) c) == 0xA0))) #endif #ifndef isUPPER_L1 #define isUPPER_L1(c) ( isUPPER(c) \ || (FITS_IN_8_BITS(c) \ && ( NATIVE_TO_LATIN1((U8) c) >= 0xC0 \ && NATIVE_TO_LATIN1((U8) c) <= 0xDE \ && NATIVE_TO_LATIN1((U8) c) != 0xD7))) #endif #ifndef isWORDCHAR #define isWORDCHAR(c) (isALPHANUMERIC(c) || (c) == '_') #endif #ifndef isWORDCHAR_L1 #define isWORDCHAR_L1(c) (isIDFIRST_L1(c) || isDIGIT(c)) #endif #ifndef isWORDCHAR_LC #define isWORDCHAR_LC(c) (isIDFIRST_LC(c) || isDIGIT_LC(c)) #endif #ifndef isXDIGIT #define isXDIGIT(c) ( isDIGIT(c) \ || inRANGE((c), 'a', 'f') \ || inRANGE((c), 'A', 'F')) #endif #ifndef isXDIGIT_L1 #define isXDIGIT_L1(c) isXDIGIT(c) #endif #ifndef isXDIGIT_LC #define isXDIGIT_LC(c) isxdigit(c) #endif #ifndef isALNUM_A #define isALNUM_A(c) isALNUM(c) #endif #ifndef isALNUMC_A #define isALNUMC_A(c) isALNUMC(c) #endif #ifndef isALPHA_A #define isALPHA_A(c) isALPHA(c) #endif #ifndef isALPHANUMERIC_A #define isALPHANUMERIC_A(c) isALPHANUMERIC(c) #endif #ifndef isASCII_A #define isASCII_A(c) isASCII(c) #endif #ifndef isBLANK_A #define isBLANK_A(c) isBLANK(c) #endif #ifndef isCNTRL_A #define isCNTRL_A(c) isCNTRL(c) #endif #ifndef isDIGIT_A #define isDIGIT_A(c) isDIGIT(c) #endif #ifndef isGRAPH_A #define isGRAPH_A(c) isGRAPH(c) #endif #ifndef isIDCONT_A #define isIDCONT_A(c) isIDCONT(c) #endif #ifndef isIDFIRST_A #define isIDFIRST_A(c) isIDFIRST(c) #endif #ifndef isLOWER_A #define isLOWER_A(c) isLOWER(c) #endif #ifndef isOCTAL_A #define isOCTAL_A(c) isOCTAL(c) #endif #ifndef isPRINT_A #define isPRINT_A(c) isPRINT(c) #endif #ifndef isPSXSPC_A #define isPSXSPC_A(c) isPSXSPC(c) #endif #ifndef isPUNCT_A #define isPUNCT_A(c) isPUNCT(c) #endif #ifndef isSPACE_A #define isSPACE_A(c) isSPACE(c) #endif #ifndef isUPPER_A #define isUPPER_A(c) isUPPER(c) #endif #ifndef isWORDCHAR_A #define isWORDCHAR_A(c) isWORDCHAR(c) #endif #ifndef isXDIGIT_A #define isXDIGIT_A(c) isXDIGIT(c) #endif #ifndef isASCII_utf8_safe #define isASCII_utf8_safe(s,e) (((e) - (s)) <= 0 ? 0 : isASCII(*(s))) #endif #ifndef isASCII_uvchr #define isASCII_uvchr(c) (FITS_IN_8_BITS(c) ? isASCII_L1(c) : 0) #endif #if (PERL_BCDVERSION >= 0x5006000) #ifdef isALPHA_uni #define D_PPP_is_ctype(upper, lower, c) \ (FITS_IN_8_BITS(c) \ ? is ## upper ## _L1(c) \ : is ## upper ## _uni((UV) (c))) #else #define D_PPP_is_ctype(upper, lower, c) \ (FITS_IN_8_BITS(c) \ ? is ## upper ## _L1(c) \ : is_uni_ ## lower((UV) (c))) #endif #ifndef isALPHA_uvchr #define isALPHA_uvchr(c) D_PPP_is_ctype(ALPHA, alpha, c) #endif #ifndef isALPHANUMERIC_uvchr #define isALPHANUMERIC_uvchr(c) (isALPHA_uvchr(c) || isDIGIT_uvchr(c)) #endif #ifdef is_uni_blank #ifndef isBLANK_uvchr #define isBLANK_uvchr(c) D_PPP_is_ctype(BLANK, blank, c) #endif #else #ifndef isBLANK_uvchr #define isBLANK_uvchr(c) (FITS_IN_8_BITS(c) \ ? isBLANK_L1(c) \ : ( (UV) (c) == 0x1680 \ || inRANGE((UV) (c), 0x2000, 0x200A) \ || (UV) (c) == 0x202F \ || (UV) (c) == 0x205F \ || (UV) (c) == 0x3000)) #endif #endif #ifndef isCNTRL_uvchr #define isCNTRL_uvchr(c) D_PPP_is_ctype(CNTRL, cntrl, c) #endif #ifndef isDIGIT_uvchr #define isDIGIT_uvchr(c) D_PPP_is_ctype(DIGIT, digit, c) #endif #ifndef isGRAPH_uvchr #define isGRAPH_uvchr(c) D_PPP_is_ctype(GRAPH, graph, c) #endif #ifndef isIDCONT_uvchr #define isIDCONT_uvchr(c) isWORDCHAR_uvchr(c) #endif #ifndef isIDFIRST_uvchr #define isIDFIRST_uvchr(c) D_PPP_is_ctype(IDFIRST, idfirst, c) #endif #ifndef isLOWER_uvchr #define isLOWER_uvchr(c) D_PPP_is_ctype(LOWER, lower, c) #endif #ifndef isPRINT_uvchr #define isPRINT_uvchr(c) D_PPP_is_ctype(PRINT, print, c) #endif #ifndef isPSXSPC_uvchr #define isPSXSPC_uvchr(c) isSPACE_uvchr(c) #endif #ifndef isPUNCT_uvchr #define isPUNCT_uvchr(c) D_PPP_is_ctype(PUNCT, punct, c) #endif #ifndef isSPACE_uvchr #define isSPACE_uvchr(c) D_PPP_is_ctype(SPACE, space, c) #endif #ifndef isUPPER_uvchr #define isUPPER_uvchr(c) D_PPP_is_ctype(UPPER, upper, c) #endif #ifndef isXDIGIT_uvchr #define isXDIGIT_uvchr(c) D_PPP_is_ctype(XDIGIT, xdigit, c) #endif #ifndef isWORDCHAR_uvchr #define isWORDCHAR_uvchr(c) (FITS_IN_8_BITS(c) \ ? isWORDCHAR_L1(c) : isALPHANUMERIC_uvchr(c)) #endif #ifndef isALPHA_utf8_safe #define isALPHA_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, ALPHA) #endif #ifdef isALPHANUMERIC_utf8 #ifndef isALPHANUMERIC_utf8_safe #define isALPHANUMERIC_utf8_safe(s,e) \ D_PPP_IS_GENERIC_UTF8_SAFE(s, e, ALPHANUMERIC) #endif #else #ifndef isALPHANUMERIC_utf8_safe #define isALPHANUMERIC_utf8_safe(s,e) \ (isALPHA_utf8_safe(s,e) || isDIGIT_utf8_safe(s,e)) #endif #endif #if 'A' == 65 #ifndef isBLANK_utf8_safe #define isBLANK_utf8_safe(s,e) \ ( ( LIKELY((e) > (s)) ) ? \ ( ( 0x09 == ((const U8*)s)[0] || 0x20 == ((const U8*)s)[0] ) ? 1 \ : ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) ? \ ( ( 0xC2 == ((const U8*)s)[0] ) ? \ ( ( 0xA0 == ((const U8*)s)[1] ) ? 2 : 0 ) \ : ( 0xE1 == ((const U8*)s)[0] ) ? \ ( ( ( 0x9A == ((const U8*)s)[1] ) && ( 0x80 == ((const U8*)s)[2] ) ) ? 3 : 0 )\ : ( 0xE2 == ((const U8*)s)[0] ) ? \ ( ( 0x80 == ((const U8*)s)[1] ) ? \ ( ( inRANGE(((const U8*)s)[2], 0x80, 0x8A ) || 0xAF == ((const U8*)s)[2] ) ? 3 : 0 )\ : ( ( 0x81 == ((const U8*)s)[1] ) && ( 0x9F == ((const U8*)s)[2] ) ) ? 3 : 0 )\ : ( ( ( 0xE3 == ((const U8*)s)[0] ) && ( 0x80 == ((const U8*)s)[1] ) ) && ( 0x80 == ((const U8*)s)[2] ) ) ? 3 : 0 )\ : 0 ) \ : 0 ) #endif #elif 'A' == 193 && '^' == 95 #ifndef isBLANK_utf8_safe #define isBLANK_utf8_safe(s,e) \ ( ( LIKELY((e) > (s)) ) ? \ ( ( 0x05 == ((const U8*)s)[0] || 0x40 == ((const U8*)s)[0] ) ? 1 \ : ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) ? \ ( ( 0x80 == ((const U8*)s)[0] ) ? \ ( ( 0x41 == ((const U8*)s)[1] ) ? 2 : 0 ) \ : ( 0xBC == ((const U8*)s)[0] ) ? \ ( ( ( 0x63 == ((const U8*)s)[1] ) && ( 0x41 == ((const U8*)s)[2] ) ) ? 3 : 0 )\ : ( 0xCA == ((const U8*)s)[0] ) ? \ ( ( 0x41 == ((const U8*)s)[1] ) ? \ ( ( inRANGE(((const U8*)s)[2], 0x41, 0x4A ) || 0x51 == ((const U8*)s)[2] ) ? 3 : 0 )\ : ( 0x42 == ((const U8*)s)[1] ) ? \ ( ( 0x56 == ((const U8*)s)[2] ) ? 3 : 0 ) \ : ( ( 0x43 == ((const U8*)s)[1] ) && ( 0x73 == ((const U8*)s)[2] ) ) ? 3 : 0 )\ : ( ( ( 0xCE == ((const U8*)s)[0] ) && ( 0x41 == ((const U8*)s)[1] ) ) && ( 0x41 == ((const U8*)s)[2] ) ) ? 3 : 0 )\ : 0 ) \ : 0 ) #endif #elif 'A' == 193 && '^' == 176 #ifndef isBLANK_utf8_safe #define isBLANK_utf8_safe(s,e) \ ( ( LIKELY((e) > (s)) ) ? \ ( ( 0x05 == ((const U8*)s)[0] || 0x40 == ((const U8*)s)[0] ) ? 1 \ : ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) ? \ ( ( 0x78 == ((const U8*)s)[0] ) ? \ ( ( 0x41 == ((const U8*)s)[1] ) ? 2 : 0 ) \ : ( 0xBD == ((const U8*)s)[0] ) ? \ ( ( ( 0x62 == ((const U8*)s)[1] ) && ( 0x41 == ((const U8*)s)[2] ) ) ? 3 : 0 )\ : ( 0xCA == ((const U8*)s)[0] ) ? \ ( ( 0x41 == ((const U8*)s)[1] ) ? \ ( ( inRANGE(((const U8*)s)[2], 0x41, 0x4A ) || 0x51 == ((const U8*)s)[2] ) ? 3 : 0 )\ : ( 0x42 == ((const U8*)s)[1] ) ? \ ( ( 0x56 == ((const U8*)s)[2] ) ? 3 : 0 ) \ : ( ( 0x43 == ((const U8*)s)[1] ) && ( 0x72 == ((const U8*)s)[2] ) ) ? 3 : 0 )\ : ( ( ( 0xCE == ((const U8*)s)[0] ) && ( 0x41 == ((const U8*)s)[1] ) ) && ( 0x41 == ((const U8*)s)[2] ) ) ? 3 : 0 )\ : 0 ) \ : 0 ) #endif #else #error Unknown character set #endif #ifndef isCNTRL_utf8_safe #define isCNTRL_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, CNTRL) #endif #ifndef isDIGIT_utf8_safe #define isDIGIT_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, DIGIT) #endif #ifndef isGRAPH_utf8_safe #define isGRAPH_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, GRAPH) #endif #ifdef isIDCONT_utf8 #ifndef isIDCONT_utf8_safe #define isIDCONT_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, IDCONT) #endif #else #ifndef isIDCONT_utf8_safe #define isIDCONT_utf8_safe(s,e) isWORDCHAR_utf8_safe(s,e) #endif #endif #ifndef isIDFIRST_utf8_safe #define isIDFIRST_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, IDFIRST) #endif #ifndef isLOWER_utf8_safe #define isLOWER_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, LOWER) #endif #ifndef isPRINT_utf8_safe #define isPRINT_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, PRINT) #endif #undef isPSXSPC_utf8_safe #ifndef isPSXSPC_utf8_safe #define isPSXSPC_utf8_safe(s,e) isSPACE_utf8_safe(s,e) #endif #ifndef isPUNCT_utf8_safe #define isPUNCT_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, PUNCT) #endif #ifndef isSPACE_utf8_safe #define isSPACE_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, SPACE) #endif #ifndef isUPPER_utf8_safe #define isUPPER_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, UPPER) #endif #ifdef isWORDCHAR_utf8 #ifndef isWORDCHAR_utf8_safe #define isWORDCHAR_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, WORDCHAR) #endif #else #ifndef isWORDCHAR_utf8_safe #define isWORDCHAR_utf8_safe(s,e) \ (isALPHANUMERIC_utf8_safe(s,e) || (*(s)) == '_') #endif #endif #if 'A' == 65 #ifndef isXDIGIT_utf8_safe #define isXDIGIT_utf8_safe(s,e) \ ( ( LIKELY((e) > (s)) ) ? \ ( ( inRANGE(((const U8*)s)[0], 0x30, 0x39 ) || inRANGE(((const U8*)s)[0], 0x41, 0x46 ) || inRANGE(((const U8*)s)[0], 0x61, 0x66 ) ) ? 1\ : ( ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) && ( 0xEF == ((const U8*)s)[0] ) ) ? ( ( 0xBC == ((const U8*)s)[1] ) ?\ ( ( inRANGE(((const U8*)s)[2], 0x90, 0x99 ) || inRANGE(((const U8*)s)[2], 0xA1, 0xA6 ) ) ? 3 : 0 )\ : ( ( 0xBD == ((const U8*)s)[1] ) && ( inRANGE(((const U8*)s)[2], 0x81, 0x86 ) ) ) ? 3 : 0 ) : 0 )\ : 0 ) #endif #elif 'A' == 193 && '^' == 95 #ifndef isXDIGIT_utf8_safe #define isXDIGIT_utf8_safe(s,e) \ ( ( LIKELY((e) > (s)) ) ? \ ( ( inRANGE(((const U8*)s)[0], 0x81, 0x86 ) || inRANGE(((const U8*)s)[0], 0xC1, 0xC6 ) || inRANGE(((const U8*)s)[0], 0xF0, 0xF9 ) ) ? 1\ : ( ( ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) && ( 0xDD == ((const U8*)s)[0] ) ) && ( 0x73 == ((const U8*)s)[1] ) ) ? ( ( 0x67 == ((const U8*)s)[2] ) ?\ ( ( inRANGE(((const U8*)s)[3], 0x57, 0x59 ) || inRANGE(((const U8*)s)[3], 0x62, 0x68 ) ) ? 4 : 0 )\ : ( ( inRANGE(((const U8*)s)[2], 0x68, 0x69 ) ) && ( inRANGE(((const U8*)s)[3], 0x42, 0x47 ) ) ) ? 4 : 0 ) : 0 )\ : 0 ) #endif #elif 'A' == 193 && '^' == 176 #ifndef isXDIGIT_utf8_safe #define isXDIGIT_utf8_safe(s,e) \ ( ( LIKELY((e) > (s)) ) ? \ ( ( inRANGE(((const U8*)s)[0], 0x81, 0x86 ) || inRANGE(((const U8*)s)[0], 0xC1, 0xC6 ) || inRANGE(((const U8*)s)[0], 0xF0, 0xF9 ) ) ? 1\ : ( ( ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) && ( 0xDD == ((const U8*)s)[0] ) ) && ( 0x72 == ((const U8*)s)[1] ) ) ? ( ( 0x66 == ((const U8*)s)[2] ) ?\ ( ( inRANGE(((const U8*)s)[3], 0x57, 0x59 ) || 0x5F == ((const U8*)s)[3] || inRANGE(((const U8*)s)[3], 0x62, 0x67 ) ) ? 4 : 0 )\ : ( ( inRANGE(((const U8*)s)[2], 0x67, 0x68 ) ) && ( inRANGE(((const U8*)s)[3], 0x42, 0x47 ) ) ) ? 4 : 0 ) : 0 )\ : 0 ) #endif #else #error Unknown character set #endif #ifndef isALPHA_LC_utf8_safe #define isALPHA_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, ALPHA) #endif #ifdef isALPHANUMERIC_utf8 #ifndef isALPHANUMERIC_LC_utf8_safe #define isALPHANUMERIC_LC_utf8_safe(s,e) \ D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, ALPHANUMERIC) #endif #else #ifndef isALPHANUMERIC_LC_utf8_safe #define isALPHANUMERIC_LC_utf8_safe(s,e) \ (isALPHA_LC_utf8_safe(s,e) || isDIGIT_LC_utf8_safe(s,e)) #endif #endif #ifndef isBLANK_LC_utf8_safe #define isBLANK_LC_utf8_safe(s,e) \ D_PPP_IS_GENERIC_LC_UTF8_SAFE_BROKEN(s, e, BLANK) #endif #ifndef isCNTRL_LC_utf8_safe #define isCNTRL_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, CNTRL) #endif #ifndef isDIGIT_LC_utf8_safe #define isDIGIT_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, DIGIT) #endif #ifndef isGRAPH_LC_utf8_safe #define isGRAPH_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, GRAPH) #endif #ifdef isIDCONT_utf8 #ifndef isIDCONT_LC_utf8_safe #define isIDCONT_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, IDCONT) #endif #else #ifndef isIDCONT_LC_utf8_safe #define isIDCONT_LC_utf8_safe(s,e) isWORDCHAR_LC_utf8_safe(s,e) #endif #endif #ifndef isIDFIRST_LC_utf8_safe #define isIDFIRST_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, IDFIRST) #endif #ifndef isLOWER_LC_utf8_safe #define isLOWER_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, LOWER) #endif #ifndef isPRINT_LC_utf8_safe #define isPRINT_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, PRINT) #endif #undef isPSXSPC_LC_utf8_safe #ifndef isPSXSPC_LC_utf8_safe #define isPSXSPC_LC_utf8_safe(s,e) isSPACE_LC_utf8_safe(s,e) #endif #ifndef isPUNCT_LC_utf8_safe #define isPUNCT_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, PUNCT) #endif #ifndef isSPACE_LC_utf8_safe #define isSPACE_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, SPACE) #endif #ifndef isUPPER_LC_utf8_safe #define isUPPER_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, UPPER) #endif #ifdef isWORDCHAR_utf8 #ifndef isWORDCHAR_LC_utf8_safe #define isWORDCHAR_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, WORDCHAR) #endif #else #ifndef isWORDCHAR_LC_utf8_safe #define isWORDCHAR_LC_utf8_safe(s,e) \ (isALPHANUMERIC_LC_utf8_safe(s,e) || (*(s)) == '_') #endif #endif #ifndef isXDIGIT_LC_utf8_safe #define isXDIGIT_LC_utf8_safe(s,e) \ D_PPP_IS_GENERIC_LC_UTF8_SAFE_BROKEN(s, e, XDIGIT) #endif #endif #define D_PPP_TOO_SHORT_MSG "Malformed UTF-8 character starting with:" \ " \\x%02x (too short; %d bytes available, need" \ " %d)\n" #if (PERL_BCDVERSION >= 0x5007003) #ifndef toLOWER_uvchr #define toLOWER_uvchr(c, s, l) UNI_TO_NATIVE(to_uni_lower(NATIVE_TO_UNI(c), s, l)) #endif #ifndef toUPPER_uvchr #define toUPPER_uvchr(c, s, l) UNI_TO_NATIVE(to_uni_upper(NATIVE_TO_UNI(c), s, l)) #endif #ifndef toTITLE_uvchr #define toTITLE_uvchr(c, s, l) UNI_TO_NATIVE(to_uni_title(NATIVE_TO_UNI(c), s, l)) #endif #ifndef toFOLD_uvchr #define toFOLD_uvchr(c, s, l) UNI_TO_NATIVE(to_uni_fold( NATIVE_TO_UNI(c), s, l)) #endif #if (PERL_BCDVERSION != 0x5015006) #if defined toLOWER_utf8 #define D_PPP_TO_LOWER_CALLEE(s,r,l) toLOWER_utf8(s,r,l) #else #define D_PPP_TO_LOWER_CALLEE(s,r,l) to_utf8_lower(s,r,l) #endif #if defined toTITLE_utf8 #define D_PPP_TO_TITLE_CALLEE(s,r,l) toTITLE_utf8(s,r,l) #else #define D_PPP_TO_TITLE_CALLEE(s,r,l) to_utf8_title(s,r,l) #endif #if defined toUPPER_utf8 #define D_PPP_TO_UPPER_CALLEE(s,r,l) toUPPER_utf8(s,r,l) #else #define D_PPP_TO_UPPER_CALLEE(s,r,l) to_utf8_upper(s,r,l) #endif #if defined toFOLD_utf8 #define D_PPP_TO_FOLD_CALLEE(s,r,l) toFOLD_utf8(s,r,l) #else #define D_PPP_TO_FOLD_CALLEE(s,r,l) to_utf8_fold(s,r,l) #endif #else #define D_PPP_TO_LOWER_CALLEE(s,r,l) \ Perl__to_utf8_lower_flags(aTHX_ s, r, l, 0, NULL) #define D_PPP_TO_TITLE_CALLEE(s,r,l) \ Perl__to_utf8_title_flags(aTHX_ s, r, l, 0, NULL) #define D_PPP_TO_UPPER_CALLEE(s,r,l) \ Perl__to_utf8_upper_flags(aTHX_ s, r, l, 0, NULL) #define D_PPP_TO_FOLD_CALLEE(s,r,l) \ Perl__to_utf8_fold_flags(aTHX_ s, r, l, FOLD_FLAGS_FULL, NULL) #endif #define D_PPP_GENERIC_MULTI_ARG_TO(name, s, e,r,l) \ (((((e) - (s)) <= 0) \ \ ? (croak("Attempting case change on zero length string"), \ 0) \ : ((e) - (s)) < UTF8SKIP(s)) \ ? (croak(D_PPP_TOO_SHORT_MSG, \ s[0], (int) ((e) - (s)), (int) UTF8SKIP(s)), \ 0) \ : D_PPP_TO_ ## name ## _CALLEE(s,r,l)) #ifndef toUPPER_utf8_safe #define toUPPER_utf8_safe(s,e,r,l) \ D_PPP_GENERIC_MULTI_ARG_TO(UPPER,s,e,r,l) #endif #ifndef toLOWER_utf8_safe #define toLOWER_utf8_safe(s,e,r,l) \ D_PPP_GENERIC_MULTI_ARG_TO(LOWER,s,e,r,l) #endif #ifndef toTITLE_utf8_safe #define toTITLE_utf8_safe(s,e,r,l) \ D_PPP_GENERIC_MULTI_ARG_TO(TITLE,s,e,r,l) #endif #ifndef toFOLD_utf8_safe #define toFOLD_utf8_safe(s,e,r,l) \ D_PPP_GENERIC_MULTI_ARG_TO(FOLD,s,e,r,l) #endif #elif (PERL_BCDVERSION >= 0x5006000) #ifdef uvchr_to_utf8 #define D_PPP_UV_TO_UTF8 uvchr_to_utf8 #else #define D_PPP_UV_TO_UTF8 uv_to_utf8 #endif #define D_PPP_GENERIC_SINGLE_ARG_TO_UVCHR(name, c, s, l) \ (*(l) = (D_PPP_UV_TO_UTF8(s, \ UNI_TO_NATIVE(to_uni_ ## name(NATIVE_TO_UNI(c)))) - (s)), \ UNI_TO_NATIVE(to_uni_ ## name(NATIVE_TO_UNI(c)))) #ifndef toLOWER_uvchr #define toLOWER_uvchr(c, s, l) \ D_PPP_GENERIC_SINGLE_ARG_TO_UVCHR(lower, c, s, l) #endif #ifndef toUPPER_uvchr #define toUPPER_uvchr(c, s, l) \ D_PPP_GENERIC_SINGLE_ARG_TO_UVCHR(upper, c, s, l) #endif #ifndef toTITLE_uvchr #define toTITLE_uvchr(c, s, l) \ D_PPP_GENERIC_SINGLE_ARG_TO_UVCHR(title, c, s, l) #endif #ifndef toFOLD_uvchr #define toFOLD_uvchr(c, s, l) toLOWER_uvchr(c, s, l) #endif #define D_PPP_GENERIC_SINGLE_ARG_TO_UTF8(name, s, e, r, l) \ (((((e) - (s)) <= 0) \ ? (croak("Attempting case change on zero length string"), \ 0) \ : ((e) - (s)) < UTF8SKIP(s)) \ ? (croak(D_PPP_TOO_SHORT_MSG, \ s[0], (int) ((e) - (s)), (int) UTF8SKIP(s)), \ 0) \ \ : D_PPP_UV_TO_UTF8(r, to_utf8_ ## name(s)), \ \ *(l) = UTF8SKIP(r), to_utf8_ ## name(r)) #ifndef toUPPER_utf8_safe #define toUPPER_utf8_safe(s,e,r,l) \ D_PPP_GENERIC_SINGLE_ARG_TO_UTF8(upper, s, e, r, l) #endif #ifndef toLOWER_utf8_safe #define toLOWER_utf8_safe(s,e,r,l) \ D_PPP_GENERIC_SINGLE_ARG_TO_UTF8(lower, s, e, r, l) #endif #ifndef toTITLE_utf8_safe #define toTITLE_utf8_safe(s,e,r,l) \ D_PPP_GENERIC_SINGLE_ARG_TO_UTF8(title, s, e, r, l) #endif #ifndef toFOLD_utf8_safe #define toFOLD_utf8_safe(s,e,r,l) toLOWER_utf8_safe(s,e,r,l) #endif #endif #if (PERL_BCDVERSION >= 0x5008000) #ifndef HeUTF8 #define HeUTF8(he) ((HeKLEN(he) == HEf_SVKEY) ? \ SvUTF8(HeKEY_sv(he)) : \ (U32)HeKUTF8(he)) #endif #endif #ifndef C_ARRAY_LENGTH #define C_ARRAY_LENGTH(a) (sizeof(a)/sizeof((a)[0])) #endif #ifndef C_ARRAY_END #define C_ARRAY_END(a) ((a) + C_ARRAY_LENGTH(a)) #endif #ifndef LIKELY #define LIKELY(x) (x) #endif #ifndef UNLIKELY #define UNLIKELY(x) (x) #endif #ifndef MUTABLE_PTR #if defined(PERL_USE_GCC_BRACE_GROUPS) #define MUTABLE_PTR(p) ({ void *_p = (p); _p; }) #else #define MUTABLE_PTR(p) ((void *) (p)) #endif #endif #ifndef MUTABLE_AV #define MUTABLE_AV(p) ((AV *)MUTABLE_PTR(p)) #endif #ifndef MUTABLE_CV #define MUTABLE_CV(p) ((CV *)MUTABLE_PTR(p)) #endif #ifndef MUTABLE_GV #define MUTABLE_GV(p) ((GV *)MUTABLE_PTR(p)) #endif #ifndef MUTABLE_HV #define MUTABLE_HV(p) ((HV *)MUTABLE_PTR(p)) #endif #ifndef MUTABLE_IO #define MUTABLE_IO(p) ((IO *)MUTABLE_PTR(p)) #endif #ifndef MUTABLE_SV #define MUTABLE_SV(p) ((SV *)MUTABLE_PTR(p)) #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(vnewSVpvf) #if defined(PERL_USE_GCC_BRACE_GROUPS) #define vnewSVpvf(pat, args) ({ SV *_sv = newSV(0); sv_vsetpvfn(_sv, (pat), strlen((pat)), (args), Null(SV**), 0, Null(bool*)); _sv; }) #else #define vnewSVpvf(pat, args) ((PL_Sv = newSV(0)), sv_vsetpvfn(PL_Sv, (pat), strlen((pat)), (args), Null(SV**), 0, Null(bool*)), PL_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 * const sv, const char * const pat, ...); static #else extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * const sv, const char * const pat, ...); #endif #if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL) #define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg) void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * const sv, const char * const 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 * const sv, const char * const pat, ...); static #else extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV * const sv, const char * const pat, ...); #endif #if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL) #define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) #define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) void DPPP_(my_sv_catpvf_mg_nocontext)(SV * const sv, const char * const 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 #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 * const sv, const char * const pat, ...); static #else extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * const sv, const char * const pat, ...); #endif #if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL) #define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg) void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * const sv, const char * const 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 * const sv, const char * const pat, ...); static #else extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV * const sv, const char * const pat, ...); #endif #if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL) #define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) #define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) void DPPP_(my_sv_setpvf_mg_nocontext)(SV * const sv, const char * const 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 #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 sv_2pv_nolen #define sv_2pv_nolen(sv) SvPV_nolen(sv) #endif #ifdef SvPVbyte #if (PERL_BCDVERSION < 0x5007000) #ifndef sv_2pvbyte #define sv_2pvbyte(sv, lp) (sv_utf8_downgrade((sv), 0), SvPV((sv), *(lp))) #endif #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 #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_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 defined(PERL_USE_GCC_BRACE_GROUPS) #ifndef sv_2pv_flags #define sv_2pv_flags(sv, lp, flags) ({ SV *_sv = (sv); const I32 _flags = (flags); STRLEN *_lp = lp; _lp = _lp ? : &PL_na; (!(_flags & SV_GMAGIC) && SvGMAGICAL(_sv)) ? ({ char *_pv; SvGMAGICAL_off(_sv); _pv = sv_2pv(_sv, _lp); SvGMAGICAL_on(_sv); _pv; }) : sv_2pv(_sv, _lp); }) #endif #ifndef sv_pvn_force_flags #define sv_pvn_force_flags(sv, lp, flags) ({ SV *_sv = (sv); const I32 _flags = (flags); STRLEN *_lp = lp; _lp = _lp ? : &PL_na; (!(_flags & SV_GMAGIC) && SvGMAGICAL(_sv)) ? ({ char *_pv; SvGMAGICAL_off(_sv); _pv = sv_pvn_force(_sv, _lp); SvGMAGICAL_on(_sv); _pv; }) : sv_pvn_force(_sv, _lp); }) #endif #else #ifndef sv_2pv_flags #define sv_2pv_flags(sv, lp, flags) ((PL_Sv = (sv)), (!((flags) & SV_GMAGIC) && SvGMAGICAL(PL_Sv)) ? (SvGMAGICAL_off(PL_Sv), (PL_Xpv = (XPV *)sv_2pv(PL_Sv, (lp) ? (lp) : &PL_na)), SvGMAGICAL_on(PL_Sv), (char *)PL_Xpv) : sv_2pv(PL_Sv, (lp) ? (lp) : &PL_na)) #endif #ifndef sv_pvn_force_flags #define sv_pvn_force_flags(sv, lp, flags) ((PL_Sv = (sv)), (!((flags) & SV_GMAGIC) && SvGMAGICAL(PL_Sv)) ? (SvGMAGICAL_off(PL_Sv), (PL_Xpv = (XPV *)sv_pvn_force(PL_Sv, (lp) ? (lp) : &PL_na)), SvGMAGICAL_on(PL_Sv), (char *)PL_Xpv) : sv_pvn_force(PL_Sv, (lp) ? (lp) : &PL_na)) #endif #endif #if (PERL_BCDVERSION < 0x5008008) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009003) ) #define D_PPP_SVPV_NOLEN_LP_ARG &PL_na #else #define D_PPP_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, D_PPP_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, D_PPP_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, D_PPP_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, D_PPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC|SV_CONST_RETURN)) #endif #if defined(PERL_USE_GCC_BRACE_GROUPS) #ifndef SvPVx_nolen_const #define SvPVx_nolen_const(sv) ({SV *sV_ = (sv); SvPV_nolen_const(sV_); }) #endif #else #ifndef SvPVx_nolen_const #define SvPVx_nolen_const(sv) (PL_Sv = sv, SvPV_nolen_const(PL_Sv)) #endif #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 SvPV_nomg_nolen #define SvPV_nomg_nolen(sv) ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX(sv) : sv_2pv_flags(sv, D_PPP_SVPV_NOLEN_LP_ARG, 0)) #endif #ifndef SvPV_renew #define SvPV_renew(sv,n) STMT_START { SvLEN_set(sv, n); \ SvPV_set((sv), (char *) saferealloc( \ (Malloc_t)SvPVX(sv), (MEM_SIZE)((n)))); \ } STMT_END #endif #ifndef SvPVCLEAR #define SvPVCLEAR(sv) sv_setpvs((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 packWARN2 #define packWARN2(a,b) (packWARN(a) << 8 | (b)) #endif #ifndef packWARN3 #define packWARN3(a,b,c) (packWARN2(a,b) << 8 | (c)) #endif #ifndef packWARN4 #define packWARN4(a,b,c,d) (packWARN3(a,b,c) << 8 | (d)) #endif #ifndef ckWARN #ifdef G_WARN_ON #define ckWARN(a) (PL_dowarn & G_WARN_ON) #else #define ckWARN(a) PL_dowarn #endif #endif #ifndef ckWARN2 #define ckWARN2(a,b) (ckWARN(a) || ckWARN(b)) #endif #ifndef ckWARN3 #define ckWARN3(a,b,c) (ckWARN(c) || ckWARN2(a,b)) #endif #ifndef ckWARN4 #define ckWARN4(a,b,c,d) (ckWARN(d) || ckWARN3(a,b,c)) #endif #ifndef ckWARN_d #ifdef isLEXWARN_off #define ckWARN_d(a) (isLEXWARN_off || ckWARN(a)) #else #define ckWARN_d(a) 1 #endif #endif #ifndef ckWARN2_d #define ckWARN2_d(a,b) (ckWARN_d(a) || ckWARN_d(b)) #endif #ifndef ckWARN3_d #define ckWARN3_d(a,b,c) (ckWARN_d(c) || ckWARN2_d(a,b)) #endif #ifndef ckWARN4_d #define ckWARN4_d(a,b,c,d) (ckWARN_d(d) || ckWARN3_d(a,b,c)) #endif #ifndef vwarner #define vwarner(err, pat, argsp) \ STMT_START { SV *sv; \ PERL_UNUSED_ARG(err); \ sv = vnewSVpvf(pat, argsp); \ sv_2mortal(sv); \ warn("%s", SvPV_nolen(sv)); \ } STMT_END #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 #if defined(NEED_warner) || defined(NEED_warner_GLOBAL) #define Perl_warner DPPP_(my_warner) void DPPP_(my_warner)(U32 err, const char *pat, ...) { va_list args; va_start(args, pat); vwarner(err, pat, &args); va_end(args); } #define warner Perl_warner #define Perl_warner_nocontext Perl_warner #endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(ck_warner) #if defined(NEED_ck_warner) static void DPPP_(my_ck_warner)(pTHX_ U32 err, const char * pat, ...); static #else extern void DPPP_(my_ck_warner)(pTHX_ U32 err, const char * pat, ...); #endif #if defined(NEED_ck_warner) || defined(NEED_ck_warner_GLOBAL) #define Perl_ck_warner DPPP_(my_ck_warner) void DPPP_(my_ck_warner)(pTHX_ U32 err, const char *pat, ...) { va_list args; if ( ! ckWARN((err ) & 0xFF) && ! ckWARN((err >> 8) & 0xFF) && ! ckWARN((err >> 16) & 0xFF) && ! ckWARN((err >> 24) & 0xFF)) { return; } va_start(args, pat); vwarner(err, pat, &args); va_end(args); } #define ck_warner Perl_ck_warner #endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(ck_warner_d) #if defined(NEED_ck_warner_d) static void DPPP_(my_ck_warner_d)(pTHX_ U32 err, const char * pat, ...); static #else extern void DPPP_(my_ck_warner_d)(pTHX_ U32 err, const char * pat, ...); #endif #if defined(NEED_ck_warner_d) || defined(NEED_ck_warner_d_GLOBAL) #define Perl_ck_warner_d DPPP_(my_ck_warner_d) void DPPP_(my_ck_warner_d)(pTHX_ U32 err, const char *pat, ...) { va_list args; if ( ! ckWARN_d((err ) & 0xFF) && ! ckWARN_d((err >> 8) & 0xFF) && ! ckWARN_d((err >> 16) & 0xFF) && ! ckWARN_d((err >> 24) & 0xFF)) { return; } va_start(args, pat); vwarner(err, pat, &args); va_end(args); } #define ck_warner_d Perl_ck_warner_d #endif #endif #ifndef IVdf #if IVSIZE == LONGSIZE #define IVdf "ld" #define UVuf "lu" #define UVof "lo" #define UVxf "lx" #define UVXf "lX" #elif IVSIZE == INTSIZE #define IVdf "d" #define UVuf "u" #define UVof "o" #define UVxf "x" #define UVXf "X" #else #error "cannot define IV/UV formats" #endif #endif #ifndef NVef #if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ defined(PERL_PRIfldbl) && (PERL_BCDVERSION != 0x5006000) #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 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 #if defined(PERL_USE_GCC_BRACE_GROUPS) #ifndef sv_2uv #define sv_2uv(sv) ({ SV *_sv = (sv); (UV) (SvNOK(_sv) ? SvNV(_sv) : sv_2nv(_sv)); }) #endif #else #ifndef sv_2uv #define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv))) #endif #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 #if defined(PERL_USE_GCC_BRACE_GROUPS) #ifndef SvUVx #define SvUVx(sv) ({ SV *_sv = (sv)); SvUV(_sv); }) #endif #else #ifndef SvUVx #define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv)) #endif #endif #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 #if !defined(my_strnlen) #if defined(NEED_my_strnlen) static Size_t DPPP_(my_my_strnlen)(const char * str, Size_t maxlen); static #else extern Size_t DPPP_(my_my_strnlen)(const char * str, Size_t maxlen); #endif #if defined(NEED_my_strnlen) || defined(NEED_my_strnlen_GLOBAL) #define my_strnlen DPPP_(my_my_strnlen) #define Perl_my_strnlen DPPP_(my_my_strnlen) Size_t DPPP_(my_my_strnlen)(const char *str, Size_t maxlen) { const char *p = str; while(maxlen-- && *p) p++; return p - str; } #endif #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 memEQs #define memEQs(s1, l, s2) \ (sizeof(s2)-1 == l && memEQ(s1, (s2 ""), (sizeof(s2)-1))) #endif #ifndef memNEs #define memNEs(s1, l, s2) !memEQs(s1, l, s2) #endif #ifndef memCHRs #define memCHRs(s, c) ((const char *) memchr("" s "" , c, sizeof(s)-1)) #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 #ifdef NEED_mess_sv #define NEED_mess #endif #ifdef NEED_mess #define NEED_mess_nocontext #define NEED_vmess #endif #ifndef croak_sv #if (PERL_BCDVERSION >= 0x5007003) || ( (PERL_BCDVERSION >= 0x5006001) && (PERL_BCDVERSION < 0x5007000) ) #if ( (PERL_BCDVERSION >= 0x5008000) && (PERL_BCDVERSION < 0x5008009) ) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5010001) ) #define D_PPP_FIX_UTF8_ERRSV_FOR_SV(sv) \ STMT_START { \ SV *_errsv = ERRSV; \ SvFLAGS(_errsv) = (SvFLAGS(_errsv) & ~SVf_UTF8) | \ (SvFLAGS(sv) & SVf_UTF8); \ } STMT_END #else #define D_PPP_FIX_UTF8_ERRSV_FOR_SV(sv) STMT_START {} STMT_END #endif PERL_STATIC_INLINE void D_PPP_croak_sv(SV *sv) { dTHX; SV *_sv = (sv); if (SvROK(_sv)) { sv_setsv(ERRSV, _sv); croak(NULL); } else { D_PPP_FIX_UTF8_ERRSV_FOR_SV(_sv); croak("%" SVf, SVfARG(_sv)); } } #define croak_sv(sv) D_PPP_croak_sv(sv) #elif (PERL_BCDVERSION >= 0x5004000) #define croak_sv(sv) croak("%" SVf, SVfARG(sv)) #else #define croak_sv(sv) croak("%s", SvPV_nolen(sv)) #endif #endif #ifndef die_sv #if defined(NEED_die_sv) static OP * DPPP_(my_die_sv)(pTHX_ SV * baseex); static #else extern OP * DPPP_(my_die_sv)(pTHX_ SV * baseex); #endif #if defined(NEED_die_sv) || defined(NEED_die_sv_GLOBAL) #ifdef die_sv #undef die_sv #endif #define die_sv(a) DPPP_(my_die_sv)(aTHX_ a) #define Perl_die_sv DPPP_(my_die_sv) OP * DPPP_(my_die_sv)(pTHX_ SV *baseex) { croak_sv(baseex); return (OP *)NULL; } #endif #endif #ifndef warn_sv #if (PERL_BCDVERSION >= 0x5004000) #define warn_sv(sv) warn("%" SVf, SVfARG(sv)) #else #define warn_sv(sv) warn("%s", SvPV_nolen(sv)) #endif #endif #if ! defined vmess && (PERL_BCDVERSION >= 0x5004000) #if defined(NEED_vmess) static SV * DPPP_(my_vmess)(pTHX_ const char * pat, va_list * args); static #else extern SV * DPPP_(my_vmess)(pTHX_ const char * pat, va_list * args); #endif #if defined(NEED_vmess) || defined(NEED_vmess_GLOBAL) #ifdef vmess #undef vmess #endif #define vmess(a,b) DPPP_(my_vmess)(aTHX_ a,b) #define Perl_vmess DPPP_(my_vmess) SV* DPPP_(my_vmess)(pTHX_ const char* pat, va_list* args) { mess(pat, args); return PL_mess_sv; } #endif #endif #if (PERL_BCDVERSION < 0x5006000) && (PERL_BCDVERSION >= 0x5004000) #undef mess #endif #if !defined(mess_nocontext) && !defined(Perl_mess_nocontext) && (PERL_BCDVERSION >= 0x5004000) #if defined(NEED_mess_nocontext) static SV * DPPP_(my_mess_nocontext)(const char * pat, ...); static #else extern SV * DPPP_(my_mess_nocontext)(const char * pat, ...); #endif #if defined(NEED_mess_nocontext) || defined(NEED_mess_nocontext_GLOBAL) #define mess_nocontext DPPP_(my_mess_nocontext) #define Perl_mess_nocontext DPPP_(my_mess_nocontext) SV* DPPP_(my_mess_nocontext)(const char* pat, ...) { dTHX; SV *sv; va_list args; va_start(args, pat); sv = vmess(pat, &args); va_end(args); return sv; } #endif #endif #ifndef mess #if defined(NEED_mess) static SV * DPPP_(my_mess)(pTHX_ const char * pat, ...); static #else extern SV * DPPP_(my_mess)(pTHX_ const char * pat, ...); #endif #if defined(NEED_mess) || defined(NEED_mess_GLOBAL) #define Perl_mess DPPP_(my_mess) SV* DPPP_(my_mess)(pTHX_ const char* pat, ...) { SV *sv; va_list args; va_start(args, pat); sv = vmess(pat, &args); va_end(args); return sv; } #ifdef mess_nocontext #define mess mess_nocontext #else #define mess Perl_mess_nocontext #endif #endif #endif #if ! defined mess_sv && (PERL_BCDVERSION >= 0x5004000) #if defined(NEED_mess_sv) static SV * DPPP_(my_mess_sv)(pTHX_ SV * basemsg, bool consume); static #else extern SV * DPPP_(my_mess_sv)(pTHX_ SV * basemsg, bool consume); #endif #if defined(NEED_mess_sv) || defined(NEED_mess_sv_GLOBAL) #ifdef mess_sv #undef mess_sv #endif #define mess_sv(a,b) DPPP_(my_mess_sv)(aTHX_ a,b) #define Perl_mess_sv DPPP_(my_mess_sv) SV * DPPP_(my_mess_sv)(pTHX_ SV *basemsg, bool consume) { SV *tmp; SV *ret; if (SvPOK(basemsg) && SvCUR(basemsg) && *(SvEND(basemsg)-1) == '\n') { if (consume) return basemsg; ret = mess(""); SvSetSV_nosteal(ret, basemsg); return ret; } if (consume) { sv_catsv(basemsg, mess("")); return basemsg; } ret = mess(""); tmp = newSVsv(ret); SvSetSV_nosteal(ret, basemsg); sv_catsv(ret, tmp); sv_dec(tmp); return ret; } #endif #endif #ifndef warn_nocontext #define warn_nocontext warn #endif #ifndef croak_nocontext #define croak_nocontext croak #endif #ifndef croak_no_modify #define croak_no_modify() croak_nocontext("%s", PL_no_modify) #define Perl_croak_no_modify() croak_no_modify() #endif #ifndef croak_memory_wrap #if (PERL_BCDVERSION >= 0x5009002) || ( (PERL_BCDVERSION >= 0x5008006) && (PERL_BCDVERSION < 0x5009000) ) #define croak_memory_wrap() croak_nocontext("%s", PL_memory_wrap) #else #define croak_memory_wrap() croak_nocontext("panic: memory wrap") #endif #endif #ifndef croak_xs_usage #if defined(NEED_croak_xs_usage) static void DPPP_(my_croak_xs_usage)(const CV * const cv, const char * const params); static #else extern void DPPP_(my_croak_xs_usage)(const CV * const cv, const char * const params); #endif #if defined(NEED_croak_xs_usage) || defined(NEED_croak_xs_usage_GLOBAL) #define croak_xs_usage DPPP_(my_croak_xs_usage) #define Perl_croak_xs_usage DPPP_(my_croak_xs_usage) #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE #define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params) void DPPP_(my_croak_xs_usage)(const CV *const cv, const char *const params) { dTHX; const GV *const gv = CvGV(cv); PERL_ARGS_ASSERT_CROAK_XS_USAGE; if (gv) { const char *const gvname = GvNAME(gv); const HV *const stash = GvSTASH(gv); const char *const hvname = stash ? HvNAME(stash) : NULL; if (hvname) croak("Usage: %s::%s(%s)", hvname, gvname, params); else croak("Usage: %s(%s)", gvname, params); } else { croak("Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params); } } #endif #endif #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 #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 #if (PERL_BCDVERSION >= 0x5003098) && (PERL_BCDVERSION < 0x5006000) #ifndef eval_pv #define eval_pv perl_eval_pv #endif #endif #if (PERL_BCDVERSION < 0x5006000) #ifndef Perl_eval_sv #define Perl_eval_sv perl_eval_sv #endif #if (PERL_BCDVERSION >= 0x5003098) #ifndef Perl_eval_pv #define Perl_eval_pv perl_eval_pv #endif #endif #endif #ifndef G_LIST #define G_LIST G_ARRAY #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 #if defined(PERL_USE_GCC_BRACE_GROUPS) #define D_PPP_CROAK_IF_ERROR(cond) ({ \ SV *_errsv; \ ( (cond) \ && (_errsv = ERRSV) \ && (SvROK(_errsv) || SvTRUE(_errsv)) \ && (croak_sv(_errsv), 1)); \ }) #else PERL_STATIC_INLINE void D_PPP_CROAK_IF_ERROR(int cond) { dTHX; SV *errsv; if (!cond) return; errsv = ERRSV; if (SvROK(errsv) || SvTRUE(errsv)) croak_sv(errsv); } #define D_PPP_CROAK_IF_ERROR(cond) D_PPP_CROAK_IF_ERROR(cond) #endif #ifndef G_METHOD #define G_METHOD 64 #ifdef call_sv #undef call_sv #endif #if (PERL_BCDVERSION < 0x5006000) #define call_sv(sv, flags) ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \ (flags) & ~G_METHOD) : perl_call_sv(sv, flags)) #else #define call_sv(sv, flags) ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \ (flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags)) #endif #endif #ifndef G_RETHROW #define G_RETHROW 8192 #ifdef eval_sv #undef eval_sv #endif #if defined(PERL_USE_GCC_BRACE_GROUPS) #define eval_sv(sv, flags) ({ I32 _flags = (flags); I32 _ret = Perl_eval_sv(aTHX_ sv, (_flags & ~G_RETHROW)); D_PPP_CROAK_IF_ERROR(_flags & G_RETHROW); _ret; }) #else #define eval_sv(sv, flags) ((PL_na = Perl_eval_sv(aTHX_ sv, ((flags) & ~G_RETHROW))), D_PPP_CROAK_IF_ERROR((flags) & G_RETHROW), (I32)PL_na) #endif #endif #if (PERL_BCDVERSION < 0x5031002) #ifdef eval_pv #undef eval_pv #if defined(PERL_USE_GCC_BRACE_GROUPS) #define eval_pv(p, croak_on_error) ({ SV *_sv = Perl_eval_pv(aTHX_ p, 0); D_PPP_CROAK_IF_ERROR(croak_on_error); _sv; }) #else #define eval_pv(p, croak_on_error) ((PL_Sv = Perl_eval_pv(aTHX_ p, 0)), D_PPP_CROAK_IF_ERROR(croak_on_error), PL_Sv) #endif #endif #endif #ifndef eval_pv #if defined(NEED_eval_pv) static SV * DPPP_(my_eval_pv)(const char * p, I32 croak_on_error); static #else extern SV * DPPP_(my_eval_pv)(const char * p, I32 croak_on_error); #endif #if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL) #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) SV* DPPP_(my_eval_pv)(const 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; D_PPP_CROAK_IF_ERROR(croak_on_error); return sv; } #endif #endif #if ! defined(vload_module) && defined(start_subparse) #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 #if defined(NEED_vload_module) || defined(NEED_vload_module_GLOBAL) #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) 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); 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; utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), #if (PERL_BCDVERSION > 0x5003000) veop, #endif modname, imop); 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 #if defined(NEED_load_module) || defined(NEED_load_module_GLOBAL) #ifdef load_module #undef load_module #endif #define load_module DPPP_(my_load_module) #define Perl_load_module DPPP_(my_load_module) 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) #endif #ifndef newRV_noinc #if defined(PERL_USE_GCC_BRACE_GROUPS) #define newRV_noinc(sv) ({ SV *_sv = (SV *)newRV((sv)); SvREFCNT_dec((sv)); _sv; }) #else #define newRV_noinc(sv) ((PL_Sv = (SV *)newRV((sv))), SvREFCNT_dec((sv)), PL_Sv) #endif #endif #if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) #ifndef START_MY_CXT #define START_MY_CXT #if (PERL_BCDVERSION < 0x5004068) #define dMY_CXT_SV \ SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE) #else #define dMY_CXT_SV \ SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ sizeof(MY_CXT_KEY)-1, TRUE) #endif #define dMY_CXT \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) #define MY_CXT_INIT \ dMY_CXT_SV; \ \ 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)) #define MY_CXT (*my_cxtp) #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 #ifndef MY_CXT_CLONE #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 #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 #ifndef MY_CXT_CLONE #define MY_CXT_CLONE NOOP #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 newSV_type #if defined(PERL_USE_GCC_BRACE_GROUPS) #define newSV_type(t) ({ SV *_sv = newSV(0); sv_upgrade(_sv, (t)); _sv; }) #else #define newSV_type(t) ((PL_Sv = newSV(0)), sv_upgrade(PL_Sv, (t)), PL_Sv) #endif #endif #if (PERL_BCDVERSION < 0x5006000) #define D_PPP_CONSTPV_ARG(x) ((char *) (x)) #else #define D_PPP_CONSTPV_ARG(x) (x) #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(PERL_USE_GCC_BRACE_GROUPS) #define newSVpvn_flags(s, len, flags) \ ({ \ SV * sv = newSVpvn(D_PPP_CONSTPV_ARG(s), (len)); \ SvFLAGS(sv) |= ((flags) & SVf_UTF8); \ if ((flags) & SVs_TEMP) sv = sv_2mortal(sv); \ sv; \ }) #else PERL_STATIC_INLINE SV* D_PPP_newSVpvn_flags(const char *const s, const STRLEN len, const U32 flags) { dTHX; SV * sv = newSVpvn(s, len); SvFLAGS(sv) |= (flags & SVf_UTF8); if (flags & SVs_TEMP) return sv_2mortal(sv); return sv; } #define newSVpvn_flags(s, len, flags) D_PPP_newSVpvn_flags((s), (len), (flags)) #endif #endif #ifndef SV_NOSTEAL #define SV_NOSTEAL 16 #endif #if ( (PERL_BCDVERSION >= 0x5007003) && (PERL_BCDVERSION < 0x5008007) ) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009002) ) #undef sv_setsv_flags #if defined(PERL_USE_GCC_BRACE_GROUPS) #define sv_setsv_flags(dstr, sstr, flags) \ STMT_START { \ if (((flags) & SV_NOSTEAL) && (sstr) && (SvFLAGS((SV *)(sstr)) & SVs_TEMP)) { \ SvTEMP_off((SV *)(sstr)); \ Perl_sv_setsv_flags(aTHX_ (dstr), (sstr), (flags) & ~SV_NOSTEAL); \ SvTEMP_on((SV *)(sstr)); \ } else { \ Perl_sv_setsv_flags(aTHX_ (dstr), (sstr), (flags) & ~SV_NOSTEAL); \ } \ } STMT_END #else #define sv_setsv_flags(dstr, sstr, flags) \ ( \ (((flags) & SV_NOSTEAL) && (sstr) && (SvFLAGS((SV *)(sstr)) & SVs_TEMP)) ? ( \ SvTEMP_off((SV *)(sstr)), \ Perl_sv_setsv_flags(aTHX_ (dstr), (sstr), (flags) & ~SV_NOSTEAL), \ SvTEMP_on((SV *)(sstr)), \ 1 \ ) : ( \ Perl_sv_setsv_flags(aTHX_ (dstr), (sstr), (flags) & ~SV_NOSTEAL), \ 1 \ ) \ ) #endif #endif #if defined(PERL_USE_GCC_BRACE_GROUPS) #ifndef sv_setsv_flags #define sv_setsv_flags(dstr, sstr, flags) \ STMT_START { \ if (((flags) & SV_NOSTEAL) && (sstr) && (SvFLAGS((SV *)(sstr)) & SVs_TEMP)) { \ SvTEMP_off((SV *)(sstr)); \ if (!((flags) & SV_GMAGIC) && (sstr) && SvGMAGICAL((SV *)(sstr))) { \ SvGMAGICAL_off((SV *)(sstr)); \ sv_setsv((dstr), (sstr)); \ SvGMAGICAL_on((SV *)(sstr)); \ } else { \ sv_setsv((dstr), (sstr)); \ } \ SvTEMP_on((SV *)(sstr)); \ } else { \ if (!((flags) & SV_GMAGIC) && (sstr) && SvGMAGICAL((SV *)(sstr))) { \ SvGMAGICAL_off((SV *)(sstr)); \ sv_setsv((dstr), (sstr)); \ SvGMAGICAL_on((SV *)(sstr)); \ } else { \ sv_setsv((dstr), (sstr)); \ } \ } \ } STMT_END #endif #else #ifndef sv_setsv_flags #define sv_setsv_flags(dstr, sstr, flags) \ ( \ (((flags) & SV_NOSTEAL) && (sstr) && (SvFLAGS((SV *)(sstr)) & SVs_TEMP)) ? ( \ SvTEMP_off((SV *)(sstr)), \ (!((flags) & SV_GMAGIC) && (sstr) && SvGMAGICAL((SV *)(sstr))) ? ( \ SvGMAGICAL_off((SV *)(sstr)), \ sv_setsv((dstr), (sstr)), \ SvGMAGICAL_on((SV *)(sstr)), \ 1 \ ) : ( \ sv_setsv((dstr), (sstr)), \ 1 \ ), \ SvTEMP_on((SV *)(sstr)), \ 1 \ ) : ( \ (!((flags) & SV_GMAGIC) && (sstr) && SvGMAGICAL((SV *)(sstr))) ? ( \ SvGMAGICAL_off((SV *)(sstr)), \ sv_setsv((dstr), (sstr)), \ SvGMAGICAL_on((SV *)(sstr)), \ 1 \ ) : ( \ sv_setsv((dstr), (sstr)), \ 1 \ ) \ ) \ ) #endif #endif #ifndef newSVsv_flags #if defined(PERL_USE_GCC_BRACE_GROUPS) #define newSVsv_flags(sv, flags) \ ({ \ SV *n= newSV(0); \ sv_setsv_flags(n, (sv), (flags)); \ n; \ }) #else PERL_STATIC_INLINE SV* D_PPP_newSVsv_flags(SV *const old, I32 flags) { dTHX; SV *n= newSV(0); sv_setsv_flags(n, old, flags); return n; } #define newSVsv_flags(sv, flags) D_PPP_newSVsv_flags(sv, flags) #endif #endif #ifndef newSVsv_nomg #define newSVsv_nomg(sv) newSVsv_flags((sv), SV_NOSTEAL) #endif #if (PERL_BCDVERSION >= 0x5017005) #ifndef sv_mortalcopy_flags #define sv_mortalcopy_flags(sv, flags) Perl_sv_mortalcopy_flags(aTHX_ (sv), (flags)) #endif #else #ifndef sv_mortalcopy_flags #define sv_mortalcopy_flags(sv, flags) sv_2mortal(newSVsv_flags((sv), (flags))) #endif #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 #ifndef newSVpvn_share #if defined(NEED_newSVpvn_share) static SV * DPPP_(my_newSVpvn_share)(pTHX_ const char * s, I32 len, U32 hash); static #else extern SV * DPPP_(my_newSVpvn_share)(pTHX_ const char * s, I32 len, U32 hash); #endif #if defined(NEED_newSVpvn_share) || defined(NEED_newSVpvn_share_GLOBAL) #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) SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *s, I32 len, U32 hash) { SV *sv; if (len < 0) len = -len; if (!hash) PERL_HASH(hash, (char*) s, len); sv = newSVpvn((char *) s, 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 HvNAME_get #define HvNAME_get(hv) HvNAME(hv) #endif #ifndef HvNAMELEN_get #define HvNAMELEN_get(hv) (HvNAME_get(hv) ? (I32)strlen(HvNAME_get(hv)) : 0) #endif #if (PERL_BCDVERSION >= 0x5009002) && (PERL_BCDVERSION <= 0x5009003) #undef gv_fetchpvn_flags #endif #ifdef GV_NOADD_MASK #define D_PPP_GV_NOADD_MASK GV_NOADD_MASK #else #define D_PPP_GV_NOADD_MASK 0xE0 #endif #ifndef gv_fetchpvn_flags #define gv_fetchpvn_flags(name, len, flags, sv_type) gv_fetchpv(SvPVX(sv_2mortal(newSVpvn((name), (len)))), ((flags) & D_PPP_GV_NOADD_MASK) ? FALSE : TRUE, (I32)(sv_type)) #endif #ifndef GvSVn #define GvSVn(gv) GvSV(gv) #endif #ifndef isGV_with_GP #define isGV_with_GP(gv) isGV(gv) #endif #ifndef gv_fetchsv #define gv_fetchsv(name, flags, svt) gv_fetchpv(SvPV_nolen_const(name), flags, svt) #endif #ifndef get_cvn_flags #define get_cvn_flags(name, namelen, flags) get_cv(name, flags) #endif #ifndef gv_init_pvn #define gv_init_pvn(gv, stash, ptr, len, flags) gv_init(gv, stash, ptr, len, flags & GV_ADDMULTI ? TRUE : FALSE) #endif #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 newSVpvs_share #define newSVpvs_share(str) newSVpvn_share(str "", sizeof(str) - 1, 0) #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 gv_fetchpvs #define gv_fetchpvs(name, flags, svt) gv_fetchpvn_flags(name "", sizeof(name) - 1, flags, svt) #endif #ifndef gv_stashpvs #define gv_stashpvs(name, flags) gv_stashpvn(name "", sizeof(name) - 1, flags) #endif #ifndef get_cvs #define get_cvs(name, flags) get_cvn_flags(name "", sizeof(name)-1, flags) #endif #undef SvGETMAGIC #ifndef SvGETMAGIC #define SvGETMAGIC(x) ((void)(UNLIKELY(SvGMAGICAL(x)) && mg_get(x))) #endif #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 #ifdef SVf_IVisUV #if defined(PERL_USE_GCC_BRACE_GROUPS) #ifndef SvIV_nomg #define SvIV_nomg(sv) (!SvGMAGICAL((sv)) ? SvIV((sv)) : ({ SV *_sviv = sv_mortalcopy_flags((sv), SV_NOSTEAL); IV _iv = SvIV(_sviv); SvFLAGS((sv)) = (SvFLAGS((sv)) & ~SVf_IVisUV) | (SvFLAGS(_sviv) & SVf_IVisUV); _iv; })) #endif #ifndef SvUV_nomg #define SvUV_nomg(sv) (!SvGMAGICAL((sv)) ? SvUV((sv)) : ({ SV *_svuv = sv_mortalcopy_flags((sv), SV_NOSTEAL); UV _uv = SvUV(_svuv); SvFLAGS((sv)) = (SvFLAGS((sv)) & ~SVf_IVisUV) | (SvFLAGS(_svuv) & SVf_IVisUV); _uv; })) #endif #else #ifndef SvIV_nomg #define SvIV_nomg(sv) (!SvGMAGICAL((sv)) ? SvIV((sv)) : ((PL_Sv = sv_mortalcopy_flags((sv), SV_NOSTEAL)), sv_upgrade(PL_Sv, SVt_PVIV), (SvIVX(PL_Sv) = SvIV(PL_Sv)), (SvFLAGS((sv)) = (SvFLAGS((sv)) & ~SVf_IVisUV) | (SvFLAGS(PL_Sv) & SVf_IVisUV)), SvIVX(PL_Sv))) #endif #ifndef SvUV_nomg #define SvUV_nomg(sv) (!SvGMAGICAL((sv)) ? SvIV((sv)) : ((PL_Sv = sv_mortalcopy_flags((sv), SV_NOSTEAL)), sv_upgrade(PL_Sv, SVt_PVIV), (SvUVX(PL_Sv) = SvUV(PL_Sv)), (SvFLAGS((sv)) = (SvFLAGS((sv)) & ~SVf_IVisUV) | (SvFLAGS(PL_Sv) & SVf_IVisUV)), SvUVX(PL_Sv))) #endif #endif #else #ifndef SvIV_nomg #define SvIV_nomg(sv) (!SvGMAGICAL((sv)) ? SvIV((sv)) : SvIVx(sv_mortalcopy_flags((sv), SV_NOSTEAL))) #endif #ifndef SvUV_nomg #define SvUV_nomg(sv) (!SvGMAGICAL((sv)) ? SvUV((sv)) : SvUVx(sv_mortalcopy_flags((sv), SV_NOSTEAL))) #endif #endif #ifndef SvNV_nomg #define SvNV_nomg(sv) (!SvGMAGICAL((sv)) ? SvNV((sv)) : SvNVx(sv_mortalcopy_flags((sv), SV_NOSTEAL))) #endif #ifndef SvTRUE_nomg #define SvTRUE_nomg(sv) (!SvGMAGICAL((sv)) ? SvTRUE((sv)) : SvTRUEx(sv_mortalcopy_flags((sv), SV_NOSTEAL))) #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 #if (PERL_BCDVERSION < 0x5004000) #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; \ 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 #if !defined(mg_findext) #if defined(NEED_mg_findext) static MAGIC * DPPP_(my_mg_findext)(const SV * sv, int type, const MGVTBL * vtbl); static #else extern MAGIC * DPPP_(my_mg_findext)(const SV * sv, int type, const MGVTBL * vtbl); #endif #if defined(NEED_mg_findext) || defined(NEED_mg_findext_GLOBAL) #define mg_findext DPPP_(my_mg_findext) #define Perl_mg_findext DPPP_(my_mg_findext) MAGIC * DPPP_(my_mg_findext)(const SV * sv, int type, const MGVTBL *vtbl) { if (sv) { MAGIC *mg; #ifdef AvPAD_NAMELIST assert(!(SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv))); #endif for (mg = SvMAGIC (sv); mg; mg = mg->mg_moremagic) { if (mg->mg_type == type && mg->mg_virtual == vtbl) return mg; } } return NULL; } #endif #endif #if !defined(sv_unmagicext) #if defined(NEED_sv_unmagicext) static int DPPP_(my_sv_unmagicext)(pTHX_ SV * const sv, const int type, const MGVTBL * vtbl); static #else extern int DPPP_(my_sv_unmagicext)(pTHX_ SV * const sv, const int type, const MGVTBL * vtbl); #endif #if defined(NEED_sv_unmagicext) || defined(NEED_sv_unmagicext_GLOBAL) #ifdef sv_unmagicext #undef sv_unmagicext #endif #define sv_unmagicext(a,b,c) DPPP_(my_sv_unmagicext)(aTHX_ a,b,c) #define Perl_sv_unmagicext DPPP_(my_sv_unmagicext) int DPPP_(my_sv_unmagicext)(pTHX_ SV *const sv, const int type, const MGVTBL *vtbl) { MAGIC* mg; MAGIC** mgp; if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv)) return 0; mgp = &(SvMAGIC(sv)); for (mg = *mgp; mg; mg = *mgp) { const MGVTBL* const virt = mg->mg_virtual; if (mg->mg_type == type && virt == vtbl) { *mgp = mg->mg_moremagic; if (virt && virt->svt_free) virt->svt_free(aTHX_ sv, mg); if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { if (mg->mg_len > 0) Safefree(mg->mg_ptr); else if (mg->mg_len == HEf_SVKEY) SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr)); else if (mg->mg_type == PERL_MAGIC_utf8) Safefree(mg->mg_ptr); } if (mg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(mg->mg_obj); Safefree(mg); } else mgp = &mg->mg_moremagic; } if (SvMAGIC(sv)) { if (SvMAGICAL(sv)) mg_magical(sv); } else { SvMAGICAL_off(sv); SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; } return 0; } #endif #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 #if (PERL_BCDVERSION >= 0x5006000) #ifndef caller_cx #if defined(NEED_caller_cx) || defined(NEED_caller_cx_GLOBAL) static I32 DPPP_dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) { I32 i; for (i = startingblock; i >= 0; i--) { const PERL_CONTEXT * const cx = &cxstk[i]; switch (CxTYPE(cx)) { default: continue; case CXt_EVAL: case CXt_SUB: case CXt_FORMAT: return i; } } return i; } #endif #if defined(NEED_caller_cx) static const PERL_CONTEXT * DPPP_(my_caller_cx)(pTHX_ I32 level, const PERL_CONTEXT * * dbcxp); static #else extern const PERL_CONTEXT * DPPP_(my_caller_cx)(pTHX_ I32 level, const PERL_CONTEXT * * dbcxp); #endif #if defined(NEED_caller_cx) || defined(NEED_caller_cx_GLOBAL) #ifdef caller_cx #undef caller_cx #endif #define caller_cx(a,b) DPPP_(my_caller_cx)(aTHX_ a,b) #define Perl_caller_cx DPPP_(my_caller_cx) const PERL_CONTEXT * DPPP_(my_caller_cx)(pTHX_ I32 level, const PERL_CONTEXT **dbcxp) { I32 cxix = DPPP_dopoptosub_at(cxstack, cxstack_ix); const PERL_CONTEXT *cx; const PERL_CONTEXT *ccstack = cxstack; const PERL_SI *top_si = PL_curstackinfo; for (;;) { while (cxix < 0 && top_si->si_type != PERLSI_MAIN) { top_si = top_si->si_prev; ccstack = top_si->si_cxstack; cxix = DPPP_dopoptosub_at(ccstack, top_si->si_cxix); } if (cxix < 0) return NULL; if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub)) level++; if (!level--) break; cxix = DPPP_dopoptosub_at(ccstack, cxix - 1); } cx = &ccstack[cxix]; if (dbcxp) *dbcxp = cx; if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { const I32 dbcxix = DPPP_dopoptosub_at(ccstack, cxix - 1); if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) cx = &ccstack[dbcxix]; } return cx; } #endif #endif #endif #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 #if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL) #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) 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 #include dTHR; 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 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 #if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL) #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) 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; if (isDIGIT(*s)) { UV value = *s - '0'; 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) { 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)) { 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)) s++; } } else if (GROK_NUMERIC_RADIX(&s, send)) { numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; if (s < send && isDIGIT(*s)) { do { s++; } while (s < send && isDIGIT(*s)); if (valuep) { *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') { 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; numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; } else if (sawnan) { numtype &= IS_NUMBER_NEG; numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; } else if (s < send) { if (*s == 'e' || *s == 'E') { 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 #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 #if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL) #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) 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)) { 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') { redo: if (!overflowed) { if (value <= max_div_2) { value = (value << 1) | (bit - '0'); continue; } warn("Integer overflow in binary number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 2.0; 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 #if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL) #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) 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)) { 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) { 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; 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 #if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL) #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) 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++) { int digit = *s - '0'; if (digit >= 0 && digit <= 7) { redo: if (!overflowed) { if (value <= max_div_8) { value = (value << 3) | digit; continue; } warn("Integer overflow in octal number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 8.0; value_nv += (NV)digit; continue; } if (digit == ('_' - '0') && len && allow_underscores && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) { --len; ++s; goto redo; } 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 #if defined(NEED_my_snprintf) || defined(NEED_my_snprintf_GLOBAL) #define my_snprintf DPPP_(my_my_snprintf) #define Perl_my_snprintf DPPP_(my_my_snprintf) 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 < 0 || (len > 0 && (Size_t)retval >= len)) Perl_croak(aTHX_ "panic: my_snprintf buffer overflow"); return retval; } #endif #endif #if !defined(my_sprintf) #if defined(NEED_my_sprintf) static int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); static #else extern int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); #endif #if defined(NEED_my_sprintf) || defined(NEED_my_sprintf_GLOBAL) #define my_sprintf DPPP_(my_my_sprintf) int DPPP_(my_my_sprintf)(char *buffer, const char* pat, ...) { va_list args; va_start(args, pat); vsprintf(buffer, pat, args); va_end(args); return strlen(buffer); } #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 #if defined(NEED_my_strlcat) || defined(NEED_my_strlcat_GLOBAL) #define my_strlcat DPPP_(my_my_strlcat) #define Perl_my_strlcat DPPP_(my_my_strlcat) 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 #if defined(NEED_my_strlcpy) || defined(NEED_my_strlcpy_GLOBAL) #define my_strlcpy DPPP_(my_my_strlcpy) #define Perl_my_strlcpy DPPP_(my_my_strlcpy) 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 #ifdef SVf_UTF8 #ifndef SvUTF8 #define SvUTF8(sv) (SvFLAGS(sv) & SVf_UTF8) #endif #endif #if (PERL_BCDVERSION == 0x5019001) #undef UTF8f #endif #ifdef SVf_UTF8 #ifndef UTF8f #define UTF8f SVf #endif #ifndef UTF8fARG #define UTF8fARG(u,l,p) newSVpvn_flags((p), (l), ((u) ? SVf_UTF8 : 0) | SVs_TEMP) #endif #endif #define D_PPP_MIN(a,b) (((a) <= (b)) ? (a) : (b)) #ifndef UNICODE_REPLACEMENT #define UNICODE_REPLACEMENT 0xFFFD #endif #ifdef UTF8_MAXLEN #ifndef UTF8_MAXBYTES #define UTF8_MAXBYTES UTF8_MAXLEN #endif #endif #ifndef UTF_START_MARK #define UTF_START_MARK(len) \ (((len) > 7) ? 0xFF : (0xFF & (0xFE << (7-(len))))) #endif #if (PERL_BCDVERSION < 0x5018000) #undef UTF8_MAXBYTES_CASE #endif #if 'A' == 65 #define D_PPP_BYTE_INFO_BITS 6 #ifndef UTF8_MAXBYTES_CASE #define UTF8_MAXBYTES_CASE 13 #endif #else #define D_PPP_BYTE_INFO_BITS 5 #ifndef UTF8_MAXBYTES_CASE #define UTF8_MAXBYTES_CASE 15 #endif #endif #ifndef UTF_ACCUMULATION_SHIFT #define UTF_ACCUMULATION_SHIFT D_PPP_BYTE_INFO_BITS #endif #ifdef NATIVE_TO_UTF #ifndef NATIVE_UTF8_TO_I8 #define NATIVE_UTF8_TO_I8(c) NATIVE_TO_UTF(c) #endif #else #ifndef NATIVE_UTF8_TO_I8 #define NATIVE_UTF8_TO_I8(c) (c) #endif #endif #ifdef UTF_TO_NATIVE #ifndef I8_TO_NATIVE_UTF8 #define I8_TO_NATIVE_UTF8(c) UTF_TO_NATIVE(c) #endif #else #ifndef I8_TO_NATIVE_UTF8 #define I8_TO_NATIVE_UTF8(c) (c) #endif #endif #ifndef UTF_START_MASK #define UTF_START_MASK(len) \ (((len) >= 7) ? 0x00 : (0x1F >> ((len)-2))) #endif #ifndef UTF_IS_CONTINUATION_MASK #define UTF_IS_CONTINUATION_MASK \ ((U8) (0xFF << UTF_ACCUMULATION_SHIFT)) #endif #ifndef UTF_CONTINUATION_MARK #define UTF_CONTINUATION_MARK \ (UTF_IS_CONTINUATION_MASK & 0xB0) #endif #ifndef UTF_MIN_START_BYTE #define UTF_MIN_START_BYTE \ ((UTF_CONTINUATION_MARK >> UTF_ACCUMULATION_SHIFT) | UTF_START_MARK(2)) #endif #ifndef UTF_MIN_ABOVE_LATIN1_BYTE #define UTF_MIN_ABOVE_LATIN1_BYTE \ ((0x100 >> UTF_ACCUMULATION_SHIFT) | UTF_START_MARK(2)) #endif #if (PERL_BCDVERSION < 0x5007000) #undef UTF8_IS_DOWNGRADEABLE_START #endif #ifndef UTF8_IS_DOWNGRADEABLE_START #define UTF8_IS_DOWNGRADEABLE_START(c) \ inRANGE(NATIVE_UTF8_TO_I8(c), \ UTF_MIN_START_BYTE, UTF_MIN_ABOVE_LATIN1_BYTE - 1) #endif #ifndef UTF_CONTINUATION_MASK #define UTF_CONTINUATION_MASK \ ((U8) ((1U << UTF_ACCUMULATION_SHIFT) - 1)) #endif #ifndef UTF8_ACCUMULATE #define UTF8_ACCUMULATE(base, added) \ (((base) << UTF_ACCUMULATION_SHIFT) \ | ((NATIVE_UTF8_TO_I8(added)) \ & UTF_CONTINUATION_MASK)) #endif #ifndef UTF8_ALLOW_ANYUV #define UTF8_ALLOW_ANYUV 0 #endif #ifndef UTF8_ALLOW_EMPTY #define UTF8_ALLOW_EMPTY 0x0001 #endif #ifndef UTF8_ALLOW_CONTINUATION #define UTF8_ALLOW_CONTINUATION 0x0002 #endif #ifndef UTF8_ALLOW_NON_CONTINUATION #define UTF8_ALLOW_NON_CONTINUATION 0x0004 #endif #ifndef UTF8_ALLOW_SHORT #define UTF8_ALLOW_SHORT 0x0008 #endif #ifndef UTF8_ALLOW_LONG #define UTF8_ALLOW_LONG 0x0010 #endif #ifndef UTF8_ALLOW_OVERFLOW #define UTF8_ALLOW_OVERFLOW 0x0080 #endif #ifndef UTF8_ALLOW_ANY #define UTF8_ALLOW_ANY ( UTF8_ALLOW_CONTINUATION \ |UTF8_ALLOW_NON_CONTINUATION \ |UTF8_ALLOW_SHORT \ |UTF8_ALLOW_LONG \ |UTF8_ALLOW_OVERFLOW) #endif #if defined UTF8SKIP #undef UTF8_SAFE_SKIP #undef UTF8_CHK_SKIP #ifndef UTF8_SAFE_SKIP #define UTF8_SAFE_SKIP(s, e) ( \ ((((e) - (s)) <= 0) \ ? 0 \ : D_PPP_MIN(((e) - (s)), UTF8SKIP(s)))) #endif #ifndef UTF8_CHK_SKIP #define UTF8_CHK_SKIP(s) \ (s[0] == '\0' ? 1 : ((U8) D_PPP_MIN(my_strnlen((char *) (s), UTF8SKIP(s)), \ UTF8SKIP(s)))) #endif #ifndef UTF8_SKIP #define UTF8_SKIP(s) UTF8SKIP(s) #endif #endif #if 'A' == 65 #ifndef UTF8_IS_INVARIANT #define UTF8_IS_INVARIANT(c) isASCII(c) #endif #else #ifndef UTF8_IS_INVARIANT #define UTF8_IS_INVARIANT(c) (isASCII(c) || isCNTRL_L1(c)) #endif #endif #ifndef UVCHR_IS_INVARIANT #define UVCHR_IS_INVARIANT(c) UTF8_IS_INVARIANT(c) #endif #ifdef UVCHR_IS_INVARIANT #if 'A' != 65 || UVSIZE < 8 #define D_PPP_UVCHR_SKIP_UPPER(c) 7 #else #define D_PPP_UVCHR_SKIP_UPPER(c) \ (((WIDEST_UTYPE) (c)) < \ (((WIDEST_UTYPE) 1) << (6 * D_PPP_BYTE_INFO_BITS)) ? 7 : 13) #endif #ifndef UVCHR_SKIP #define UVCHR_SKIP(c) \ UVCHR_IS_INVARIANT(c) ? 1 : \ (WIDEST_UTYPE) (c) < (32 * (1U << ( D_PPP_BYTE_INFO_BITS))) ? 2 : \ (WIDEST_UTYPE) (c) < (16 * (1U << (2 * D_PPP_BYTE_INFO_BITS))) ? 3 : \ (WIDEST_UTYPE) (c) < ( 8 * (1U << (3 * D_PPP_BYTE_INFO_BITS))) ? 4 : \ (WIDEST_UTYPE) (c) < ( 4 * (1U << (4 * D_PPP_BYTE_INFO_BITS))) ? 5 : \ (WIDEST_UTYPE) (c) < ( 2 * (1U << (5 * D_PPP_BYTE_INFO_BITS))) ? 6 : \ D_PPP_UVCHR_SKIP_UPPER(c) #endif #endif #ifdef is_ascii_string #ifndef is_invariant_string #define is_invariant_string(s,l) is_ascii_string(s,l) #endif #ifndef is_utf8_invariant_string #define is_utf8_invariant_string(s,l) is_ascii_string(s,l) #endif #endif #ifdef ibcmp_utf8 #ifndef foldEQ_utf8 #define foldEQ_utf8(s1,pe1,l1,u1,s2,pe2,l2,u2) \ cBOOL(! ibcmp_utf8(s1,pe1,l1,u1,s2,pe2,l2,u2)) #endif #endif #if defined(is_utf8_string) && defined(UTF8SKIP) #ifndef isUTF8_CHAR #define isUTF8_CHAR(s, e) ( \ (e) <= (s) || ! is_utf8_string(s, UTF8_SAFE_SKIP(s, e)) \ ? 0 \ : UTF8SKIP(s)) #endif #endif #if 'A' == 65 #ifndef BOM_UTF8 #define BOM_UTF8 "\xEF\xBB\xBF" #endif #ifndef REPLACEMENT_CHARACTER_UTF8 #define REPLACEMENT_CHARACTER_UTF8 "\xEF\xBF\xBD" #endif #elif '^' == 95 #ifndef BOM_UTF8 #define BOM_UTF8 "\xDD\x73\x66\x73" #endif #ifndef REPLACEMENT_CHARACTER_UTF8 #define REPLACEMENT_CHARACTER_UTF8 "\xDD\x73\x73\x71" #endif #elif '^' == 176 #ifndef BOM_UTF8 #define BOM_UTF8 "\xDD\x72\x65\x72" #endif #ifndef REPLACEMENT_CHARACTER_UTF8 #define REPLACEMENT_CHARACTER_UTF8 "\xDD\x72\x72\x70" #endif #else #error Unknown character set #endif #if (PERL_BCDVERSION < 0x5035010) #undef utf8_to_uvchr_buf #endif #if (PERL_BCDVERSION >= 0x5006001) && ! defined(utf8_to_uvchr_buf) #if defined(utf8n_to_uvchr) || defined(utf8_to_uvchr) || defined(utf8_to_uv) #if defined(utf8n_to_uvchr) #define D_PPP_utf8_to_uvchr_buf_callee utf8n_to_uvchr #elif \ defined(utf8_to_uv) && defined(utf8_to_uv_simple) #define D_PPP_utf8_to_uvchr_buf_callee utf8_to_uv #elif defined(utf8_to_uvchr) #define D_PPP_utf8_to_uvchr_buf_callee(s, curlen, retlen, flags) \ utf8_to_uvchr((U8 *)(s), (retlen)) #else #define D_PPP_utf8_to_uvchr_buf_callee(s, curlen, retlen, flags) \ utf8_to_uv((U8 *)(s), (retlen)) #endif #endif #if defined(NEED_utf8_to_uvchr_buf) static UV DPPP_(my_utf8_to_uvchr_buf)(pTHX_ const U8 * s, const U8 * send, STRLEN * retlen); static #else extern UV DPPP_(my_utf8_to_uvchr_buf)(pTHX_ const U8 * s, const U8 * send, STRLEN * retlen); #endif #if defined(NEED_utf8_to_uvchr_buf) || defined(NEED_utf8_to_uvchr_buf_GLOBAL) #ifdef utf8_to_uvchr_buf #undef utf8_to_uvchr_buf #endif #define utf8_to_uvchr_buf(a,b,c) DPPP_(my_utf8_to_uvchr_buf)(aTHX_ a,b,c) #define Perl_utf8_to_uvchr_buf DPPP_(my_utf8_to_uvchr_buf) UV DPPP_(my_utf8_to_uvchr_buf)(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen) { #if (PERL_BCDVERSION >= 0x5031004) #if (PERL_BCDVERSION != 0x5035009) if (send <= s) s = send = (U8 *) "?"; return Perl_utf8_to_uvchr_buf_helper(aTHX_ s, send, retlen); #else if (send > s) return Perl_utf8_to_uvchr_buf_helper(aTHX_ s, send, retlen); if (! ckWARN_d(WARN_UTF8)) { if (retlen) *retlen = 0; return UNICODE_REPLACEMENT; } else { s = send = (U8 *) "?"; (void) Perl__utf8n_to_uvchr_msgs_helper(s, 0, NULL, 0, NULL, NULL); if (retlen) *retlen = (STRLEN) -1; return 0; } #endif #else UV ret; STRLEN curlen; bool overflows = 0; const U8 *cur_s = s; const bool do_warnings = ckWARN_d(WARN_UTF8); #if (PERL_BCDVERSION < 0x5026000) && ! defined(EBCDIC) STRLEN overflow_length = 0; #endif if (send > s) { curlen = send - s; } else { assert(0); curlen = 0; if (! do_warnings) { if (retlen) *retlen = 0; return UNICODE_REPLACEMENT; } } #if (PERL_BCDVERSION < 0x5026000) && ! defined(EBCDIC) if (curlen > 0 && UNLIKELY(*s >= 0xFE)) { if (sizeof(ret) < 8) { overflows = 1; overflow_length = (*s == 0xFE) ? 7 : 13; } else { const U8 highest[] = "\xFF\x80\x87\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF"; const U8 *cur_h = highest; for (cur_s = s; cur_s < send; cur_s++, cur_h++) { if (UNLIKELY(*cur_s == *cur_h)) { continue; } overflows = *cur_s > *cur_h; break; } overflow_length = 13; } } if (UNLIKELY(overflows)) { ret = 0; if (! do_warnings && retlen) { *retlen = overflow_length; } } else #endif ret = D_PPP_utf8_to_uvchr_buf_callee( (U8 *) s, curlen, retlen, (UTF8_ALLOW_ANYUV & ~(UTF8_ALLOW_LONG|UTF8_ALLOW_EMPTY))); #if (PERL_BCDVERSION >= 0x5026000) && (PERL_BCDVERSION < 0x5028000) if (UNLIKELY(ret > IV_MAX)) { overflows = 1; } #endif if (UNLIKELY(overflows)) { if (! do_warnings) { if (retlen) { *retlen = D_PPP_MIN(*retlen, UTF8SKIP(s)); *retlen = D_PPP_MIN(*retlen, curlen); } return UNICODE_REPLACEMENT; } else { Perl_warner(aTHX_ packWARN(WARN_UTF8), "Malformed UTF-8 character (overflow at 0x%" UVxf ", byte 0x%02x, after start byte 0x%02x)", ret, *cur_s, *s); if (retlen) { *retlen = (STRLEN) -1; } return 0; } } if (UNLIKELY(ret == 0 && (curlen == 0 || *s != '\0'))) { if (do_warnings) { if (retlen) { *retlen = (STRLEN) -1; } } else { ret = D_PPP_utf8_to_uvchr_buf_callee( (U8 *) s, curlen, retlen, UTF8_ALLOW_ANY); ret = UNICODE_REPLACEMENT; #if (PERL_BCDVERSION < 0x5016000) if (retlen && (IV) *retlen >= 0) { unsigned int i = 1; *retlen = D_PPP_MIN(*retlen, curlen); *retlen = D_PPP_MIN(*retlen, UTF8SKIP(s)); do { #ifdef UTF8_IS_CONTINUATION if (! UTF8_IS_CONTINUATION(s[i])) #else if (s[i] < 0x80 || s[i] > 0xBF) #endif { *retlen = i; break; } } while (++i < *retlen); } #endif } } return ret; #endif } #endif #endif #if defined(UTF8SKIP) && defined(utf8_to_uvchr_buf) #undef utf8_to_uvchr #ifndef utf8_to_uvchr #define utf8_to_uvchr(s, lp) \ ((*(s) == '\0') \ ? utf8_to_uvchr_buf(s,((s)+1), lp) \ : utf8_to_uvchr_buf(s, (s) + UTF8_CHK_SKIP(s), (lp))) #endif #endif #ifdef sv_len_utf8 #if (PERL_BCDVERSION >= 0x5017005) #ifndef sv_len_utf8_nomg #if defined(PERL_USE_GCC_BRACE_GROUPS) #define sv_len_utf8_nomg(sv) \ ({ \ SV *sv_ = (sv); \ sv_len_utf8(!SvGMAGICAL(sv_) \ ? sv_ \ : sv_mortalcopy_flags(sv_, SV_NOSTEAL)); \ }) #else PERL_STATIC_INLINE STRLEN D_PPP_sv_len_utf8_nomg(SV * sv) { dTHX; if (SvGMAGICAL(sv)) return sv_len_utf8(sv_mortalcopy_flags(sv, SV_NOSTEAL)); else return sv_len_utf8(sv); } #define sv_len_utf8_nomg(sv) D_PPP_sv_len_utf8_nomg(sv) #endif #endif #else #undef sv_len_utf8 #if defined(PERL_USE_GCC_BRACE_GROUPS) #define sv_len_utf8_nomg(sv) \ ({ \ SV *sv2 = (sv); \ STRLEN len; \ if (SvUTF8(sv2)) { \ if (SvGMAGICAL(sv2)) \ len = Perl_sv_len_utf8(aTHX_ \ sv_mortalcopy_flags(sv2, \ SV_NOSTEAL));\ else \ len = Perl_sv_len_utf8(aTHX_ sv2); \ } \ else SvPV_nomg(sv2, len); \ len; \ }) #define sv_len_utf8(sv) ({ SV *_sv1 = (sv); \ SvGETMAGIC(_sv1); \ sv_len_utf8_nomg(_sv1); \ }) #else PERL_STATIC_INLINE STRLEN D_PPP_sv_len_utf8_nomg(SV * sv) { dTHX; STRLEN len; if (SvUTF8(sv)) { if (SvGMAGICAL(sv)) len = Perl_sv_len_utf8(aTHX_ sv_mortalcopy_flags(sv, SV_NOSTEAL)); else len = Perl_sv_len_utf8(aTHX_ sv); } else SvPV_nomg(sv, len); return len; } #define sv_len_utf8_nomg(sv) D_PPP_sv_len_utf8_nomg(sv) PERL_STATIC_INLINE STRLEN D_PPP_sv_len_utf8(SV * sv) { dTHX; SvGETMAGIC(sv); return sv_len_utf8_nomg(sv); } #define sv_len_utf8(sv) D_PPP_sv_len_utf8(sv) #endif #endif #endif #ifndef PERL_PV_ESCAPE_QUOTE #define PERL_PV_ESCAPE_QUOTE 0x0001 #endif #ifndef PERL_PV_PRETTY_QUOTE #define PERL_PV_PRETTY_QUOTE PERL_PV_ESCAPE_QUOTE #endif #ifndef PERL_PV_PRETTY_ELLIPSES #define PERL_PV_PRETTY_ELLIPSES 0x0002 #endif #ifndef PERL_PV_PRETTY_LTGT #define PERL_PV_PRETTY_LTGT 0x0004 #endif #ifndef PERL_PV_ESCAPE_FIRSTCHAR #define PERL_PV_ESCAPE_FIRSTCHAR 0x0008 #endif #ifndef PERL_PV_ESCAPE_UNI #define PERL_PV_ESCAPE_UNI 0x0100 #endif #ifndef PERL_PV_ESCAPE_UNI_DETECT #define PERL_PV_ESCAPE_UNI_DETECT 0x0200 #endif #ifndef PERL_PV_ESCAPE_ALL #define PERL_PV_ESCAPE_ALL 0x1000 #endif #ifndef PERL_PV_ESCAPE_NOBACKSLASH #define PERL_PV_ESCAPE_NOBACKSLASH 0x2000 #endif #ifndef PERL_PV_ESCAPE_NOCLEAR #define PERL_PV_ESCAPE_NOCLEAR 0x4000 #endif #ifndef PERL_PV_ESCAPE_RE #define PERL_PV_ESCAPE_RE 0x8000 #endif #ifndef PERL_PV_PRETTY_NOCLEAR #define PERL_PV_PRETTY_NOCLEAR PERL_PV_ESCAPE_NOCLEAR #endif #ifndef PERL_PV_PRETTY_DUMP #define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE #endif #ifndef PERL_PV_PRETTY_REGPROP #define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE #endif #ifndef pv_escape #if defined(NEED_pv_escape) static char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); static #else extern char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); #endif #if defined(NEED_pv_escape) || defined(NEED_pv_escape_GLOBAL) #ifdef pv_escape #undef pv_escape #endif #define pv_escape(a,b,c,d,e,f) DPPP_(my_pv_escape)(aTHX_ a,b,c,d,e,f) #define Perl_pv_escape DPPP_(my_pv_escape) char * DPPP_(my_pv_escape)(pTHX_ SV *dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags) { const char esc = flags & PERL_PV_ESCAPE_RE ? '%' : '\\'; const char dq = flags & PERL_PV_ESCAPE_QUOTE ? '"' : esc; char octbuf[32] = "%123456789ABCDF"; STRLEN wrote = 0; STRLEN chsize = 0; STRLEN readsize = 1; #if defined(is_utf8_string) && defined(utf8_to_uvchr_buf) bool isuni = flags & PERL_PV_ESCAPE_UNI ? 1 : 0; #endif const char *pv = str; const char * const end = pv + count; octbuf[0] = esc; if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) sv_setpvs(dsv, ""); #if defined(is_utf8_string) && defined(utf8_to_uvchr_buf) if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count)) isuni = 1; #endif for (; pv < end && (!max || wrote < max) ; pv += readsize) { const UV u = #if defined(is_utf8_string) && defined(utf8_to_uvchr_buf) isuni ? utf8_to_uvchr_buf((U8*)pv, end, &readsize) : #endif (U8)*pv; const U8 c = (U8)u & 0xFF; if (u > 255 || (flags & PERL_PV_ESCAPE_ALL)) { if (flags & PERL_PV_ESCAPE_FIRSTCHAR) chsize = my_snprintf(octbuf, sizeof octbuf, "%" UVxf, u); else chsize = my_snprintf(octbuf, sizeof octbuf, "%cx{%" UVxf "}", esc, u); } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) { chsize = 1; } else { if (c == dq || c == esc || !isPRINT(c)) { chsize = 2; switch (c) { case '\\' : case '%' : if (c == esc) octbuf[1] = esc; else chsize = 1; break; case '\v' : octbuf[1] = 'v'; break; case '\t' : octbuf[1] = 't'; break; case '\r' : octbuf[1] = 'r'; break; case '\n' : octbuf[1] = 'n'; break; case '\f' : octbuf[1] = 'f'; break; case '"' : if (dq == '"') octbuf[1] = '"'; else chsize = 1; break; default: chsize = my_snprintf(octbuf, sizeof octbuf, pv < end && isDIGIT((U8)*(pv+readsize)) ? "%c%03o" : "%c%o", esc, c); } } else { chsize = 1; } } if (max && wrote + chsize > max) { break; } else if (chsize > 1) { sv_catpvn(dsv, octbuf, chsize); wrote += chsize; } else { char tmp[2]; my_snprintf(tmp, sizeof tmp, "%c", c); sv_catpvn(dsv, tmp, 1); wrote++; } if (flags & PERL_PV_ESCAPE_FIRSTCHAR) break; } if (escaped != NULL) *escaped= pv - str; return SvPVX(dsv); } #endif #endif #ifndef pv_pretty #if defined(NEED_pv_pretty) static char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); static #else extern char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); #endif #if defined(NEED_pv_pretty) || defined(NEED_pv_pretty_GLOBAL) #ifdef pv_pretty #undef pv_pretty #endif #define pv_pretty(a,b,c,d,e,f,g) DPPP_(my_pv_pretty)(aTHX_ a,b,c,d,e,f,g) #define Perl_pv_pretty DPPP_(my_pv_pretty) char * DPPP_(my_pv_pretty)(pTHX_ SV *dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags) { const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%'; STRLEN escaped; if (!(flags & PERL_PV_PRETTY_NOCLEAR)) sv_setpvs(dsv, ""); if (dq == '"') sv_catpvs(dsv, "\""); else if (flags & PERL_PV_PRETTY_LTGT) sv_catpvs(dsv, "<"); if (start_color != NULL) sv_catpv(dsv, D_PPP_CONSTPV_ARG(start_color)); pv_escape(dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR); if (end_color != NULL) sv_catpv(dsv, D_PPP_CONSTPV_ARG(end_color)); if (dq == '"') sv_catpvs(dsv, "\""); else if (flags & PERL_PV_PRETTY_LTGT) sv_catpvs(dsv, ">"); if ((flags & PERL_PV_PRETTY_ELLIPSES) && escaped < count) sv_catpvs(dsv, "..."); return SvPVX(dsv); } #endif #endif #ifndef pv_display #if defined(NEED_pv_display) static char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); static #else extern char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); #endif #if defined(NEED_pv_display) || defined(NEED_pv_display_GLOBAL) #ifdef pv_display #undef pv_display #endif #define pv_display(a,b,c,d,e) DPPP_(my_pv_display)(aTHX_ a,b,c,d,e) #define Perl_pv_display DPPP_(my_pv_display) char * DPPP_(my_pv_display)(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim) { pv_pretty(dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP); if (len > cur && pv[cur] == '\0') sv_catpvs(dsv, "\\0"); return SvPVX(dsv); } #endif #endif #if PERL_VERSION_LT(5,27,9) #ifndef LC_NUMERIC_LOCK #define LC_NUMERIC_LOCK #endif #ifndef LC_NUMERIC_UNLOCK #define LC_NUMERIC_UNLOCK #endif #if PERL_VERSION_LT(5,19,0) #undef STORE_LC_NUMERIC_SET_STANDARD #undef RESTORE_LC_NUMERIC #undef DECLARATION_FOR_LC_NUMERIC_MANIPULATION #ifdef USE_LOCALE #ifndef DECLARATION_FOR_LC_NUMERIC_MANIPULATION #define DECLARATION_FOR_LC_NUMERIC_MANIPULATION char *LoC_ #endif #ifndef STORE_NUMERIC_SET_STANDARD #define STORE_NUMERIC_SET_STANDARD() \ LoC_ = savepv(setlocale(LC_NUMERIC, NULL)); \ SAVEFREEPV(LoC_); \ setlocale(LC_NUMERIC, "C"); #endif #ifndef RESTORE_LC_NUMERIC #define RESTORE_LC_NUMERIC() \ setlocale(LC_NUMERIC, LoC_); #endif #else #ifndef DECLARATION_FOR_LC_NUMERIC_MANIPULATION #define DECLARATION_FOR_LC_NUMERIC_MANIPULATION #endif #ifndef STORE_LC_NUMERIC_SET_STANDARD #define STORE_LC_NUMERIC_SET_STANDARD() #endif #ifndef RESTORE_LC_NUMERIC #define RESTORE_LC_NUMERIC() #endif #endif #endif #endif #ifndef LOCK_NUMERIC_STANDARD #define LOCK_NUMERIC_STANDARD() #endif #ifndef UNLOCK_NUMERIC_STANDARD #define UNLOCK_NUMERIC_STANDARD() #endif #ifndef LOCK_LC_NUMERIC_STANDARD #define LOCK_LC_NUMERIC_STANDARD LOCK_NUMERIC_STANDARD #endif #ifndef UNLOCK_LC_NUMERIC_STANDARD #define UNLOCK_LC_NUMERIC_STANDARD UNLOCK_NUMERIC_STANDARD #endif #ifndef switch_to_global_locale #define switch_to_global_locale() #endif #ifdef sync_locale #if (PERL_BCDVERSION < 0x5027009) #if (PERL_BCDVERSION >= 0x5021003) #undef sync_locale #define sync_locale() (Perl_sync_locale(aTHX), 1) #elif defined(sync_locale) #undef sync_locale #define sync_locale() (new_ctype(setlocale(LC_CTYPE, NULL)), \ new_collate(setlocale(LC_COLLATE, NULL)), \ set_numeric_local(), \ new_numeric(setlocale(LC_NUMERIC, NULL)), \ 1) #elif defined(new_ctype) && defined(LC_CTYPE) #define sync_locale() (new_ctype(setlocale(LC_CTYPE, NULL)), 1) #endif #endif #endif #ifndef sync_locale #define sync_locale() 1 #endif #endif PDL-2.085/Basic/Core/pdlaffine.c0000644000175000017500000003064014400765134016111 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]), 1) \ PDL_DECLARE_PARAMETER_BADVAL(ctype, (trans->vtable->per_pdl_flags[from_id]), from_pdl, (trans->pdls[from_id]), 1) \ 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<$PDL(CHILD)->ndims;i++) { $PRIV(incs)[i] = $COMP(sincs)[i]; $PDL(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_reallocbroadcastids(trans->pdls[1], trans->pdls[0]->nbroadcastids); for (i=0; ipdls[0]->nbroadcastids; i++) trans->pdls[1]->broadcastids[i] = trans->pdls[0]->broadcastids[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; PDLDEBUG_f(printf("pdl_converttypei_readdata %s=%p from parent: ", trans->vtable->name, trans); pdl_dump(trans->pdls[0])); #define X_OUTER(datatype_out, ctype_out, ...) \ PDL_DECLARE_PARAMETER_BADVAL(ctype_out, (trans->vtable->per_pdl_flags[1]), CHILD, (trans->pdls[1]), 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]), 1) \ 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; PDLDEBUG_f(printf("pdl_converttypei_writebackdata %s=%p from child: ", trans->vtable->name, trans); pdl_dump(trans->pdls[1])); #define X_INNER(datatype_in, ctype_in, ...) \ PDL_DECLARE_PARAMETER_BADVAL(ctype_in, (trans->vtable->per_pdl_flags[0]), PARENT, (trans->pdls[0]), 1) \ 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.085/Basic/Core/Overloads.pm0000644000175000017500000000116614146003631016304 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.085/Basic/Core/Makefile.PL0000644000175000017500000000566714203173773016005 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 pdlbroadcast 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 pdlbroadcast.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 pdlbroadcast.h pdlmagic.h', 'pdlcore$(OBJ_EXT)' => 'pdlperl.h', }, NO_MYMETA => 1, ); PDL-2.085/Basic/Core/pdlperl.h.PL0000644000175000017500000000777014555760610016157 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; \ 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); \ sv_setsv(output, POPs); \ 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 (%"NVgf").\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 = $_->unsigned ? 'u' : $_->integer ? 'i' : 'n'); print OUT "sv_set${letter}v(outsv, (${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.085/Basic/Core/Char.pm0000644000175000017500000001773614223506016015236 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 character 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 L 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.085/Basic/Options.pm0000644000175000017500000005763714410226766015141 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 = PDL::Options->new; $opt = PDL::Options->new( \%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 = PDL::Options->new( $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 grep defined $opt{$_}, 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; confess "Called with undefined key" if !defined $key; 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 = PDL::Options->new( { 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.085/Basic/Ufunc/0000755000175000017500000000000014556074541014211 5ustar osboxesosboxesPDL-2.085/Basic/Ufunc/ufunc.pd0000644000175000017500000007755414226452055015672 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) # # 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; }, 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: broadcastloop %{ $b() = 0.; /* not a(n=>0); as interval has zero width */ %} break; case 2: broadcastloop %{ $b() = 0.5*($a(n=>0)+$a(n=>1)); %} break; case 3: broadcastloop %{ $b() = ($a(n=>0)+4*$a(n=>1)+$a(n=>2))/3.; %} break; case 4: broadcastloop %{ $b() = ($a(n=>0)+$a(n=>3)+3.*($a(n=>1)+$a(n=>2)))*0.375; %} break; case 5: broadcastloop %{ $b() = (14.*($a(n=>0)+$a(n=>4)) +64.*($a(n=>1)+$a(n=>3)) +24.*$a(n=>2))/45.; %} break; default: broadcastloop %{ 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) %{ PDL_IF_BAD(if ($ISBAD(a())) continue;,) if( !flag || ($a() '.$op.' cur ) || PDL_ISNAN_$PPSYM()(cur) ) {cur = $a(); flag = 1;} %} if ( flag ) { $c() = cur; } else { $SETBAD(c()); $PDLSTATESETBAD(c); }', Doc => projectdocs($name,$name,''), BadDoc => 'Output is set bad if no elements of the input are non-bad, otherwise the bad flag is cleared for the output ndarray. Note that C are considered to be valid values and will "win" over non-C; 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) %{ PDL_IF_BAD(if ($ISBAD(a())) continue;,) if(curind == -1 || $a() '.$op.' cur || PDL_ISNAN_$PPSYM()(cur)) {cur = $a(); curind = n;} %} if ( curind != -1 ) { $c() = curind; } else { $SETBAD(c()); $PDLSTATESETBAD(c); }', Doc => "Like $name but returns the index rather than the value", BadDoc => 'Output is set bad if no elements of the input are non-bad, otherwise the bad flag is cleared for the output ndarray. Note that C are considered to be valid values and will "win" over non-C; see L and L for ways of masking NaNs. ', ); synonym("${name}_ind", "${synonym}_ind"); pp_def( "${name}_n_ind", HandleBad => 1, Pars => 'a(n); indx [o]c(m);', OtherPars => 'PDL_Indx m_size => m;', PMCode => PDL::PP::pp_line_numbers(__LINE__, <dim(0) : \$c; # back-compat with pre-2.077 my \$set_out = 1; \$set_out = 0, \$c = null if !ref \$c; \$c = \$c->indx if !\$c->isnull; PDL::_${name}_n_ind_int(\$a, \$c, \$m_size); \$set_out ? \$_[1] = \$c : \$c; } EOF Code => '$GENERIC() cur = 0; PDL_Indx curind; register PDL_Indx ns = $SIZE(n); if($SIZE(m) > $SIZE(n)) $CROAK("m_size > n_size"); $PDLSTATESETGOOD(c); loop(m) %{ curind = ns; loop(n) %{ PDL_Indx nm; int flag=0; for(nm=0; nmnm) == n) {flag=1; break;} } if(!flag && PDL_IF_BAD($ISGOOD(a()) &&,) ((curind == ns) || $a() '.$op.' cur || PDL_ISNAN_$PPSYM()(cur))) {cur = $a(); curind = n;} %} if (curind != ns) { $c() = curind; } else { $SETBAD(c()); $PDLSTATESETBAD(c); } %}', Doc => < $name elements. As of 2.077, you can specify how many by either passing in an ndarray of the given size (DEPRECATED - will be converted to indx if needed and the input arg will be set to that), or just the size, or a null and the size. =for usage ${name}_n_ind(\$pdl, \$out = zeroes(5)); # DEPRECATED \$out = ${name}_n_ind(\$pdl, 5); ${name}_n_ind(\$pdl, \$out = null, 5); EOF BadDoc => 'Output bad flag is cleared for the output ndarray if sufficient non-bad elements found, else remaining slots in C<$c()> are set bad. Note that C are considered to be valid values and will "win" over non-C; see L and L for ways of masking NaNs. ', ); 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; int flag = 0; loop(n) %{ PDL_IF_BAD(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 */ %} PDL_IF_BAD(if ( !flag ) { /* Handle null ndarray */ $SETBAD(cmin()); $SETBAD(cmin_ind()); $SETBAD(cmax()); $SETBAD(cmax_ind()); $PDLSTATESETBAD(cmin); $PDLSTATESETBAD(cmin_ind); $PDLSTATESETBAD(cmax); $PDLSTATESETBAD(cmax_ind); } else,) { $cmin() = curmin; $cmin_ind() = curmin_ind; $cmax() = curmax; $cmax_ind() = curmax_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 broadcast 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, 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 => $copy_to_temp . $find_median_average . '}', ); # pp_def: medover my $find_median_lower = ' PDL_Indx nn1 = nn/2; $b() = $tmp(n => nn1);'; 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 . $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 = ' double np, pp1, pp2; np = nn * $p(); PDL_Indx nn1 = PDLMIN(nn,PDLMAX(0,np)); PDL_Indx nn2 = PDLMIN(nn,PDLMAX(0,np+1)); 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 => $copy_to_temp . $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 => $copy_to_temp . ' PDL_Indx np = PDLMAX(0,PDLMIN(nn,(nn+1)*$p())); $b() = $tmp(n => np); }', ); for ( ['','result is interpolated'], ['odd','nearest data value is the result'], ) { pp_add_exported('', $_->[0].'pct'); pp_addpm(<[0]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 $_->[1]. =for usage \$x = $_->[0]pct(\$data, \$pct); =cut *$_->[0]pct = \\&PDL::$_->[0]pct; sub PDL::$_->[0]pct { my(\$x, \$p) = \@_; \$x->clump(-1)->$_->[0]pctover(\$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 => 'register PDL_Indx nn = 0, nb = $SIZE(n) - 1; '.qsort_croak('b',0,0).' loop(n) %{ PDL_IF_BAD(if (!$ISGOOD(a())) { $SETBAD(b(n=>nb)); nb--; } else,) { $b(n=>nn) = $a(); nn++; } %} 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 => 'register PDL_Indx nn = PDL_IF_BAD(0,$SIZE(n)-1), nb = $SIZE(n) - 1; if ($SIZE(n) == 0) return PDL_err; '.qsort_croak('indx',0,0).' loop(n) %{ PDL_IF_BAD(if (!$ISGOOD(a())) { $indx(n=>nb) = n; nb--; } else { $indx(n=>nn) = n; nn++; } /* play safe since nn used more than once */ ,$indx() = n;) %} PDL_IF_BAD(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 => 'register PDL_Indx nn = PDL_IF_BAD(0,$SIZE(m)-1), nb = $SIZE(m) - 1; char is_inplace = ($P(a) == $P(b)); PDL_Indx nd = $SIZE(n); '.qsort_croak('b',1,1).' PDL_IF_BAD(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;, if (!is_inplace) { loop(n,m) %{ $b() = $a(); %} } {)' . 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 broadcasted 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 => 'register PDL_Indx nn = PDL_IF_BAD(0,$SIZE(m)-1), nb = $SIZE(m) - 1; PDL_Indx nd = $SIZE(n); '.qsort_croak('indx',1,0).' loop(m) %{ PDL_IF_BAD( 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; , $indx()=m; ) %} PDL_IF_BAD( 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 broadcasted 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.085/Basic/Ufunc/Makefile.PL0000644000175000017500000000065614202424257016161 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.085/Basic/Complex/0000755000175000017500000000000014556074541014540 5ustar osboxesosboxesPDL-2.085/Basic/Complex/complex.pd0000644000175000017500000007451114416374741016544 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_core_importList('()'); 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'; =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 broadcasting). =item * use C to cast from normal ndarrays into the complex datatype. Use C to cast back. This requires a copy, though. =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->pdl(0,1) } { no warnings 'redefine'; sub i { $i->copy + (@_ ? $_[0] : 0) }; } # sensible aliases from PDL::LinearAlgebra *r2p = \&Cr2p; *p2r = \&Cp2r; *conj = \&Cconj; *abs = \&Cabs; *abs2 = \&Cabs2; *arg = \&Carg; *tan = \&Ctan; *proj = \&Cproj; *asin = \&Casin; *acos = \&Cacos; *atan = \&Catan; *sinh = \&Csinh; *cosh = \&Ccosh; *tanh = \&Ctanh; *asinh = \&Casinh; *acosh = \&Cacosh; *atanh = \&Catanh; 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 (fabsl (br) > fabsl (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->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'; # 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; die if !(my ($op, $commutes, $func) = /(\S+)([-+])(\w+)/); $sub = eval 'sub { my ($x, $y) = '.($commutes eq '+' ? '' : '$_[2] ? @_[1,0] : ').'@_[0,1]; $_ = r2C $_ for grep ref $_ ne __PACKAGE__, $x, $y; '.$func.'($x, $y); }'; #need to swap? die if $@; ($op, $sub, exists $NO_MUTATE{$op} ? () : ("$op=", $sub)); } sub _gen_unop { my ($op, $func) = split '@', $_[0]; 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 broadcasting 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.085/Basic/Complex/t/0000755000175000017500000000000014556074541015003 5ustar osboxesosboxesPDL-2.085/Basic/Complex/t/complex.t0000644000175000017500000003144014416346155016637 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; } # capture error in PDL::LinearAlgebra { my $info = bless pdl(1), 'PDL::Complex'; eval { $info ? 1 : 0 }; is $@, '', 'no error in comparison'; } #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'); ok !$x->badflag, 'PDL::Complex badflag works'; 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) ok(tapprox($x->Cconj->im, -2), 'Cconj works'); ok(tapprox($x->conj->im, -2), 'conj works'); $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 broadcasting 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.085/Basic/Complex/Makefile.PL0000644000175000017500000000043614014062163016477 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.085/Basic/Constants.pm0000644000175000017500000000230714202424257015434 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.085/Basic/Gen/0000755000175000017500000000000014556074541013642 5ustar osboxesosboxesPDL-2.085/Basic/Gen/PP.pm0000644000175000017500000023374014422365176014527 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_%s_bar') # PDL::PP::Rule::InsertName->new("Foo", "Arg2", '_pdl_%s_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 string and use a %s where the name goes # # 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. 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 .= "[".join(",", @{$self->{targets}||[]})."]"; $str .= "<-[".join(",", @{$self->{conditions}||[]})."] "; $str .= $self->{doc} if exists $self->{doc}; 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 !/\?$/ && !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 {(my $r=$_)=~s/\?$//;$r} @{ $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) = @_; $self->report("Applying: $self\n"); 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 default doc string $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 == 1; unshift @{$self->{conditions}}, "Name"; # add "Name" as first condition 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]; $self->report ("--setting: $target (name=$pars->{Name})\n"); $pars->{$target} = sprintf $self->{"insertname.value"}, $pars->{Name}; } # PDL::PP::Rule->new("NewXSCoerceMustSubs", ["NewXSCoerceMustSub1","Name"], # \&dosubst), # # PDL::PP::Rule::Substitute->new($target,$condition) # $target and $condition must be scalars. package PDL::PP::Rule::Substitute; use strict; use Carp; our @ISA = qw (PDL::PP::Rule); sub badflag_isset { "($_[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,$compobj,$privobj) = @_; my $ret = (ref $src ? $src->[0] : $src); my @pairs; for ([$compobj,'COMP'], [$privobj,'PRIV']) { my ($cobj, $which) = @$_; my ($cn,$co) = map $cobj->$_, qw(othernames otherobjs); push @pairs, 'DO'.$which.'ALLOC' => sub { join '', map $$co{$_}->get_malloc("\$$which($_)"), grep $$co{$_}->need_malloc, @$cn }; } my %syms = ( @pairs, ((ref $src) ? %{$src->[1]} : ()), PRIV => sub {return "$sname->$_[0]"}, COMP => sub {my $r="$pname->$_[0]";$sig->other_is_output($_[0])?"(*($r))":$r}, CROAK => sub {"return PDL->make_error(PDL_EUSERERROR, \"Error in $name:\" @{[join ',', @_]})"}, NAME => sub {return $name}, MODULE => sub {return $::PDLMOD}, SETPDLSTATEBAD => sub { "$_[0]\->state |= PDL_BADVAL" }, SETPDLSTATEGOOD => sub { "$_[0]\->state &= ~PDL_BADVAL" }, ISPDLSTATEBAD => \&badflag_isset, ISPDLSTATEGOOD => sub {"!".badflag_isset($_[0])}, BADFLAGCACHE => sub { "badflag_cache" }, PDLSTATESETBAD => sub { ($sig->objs->{$_[0]}//confess "Can't get PDLSTATESETBAD for unknown ndarray '$_[0]'")->do_pdlaccess."->state |= PDL_BADVAL" }, PDLSTATESETGOOD => sub { ($sig->objs->{$_[0]}->do_pdlaccess//confess "Can't get PDLSTATESETGOOD for unknown ndarray '$_[0]'")."->state &= ~PDL_BADVAL" }, PDLSTATEISBAD => sub {badflag_isset(($sig->objs->{$_[0]}//confess "Can't get PDLSTATEISBAD for unknown ndarray '$_[0]'")->do_pdlaccess)}, PDLSTATEISGOOD => sub {"!".badflag_isset(($sig->objs->{$_[0]}//confess "Can't get PDLSTATEISGOOD for unknown ndarray '$_[0]'")->do_pdlaccess)}, PP => sub { ($sig->objs->{$_[0]}//confess "Can't get PP for unknown ndarray '$_[0]'")->do_physpointeraccess }, P => sub { (my $o = ($sig->objs->{$_[0]}//confess "Can't get P for unknown ndarray '$_[0]'"))->{FlagPhys} = 1; $o->do_pointeraccess; }, PDL => sub { ($sig->objs->{$_[0]}//confess "Can't get PDL for unknown ndarray '$_[0]'")->do_pdlaccess }, SIZE => sub { ($sig->ind_obj($_[0])//confess "Can't get SIZE of unknown dim '$_[0]'")->get_size }, SETNDIMS => sub {"PDL_RETERROR(PDL_err, PDL->reallocdims(__it,$_[0]));"}, SETDIMS => sub {"PDL_RETERROR(PDL_err, PDL->setdims_careful(__it));"}, SETDELTABROADCASTIDS => sub {PDL::PP::pp_line_numbers(__LINE__, <reallocbroadcastids(\$PDL(CHILD), \$PDL(PARENT)->nbroadcastids)); for(__ind=0; __ind<\$PDL(PARENT)->nbroadcastids; __ind++) \$PDL(CHILD)->broadcastids[__ind] = \$PDL(PARENT)->broadcastids[__ind] + ($_[0]); } EOF %PDL::PP::macros, ); my $known_pat = join '|', map quotemeta, sort keys %syms; while (my ($before, $kw, $args, $other) = macro_extract($ret, $known_pat)) { confess("$kw not defined in '$ret'!") if !$syms{$kw}; $ret = join '', $before, $syms{$kw}->(split_cpp($args)), $other; } $ret; } # split like C pre-processor - on commas unless in "" or () my $extract_spec = [ sub {Text::Balanced::extract_delimited($_[0], '"')}, sub {Text::Balanced::extract_bracketed($_[0], '()')}, qr/\s+/, qr/[^",\(\s]+/, { COMMA => qr/,/ }, ]; sub split_cpp { my ($text) = @_; require Text::Balanced; my ($thisstr, @parts); while (defined(my $n = Text::Balanced::extract_multiple($text, $extract_spec, undef, 1))) { if (ref $n) { push @parts, $thisstr // ''; $thisstr = ''; } else { $thisstr = '' if !defined $thisstr; $thisstr .= $n; } } push @parts, $thisstr if defined $thisstr; s/^\s+//, s/\s+$// for @parts; @parts; } sub macro_extract { require Text::Balanced; my ($text, $pat) = @_; return unless $text =~ /\$($pat)\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 { die "Usage: PDL::PP::Rule::Substitute->new(\$target,\$condition);" unless @_ == 3; my ($class, $target, $condition) = @_; 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 CompObj PrivObj)], \&dosubst_private); } package PDL::PP; use strict; our $VERSION = "2.3"; $VERSION = eval $VERSION; our $macros_xs = pp_line_numbers(__LINE__, <<'EOF'); #include "pdlperl.h" #define PDL_XS_PREAMBLE(nret) \ 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 = (nret); \ (void)nreturn; \ 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) ") \ do { \ 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") \ } \ } \ } while (0) static inline pdl *PDL_XS_pdlinit(pTHX_ char *objname, HV *bless_stash, SV *to_push, char *method, SV **svp) { dSP; pdl *ret; if (strcmp(objname,"PDL") == 0) { PDL_COMMENT("shortcut if just PDL") ret = PDL->pdlnew(); if (!ret) PDL->pdl_barf("Error making null pdl"); if (svp) { *svp = sv_newmortal(); PDL->SetSV_PDL(*svp, ret); if (bless_stash) *svp = sv_bless(*svp, bless_stash); } } else { PUSHMARK(SP); XPUSHs(to_push); PUTBACK; perl_call_method(method, G_SCALAR); SPAGAIN; SV *sv = POPs; PUTBACK; ret = PDL->SvPDLV(sv); if (svp) *svp = sv; } return ret; } #define PDL_XS_PERLINIT_init() \ PDL_XS_pdlinit(aTHX_ objname, bless_stash, sv_2mortal(newSVpv(objname, 0)), "initialize", NULL) #define PDL_XS_PERLINIT_initsv(sv) \ PDL_XS_pdlinit(aTHX_ objname, bless_stash, sv_2mortal(newSVpv(objname, 0)), "initialize", &sv) #define PDL_XS_PERLINIT_copy() \ PDL_XS_pdlinit(aTHX_ objname, bless_stash, parent, "copy", NULL) #define PDL_XS_PERLINIT_copysv(sv) \ PDL_XS_pdlinit(aTHX_ objname, bless_stash, parent, "copy", &sv) #define PDL_XS_RETURN(clause1) \ if (nreturn) { \ if (nreturn > 0) EXTEND (SP, nreturn); \ clause1; \ XSRETURN(nreturn); \ } else { \ XSRETURN(0); \ } #define PDL_IS_INPLACE(in) ((in)->state & PDL_INPLACE) #define PDL_XS_INPLACE(in, out, whichinit) \ if (PDL_IS_INPLACE(in)) { \ if (out ## _SV) barf("inplace input but different output given"); \ out ## _SV = sv_newmortal(); \ in->state &= ~PDL_INPLACE; PDL_COMMENT("unset") \ out = in; \ PDL->SetSV_PDL(out ## _SV,out); \ } else \ out = out ## _SV ? PDL_CORE_(SvPDLV)(out ## _SV) : \ PDL_XS_PERLINIT_ ## whichinit ## sv(out ## _SV); 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") EOF our $header_xs = <<'EOF'; Core* PDL = NULL; PDL_COMMENT("Structure hold core C functions") MODULE = %1$s PACKAGE = %2$s PREFIX=pdl_run_ PROTOTYPES: DISABLE EOF our $header_xsboot = pp_line_numbers(__LINE__, <<'EOF'); BOOT: PDL_COMMENT("Get pointer to structure of core shared C routines") PDL_COMMENT("make sure PDL::Core is loaded") 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_add_typemaps pp_core_importList pp_beginwrap pp_setversion pp_addbegin pp_line_numbers pp_deprecate_module pp_add_macros/; $::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, @_); } 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_nolineno { 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'; } $pm =~ s#\n{3,}#\n\n#g; $::PDLPM{$pos} .= "\n$pm\n\n"; } sub pp_addpm { my @args = @_; my $pmind = ref $_[0] ? 1 : 0; my @c = caller; $args[$pmind] = _pp_line_number_file($c[1], $c[2]-1, "\n$args[$pmind]"); $args[$pmind] =~ s#\n{3,}#\n\n#g; _pp_addpm_nolineno(@args); } 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 PREFIX=pdl_run_\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 broadcastloops 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); } my $LINE_RE = qr/^(\s*)PDL_LINENO_(?:START (\S+) "(.*)"|(END))$/; sub _pp_linenumber_fill { local $_; # else get "Modification of a read-only value attempted" my ($file, $text) = @_; my (@stack, @to_return) = [1, $file]; my @lines = split /\n/, $text; REALLINE: while (defined($_ = shift @lines)) { $_->[0]++ for @stack; push(@to_return, $_), next if !/$LINE_RE/; my ($ci, $new_line, $new_file, $is_end) = ($1, $2, $3, $4); if (!$is_end) { push @stack, [$new_line-1, $new_file]; push @to_return, qq{$ci#line @{[$stack[-1][0]+1]} "$stack[-1][1]"} if @lines; next REALLINE; } @stack = [$stack[0][0], $file]; # as soon as any block is left, line numbers for outer blocks become meaningless my ($seen_empty, $empty_first, $last_ci, @last_dir) = (0, undef, $ci); # list=(line, file) LINE: while (1) { last REALLINE if !@lines; if (!length $lines[0]) { $seen_empty = 1; shift @lines; next LINE; } if ($lines[0] =~ /$LINE_RE/) { # directive ($last_ci, @last_dir) = ($1, !$4 ? ($2, $3) : ()); $empty_first //= $seen_empty; shift @lines; next LINE; } else { # substantive push @stack, \@last_dir if @last_dir; push(@to_return, ''), $stack[0][0]++ if $seen_empty and $empty_first; push @to_return, qq{$last_ci#line $stack[-1][0] "$stack[-1][1]"}; push(@to_return, ''), $stack[0][0]++ if $seen_empty and !$empty_first; last LINE; } } } 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), $::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 $user_boot = $::PDLXSBOOT//''; $user_boot =~ s/^\s*(.*?)\n*$/ $1\n/ if $user_boot; (my $mod_underscores = $::PDLMOD) =~ s#::#_#g; my $text = join '', sprintf($PDL::PP::header_c, $mod_underscores), $::PDLXSC//'', $PDL::PP::macros_xs, sprintf($PDL::PP::header_xs, $::PDLMOD, $::PDLOBJ), $::PDLXS, "\n", $PDL::PP::header_xsboot, $pdl_boot, $user_boot; _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_nolineno("\n".$obj{PdlDoc}."\n") if $obj{PdlDoc}; PDL::PP::_pp_addpm_nolineno($obj{PMCode}) if defined $obj{PMCode}; PDL::PP::_pp_addpm_nolineno($obj{PMFunc}."\n") if defined $obj{PMFunc}; 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_nolineno {At => 'Top'}, <new; $typemap_obj->merge(file => $_, replace => 1) for @typemaps; $typemap_obj; } sub typemap { my ($type, $method) = @_; $typemap_obj ||= _load_typemap(); $type=ExtUtils::Typemaps::tidy_type($type); my $inputmap = $typemap_obj->$method(ctype => $type); die "The type =$type= does not have a typemap entry!\n" unless $inputmap; ($inputmap->code, $type); } sub typemap_eval { # lifted from ExtUtils::ParseXS::Eval, ignoring eg $ALIAS my ($code, $varhash) = @_; my ($var, $type, $num, $init, $printed_name, $arg, $ntype, $argoff, $subtype) = @$varhash{qw(var type num init printed_name arg ntype argoff subtype)}; my $rv = eval qq("$code"); die $@ if $@; $rv; } sub pp_add_typemaps { confess "Usage: pp_add_typemaps([string|file|typemap]=>\$arg)" if @_ != 2; $typemap_obj ||= _load_typemap(); my $new_obj = $_[0] eq 'typemap' ? $_[1] : ExtUtils::Typemaps->new(@_); pp_addxs($new_obj->as_embedded_typemap); $typemap_obj->merge(typemap => $new_obj, replace => 1); } 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"; } $str =~ s/(\s*\n)+/\n/g; ($str,$boot,$prelude) } sub indent($$) { my ($ind, $text) = @_; return $text if !length $text or !$ind; $ind = ' ' x $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 ($sv, $callcopy) = @_; "PDL_XS_PERLINIT_".($callcopy ? "copy" : "init").($sv ? "sv($sv)" : "()"); } sub callTypemap { my ($x, $ptype) = @_; my ($setter, $type) = typemap($ptype, 'get_inputmap'); my $ret = typemap_eval($setter, {var=>$x, type=>$type, arg=>("${x}_SV")}); $ret =~ s/^\s*(.*?)\s*$/$1/g; $ret =~ s/\s*\n\s*/ /g; $ret; } sub reorder_args { my ($sig, $otherdefaults) = @_; my %optionals = map +($_=>1), keys(%$otherdefaults); my @other_mand = grep !$optionals{$_} && !$sig->other_is_out($_), my @other = @{$sig->othernames(1, 1)}; my @other_opt = grep $optionals{$_}, @other; ($sig->names_in, @other_mand, @other_opt, $sig->names_out, $sig->other_out); } ########################################################### # 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($PDL(PARENT)->ndims); for(i=0; i<$PDL(CHILD)->ndims; i++) { $PDL(CHILD)->dims[i] = $PDL(PARENT)->dims[i]; } $SETDIMS(); $SETDELTABROADCASTIDS(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", [qw(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", [qw(Name Pars? OtherPars Doc BadDoc?)], sub { my ($name,$pars,$otherpars,$doc,$baddoc) = @_; return '' if !defined $doc # Allow explicit non-doc using Doc=>undef or $doc =~ /^\s*internal\s*$/i; # If the doc string is one line let's have two 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 # 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->new("HaveBroadcasting","HaveThreading", sub {@_}), # compat PDL::PP::Rule::Croak->new([qw(P2Child GenericTypes)], 'Cannot have both P2Child and GenericTypes defined'), PDL::PP::Rule->new([qw(Pars HaveBroadcasting CallCopy GenericTypes DefaultFlow AllFuncHeader RedoDimsFuncHeader)], ["P2Child","Name","StructName"], sub { my (undef,$name,$sname) = @_; ("PARENT(); [oca]CHILD();",0,0,[PDL::Types::ppdefs_all()],1, "pdl *__it = $sname->pdls[1];\n", "PDL->hdr_childcopy($sname); $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_%s_vtable'), PDL::PP::Rule::Returns->new("Priv", "AffinePriv", 'PDL_Indx incs[$PDL(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", [qw(EquivPDimExpr EquivDimCheck?)], sub { my($pdimexpr,$dimcheck) = @_; $pdimexpr =~ s/\$CDIM\b/i/g; ' int i,cor; '.$dimcheck.' $SETNDIMS($PDL(PARENT)->ndims); $DOPRIVALLOC(); $PRIV(offs) = 0; for(i=0; i<$PDL(CHILD)->ndims; i++) { cor = '.$pdimexpr.'; $PDL(CHILD)->dims[i] = $PDL(PARENT)->dims[cor]; $PRIV(incs)[i] = $PDL(PARENT)->dimincs[cor]; } $SETDIMS(); $SETDELTABROADCASTIDS(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; '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 'broadcastloop %{', 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; '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", '_%s_int'), PDL::PP::Rule::Returns::One->new("HaveBroadcasting"), PDL::PP::Rule::Returns::EmptyString->new("Priv"), PDL::PP::Rule->new("PrivObj", ["BadFlag","Priv"], sub { PDL::PP::Signature->new('', @_) }), # Parameters in the 'a(x,y); [o]b(y)' format, with # fixed nos of real, unbroadcast-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(@_) }), # 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", [qw(BadFlag OtherPars Comp?)], sub { PDL::PP::Signature->new('', $_[0], join(';', grep defined() && /[^\s;]/, @_[1..$#_])) }), PDL::PP::Rule->new("CompStruct", ["CompObj"], sub {$_[0]->getcomp}), # 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]}{FlagTypeOverride}; }), PDL::PP::Rule->new("InplaceNormalised", ["SignatureObj","Inplace"], 'interpret Inplace and Signature to get input/output', # 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' # this will set InplaceNormalised to [input,output] sub { my ($sig, $arg) = @_; confess 'Inplace given false value' if !$arg; confess "Inplace array-ref (@$arg) > 2 elements" if ref($arg) eq "ARRAY" and @$arg > 2; # find input and output ndarrays my %is_out = map +($_=>1), my @out = $sig->names_out; my @in = $sig->names_in; my $in = @in == 1 ? $in[0] : undef; my $out = @out == 1 ? $out[0] : undef; my $noutca = $sig->names_oca; 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" unless defined $in; confess "ERROR: Inplace input ndarray '$in' is actually output" if $is_out{$in}; confess "ERROR: Inplace does not know name of output ndarray" unless defined $out; my ($in_obj, $out_obj) = map $sig->objs->{$_}, $in, $out; confess "ERROR: Inplace output arg $out not [o]\n" if !$$out_obj{FlagW}; my ($in_inds, $out_inds) = map $_->{IndObjs}, $in_obj, $out_obj; confess "ERROR: Inplace args $in and $out different number of dims" if @$in_inds != @$out_inds; for my $i (0..$#$in_inds) { my ($in_ind, $out_ind) = map $_->[$i], $in_inds, $out_inds; next if grep !defined $_->{Value}, $in_ind, $out_ind; confess "ERROR: Inplace Pars $in and $out inds ".join('=',@$in_ind{qw(Name Value)})." and ".join('=',@$out_ind{qw(Name Value)})." not compatible" if $in_ind->{Value} != $out_ind->{Value}; } [$in, $out]; }), PDL::PP::Rule->new(["InplaceCode"], [qw(InplaceNormalised CallCopy)], 'code to implement working 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, sub { my ($arg, $callcopy) = @_; my ($in, $out) = @$arg; " PDL_XS_INPLACE($in, $out, @{[$callcopy ? 'copy' : 'init']})\n"; }), PDL::PP::Rule::Returns::EmptyString->new("InplaceCode", []), PDL::PP::Rule::Returns::EmptyString->new("HdrCode", [], 'Code that will be inserted before the call to the RunFunc'), PDL::PP::Rule::Returns::EmptyString->new("FtrCode", [], 'Code that will be inserted after the call to the RunFunc'), PDL::PP::Rule->new([], [qw(Name SignatureObj ArgOrder OtherParsDefaults?)], "Check for ArgOrder errors", sub { my ($name, $sig, $argorder, $otherdefaults) = @_; return if $argorder and !ref $argorder; confess "$name ArgOrder given false value" if !ref $argorder; my @names = @{ $sig->allnames(1, 1) }; my %namehash = map +($_=>1), @names; delete @namehash{@$argorder}; confess "$name ArgOrder missed params: ".join(' ', keys %namehash) if keys %namehash; my %orderhash = map +($_=>1), @$argorder; delete @orderhash{@names}; confess "$name ArgOrder too many params: ".join(' ', keys %orderhash) if keys %orderhash; my %optionals = map +($_=>1), keys(%$otherdefaults), $sig->names_out, $sig->other_out; my $optional = ''; for (@$argorder) { $optional = $_, next if exists $optionals{$_}; confess "$name got mandatory argument '$_' after optional argument '$optional'" if $optional and !exists $optionals{$_}; } (); }), PDL::PP::Rule->new([], [qw(Name SignatureObj OtherParsDefaults)], "Check the OtherPars defaults aren't for ones after ones without", sub { my ($name,$sig,$otherdefaults) = @_; my @other_args = @{ $sig->othernames(1, 1) }; return if keys %$otherdefaults == @other_args; my $default_seen = ''; for (@other_args) { $default_seen = $_ if exists $otherdefaults->{$_}; confess "$name got default-less arg '$_' after default-ful arg '$default_seen'" if $default_seen and !exists $otherdefaults->{$_}; } }), PDL::PP::Rule->new("VarArgsXSHdr", [qw(Name SignatureObj CallCopy? OtherParsDefaults? ArgOrder? InplaceNormalised?)], '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, $callcopy,$otherdefaults,$argorder,$inplace) = @_; $argorder = [reorder_args($sig, $otherdefaults)] if $argorder and !ref $argorder; my $optypes = $sig->otherobjs; my @args = @{ $argorder || $sig->allnames(1, 1) }; my %other = map +($_=>1), @{$sig->othernames(1, 1)}; $otherdefaults ||= {}; my $ci = 2; # current indenting my %ptypes = map +($_=>$$optypes{$_} ? $$optypes{$_}->get_decl('', {VarArrays2Ptrs=>1}) : 'pdl *'), @args; my %out = map +($_=>1), $sig->names_out_nca; my %outca = map +($_=>1), $sig->names_oca; my @inargs = grep !$outca{$_}, @args; my %other_out = map +($_=>1), $sig->other_out; my $nout = keys(%out) + keys(%other_out); my $noutca = keys %outca; my $ntot = @args; my $nallout = $nout + $noutca; my $ndefault = keys %$otherdefaults; my %valid_itemcounts = ((my $nmaxonstack = $ntot - $noutca)=>1); $valid_itemcounts{my $nin = $nmaxonstack - $nout} = 1; $valid_itemcounts{my $nin_minus_default = "($nin-$ndefault)"} = 1 if $ndefault; my $only_one = keys(%valid_itemcounts) == 1; my $nretval = $argorder ? $nout : $only_one ? $noutca : "(items == $nmaxonstack) ? $noutca : $nallout"; my ($cnt, @preinit, @xsargs, %already_read, %name2cnts) = -1; my @inputdecls = map "PDL_Indx ${_}_count=0;", grep $other{$_} && $optypes->{$_}->is_array, @inargs; foreach my $x (@inargs) { if (!$argorder && ($out{$x} || $other_out{$x} || exists $otherdefaults->{$x})) { last if @xsargs + keys(%out) + $noutca != $ntot; $argorder = 1; # remaining all output ndarrays, engage } $cnt++; $name2cnts{$x} = [$cnt, $cnt]; $already_read{$x} = 1; push @xsargs, $x.(!$argorder ? '' : exists $otherdefaults->{$x} ? "=$otherdefaults->{$x}" : !$out{$x} ? '' : $inplace && $x eq $inplace->[1] ? "=$x" : "=".callPerlInit($x."_SV", $callcopy) ); push @inputdecls, "$ptypes{$x}$x".($inplace && $x eq $inplace->[1] ? "=NO_INIT" : ''); } my $shortcnt = my $xs_arg_cnt = $cnt; foreach my $x (@inargs[$cnt+1..$nmaxonstack-1]) { $cnt++; $name2cnts{$x} = [$cnt, undef]; $name2cnts{$x}[1] = ++$shortcnt if !($out{$x} || $other_out{$x}); push @xsargs, "$x=$x"; push @inputdecls, "$ptypes{$x}$x".($other{$x} && !exists $otherdefaults->{$x} ? "; { ".callTypemap($x, $ptypes{$x})."; }" : "=NO_INIT"); } push @inputdecls, map "$ptypes{$_}$_=".callPerlInit($_."_SV", $callcopy).";", grep $outca{$_}, @args; my $defaults_rawcond = $ndefault ? "items == $nin_minus_default" : ''; my $svdecls = join '', map "\n $_", (map "SV *${_}_SV = ".( !$name2cnts{$_} ? 'NULL' : $argorder ? "items > $name2cnts{$_}[1] ? ST($name2cnts{$_}[1]) : ".($other_out{$_} ? "sv_newmortal()" : "NULL") : $name2cnts{$_}[0] == ($name2cnts{$_}[1]//-1) ? "ST($name2cnts{$_}[0])" : "(items == $nmaxonstack) ? ST($name2cnts{$_}[0]) : ". (!defined $name2cnts{$_}[1] ? ($other_out{$_} ? "sv_newmortal()" : "NULL") : defined $otherdefaults->{$_} ? "!($defaults_rawcond) ? ST($name2cnts{$_}[1]) : ".($other_out{$_} ? "sv_newmortal()" : "NULL") : "ST($name2cnts{$_}[1])" ) ).";", (grep !$already_read{$_}, $sig->names_in), $sig->names_out, @{$sig->othernames(1, 1, \%already_read)}), ; my $argcode = indent(2, join '', (map "if (!${_}_SV) { $_ = ($otherdefaults->{$_}); } else ". "{ ".callTypemap($_, $ptypes{$_})."; }\n", grep !$argorder && exists $otherdefaults->{$_}, @{$sig->othernames(1, 1)}), (map callTypemap($_, $ptypes{$_}).";\n", grep !$already_read{$_}, $sig->names_in), (map +("if (${_}_SV) { ".($argorder ? '' : callTypemap($_, $ptypes{$_}))."; } else ")."$_ = ".callPerlInit($_."_SV", $callcopy).";\n", grep $out{$_} && !$already_read{$_} && !($inplace && $_ eq $inplace->[1]), @args) ); push @preinit, qq[PDL_XS_PREAMBLE($nretval);] if $nallout; push @preinit, qq{if (!(@{[join ' || ', map "(items == $_)", sort keys %valid_itemcounts]})) croak("Usage: ${main::PDLOBJ}::$name(@{[ join ",", map exists $otherdefaults->{$_} ? "$_=$otherdefaults->{$_}" : $out{$_} || $other_out{$_} ? "[$_]" : $_, @inargs ]}) (you may leave [outputs] and values with =defaults out of list)");} unless $only_one || $argorder || ($nmaxonstack - ($xs_arg_cnt+1) == keys(%valid_itemcounts)-1); my $preamble = @preinit ? qq[\n PREINIT:@{[join "\n ", "", @preinit]}\n INPUT:\n] : ''; join '', qq[ \nNO_OUTPUT pdl_error pdl_run_$name(@{[join ', ', @xsargs]})$svdecls $preamble@{[join "\n ", "", @inputdecls]} PPCODE: ], map "$_\n", $argcode; }), # globalnew implies internal usage, not XS PDL::PP::Rule::Returns->new("VarArgsXSReturn","GlobalNew",undef), PDL::PP::Rule->new("FixArgsXSOtherOutDeclSV", ["SignatureObj"], "Generate XS to declare SVs for output OtherPars", sub { my ($sig) = @_; my $optypes = $sig->otherobjs; my @args = @{ $sig->allnames(1, 1) }; my %outca = map +($_=>1), $sig->names_oca; my %other_output = map +($_=>1), my @other_output = ($sig->other_io, $sig->other_out); my $ci = 2; my $cnt = 0; my %outother2cnt; foreach my $x (grep !$outca{$_}, @args) { $outother2cnt{$x} = $cnt if $other_output{$x}; $cnt++; } join "\n", map indent($ci,qq{SV *${_}_SV = ST($outother2cnt{$_});}), @other_output; }), PDL::PP::Rule->new("XSOtherOutSet", [qw(Name SignatureObj)], "Generate XS to set SVs to output values for OtherPars", sub { my ($name, $sig) = @_; my $clause1 = ''; my @other_output = ($sig->other_io, $sig->other_out); my $optypes = $sig->otherobjs; my %ptypes = map +($_=>$$optypes{$_}->get_decl('', {VarArrays2Ptrs=>1})), @other_output; for my $x (@other_output) { my ($setter, $type) = typemap($ptypes{$x}, 'get_outputmap'); $setter = typemap_eval($setter, {var=>$x, type=>$type, arg=>"tsv"}); $clause1 .= <pdl_barf("Internal error in $name: tried to output to NULL ${x}_SV"); {\n SV *tsv = sv_newmortal(); $setter sv_setsv(${x}_SV, tsv);\n} EOF } indent(2, $clause1); }), PDL::PP::Rule->new("VarArgsXSReturn", ["SignatureObj"], "Generate XS trailer to return output variables or leave them as modified input variables", sub { my ($sig) = @_; my $oc = my @outs = $sig->names_out; # output ndarrays in calling order my @other_outputs = ($sig->other_io, $sig->other_out); # output OtherPars my $clause1 = join ';', (map "ST($_) = $outs[$_]_SV", 0 .. $#outs), (map "ST(@{[$_+$oc]}) = $other_outputs[$_]_SV", 0 .. $#other_outputs); $clause1 ? indent(2,"PDL_XS_RETURN($clause1)\n") : ''; }), PDL::PP::Rule->new("NewXSHdr", ["NewXSName","SignatureObj"], sub { my($name,$sig) = @_; my $shortpars = join ',', @{ $sig->allnames(1, 1) }; my $optypes = $sig->otherobjs; my @counts = map "PDL_Indx ${_}_count=0;", grep $optypes->{$_}->is_array, @{ $sig->othernames(1, 1) }; my $longpars = join "\n", map " $_", @counts, $sig->alldecls(1, 0, 1); return<new("RunFuncName", 'pdl_run_%s'), PDL::PP::Rule->new("NewXSCHdrs", ["RunFuncName","SignatureObj","GlobalNew"], sub { my($name,$sig,$gname) = @_; my $longpars = join ",", $sig->alldecls(0, 1); 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 ',', map $sig->other_is_output($_)?"&$_":$_, @{ $sig->allnames(0) }; my $longpars = join ",", $sig->alldecls(0, 1); (indent(2,"RETVAL = $func_name($shortpars);\nPDL->barf_if_error(RETVAL);\n"), "pdl_error $func_name($longpars)"); }), PDL::PP::Rule->new("NewXSMakeNow", ["SignatureObj"], sub { join '', map "$_ = 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("NewXSTypeCoerceNS", ["StructName"], sub { " PDL_RETERROR(PDL_err, PDL->type_coerce($_[0]));\n" }), PDL::PP::Rule::Substitute->new("NewXSTypeCoerceSubd", "NewXSTypeCoerceNS"), PDL::PP::Rule->new("NewXSRunTrans", ["StructName"], sub { my($trans) = @_; " PDL_RETERROR(PDL_err, PDL->make_trans_mutual($trans));\n"; }), 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]).qq[$comp\n} $ptype;], $ptype); }), do { sub wrap_vfn { my ( $code,$rout,$func_header, $all_func_header,$sname,$pname,$ptype,$extra_args, ) = @_; join "", PDL::PP::pp_line_numbers(__LINE__, qq[pdl_error $rout(pdl_trans *$sname$extra_args) { pdl_error PDL_err = {0, NULL, 0};]), ($ptype ? " $ptype *$pname = $sname->params;\n" : ''), indent(2, join '', grep $_, $all_func_header, $func_header, $code), " return PDL_err;\n}"; } sub make_vfn_args { my ($which, $extra_args) = @_; ("${which}Func", ["${which}CodeSubd","${which}FuncName","${which}FuncHeader?", qw(AllFuncHeader? StructName ParamStructName ParamStructType), ], sub {$_[1] eq 'NULL' ? '' : wrap_vfn(@_,$extra_args//'')} ); } ()}, PDL::PP::Rule->new("MakeCompOther", [qw(SignatureObj ParamStructName)], sub { $_[0]->getcopy("$_[1]->%s") }), PDL::PP::Rule->new("MakeCompTotal", [qw(MakeCompOther MakeComp?)], sub { join "\n", grep $_, @_ }), PDL::PP::Rule::Substitute->new("MakeCompiledReprSubd", "MakeCompTotal"), PDL::PP::Rule->new("NewXSSetTransPDLs", ["SignatureObj","StructName"], sub { my($sig,$trans) = @_; join '', map " $trans->pdls[$_->[0]] = $_->[2];\n", grep !$_->[1], $sig->names_sorted_tuples; }), PDL::PP::Rule->new("NewXSExtractTransPDLs", [qw(SignatureObj StructName MakeComp?)], sub { my($sig,$trans,$makecomp) = @_; !$makecomp ? '' : join '', map " $_->[2] = $trans->pdls[$_->[0]];\n", grep !$_->[1], $sig->names_sorted_tuples; }), (map PDL::PP::Rule::Substitute->new("${_}ReadDataCodeUnparsed", "${_}Code"), '', 'Bad'), PDL::PP::Rule->new(PDL::PP::Code::make_args(qw(ReadData)), sub { PDL::PP::Code->new(@_, undef, undef, 1); }), PDL::PP::Rule::Substitute->new("ReadDataCodeSubd", "ReadDataCodeParsed"), PDL::PP::Rule::InsertName->new("ReadDataFuncName", 'pdl_%s_readdata'), PDL::PP::Rule->new(make_vfn_args("ReadData")), (map PDL::PP::Rule::Substitute->new("${_}WriteBackDataCodeUnparsed", "${_}BackCode"), '', 'Bad'), PDL::PP::Rule->new(PDL::PP::Code::make_args(qw(WriteBackData)), sub { PDL::PP::Code->new(@_, undef, 1, 1); }), PDL::PP::Rule::Substitute->new("WriteBackDataCodeSubd", "WriteBackDataCodeParsed"), PDL::PP::Rule::InsertName->new("WriteBackDataFuncName", "BackCode", 'pdl_%s_writebackdata'), PDL::PP::Rule::Returns::NULL->new("WriteBackDataFuncName", "Code"), PDL::PP::Rule->new(make_vfn_args("WriteBackData")), 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", [qw(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', ''), (map PDL::PP::Rule::Substitute->new("RedoDims${_}Unparsed", "RedoDims$_"), '', 'Code'), PDL::PP::Rule->new(PDL::PP::Code::make_args(qw(RedoDims)), 'makes the parsed representation from the supplied RedoDimsCode', sub { return '' if !$_[0]; PDL::PP::Code->new(@_, 1, undef, 0); }), PDL::PP::Rule->new("RedoDimsCodeParsed","RedoDimsUnparsed", sub {@_}), PDL::PP::Rule->new("RedoDims", ["DimsSetters","RedoDimsCodeParsed","DefaultRedoDims"], 'makes the redodims function from the various bits and pieces', sub { join "\n", grep $_ && /\S/, @_ }), PDL::PP::Rule::Substitute->new("RedoDimsCodeSubd", "RedoDims"), PDL::PP::Rule->new(make_vfn_args("RedoDims")), PDL::PP::Rule->new("CompFreeCode", [qw(CompObj CompFreeCodeComp?)], "Free any OtherPars/Comp stuff, including user-supplied code (which is probably paired with own MakeComp)", sub {join '', grep defined() && length, $_[0]->getfree("COMP"), @_[1..$#_]}, ), PDL::PP::Rule->new("NTPrivFreeCode", "PrivObj", sub {$_[0]->getfree("PRIV")}), PDL::PP::Rule->new("FreeCodeNS", ["StructName","CompFreeCode","NTPrivFreeCode"], sub { (grep $_, @_[1..$#_]) ? "PDL_FREE_CODE($_[0], destroy, $_[1], $_[2])" : ''}), PDL::PP::Rule::Substitute->new("FreeCodeSubd", "FreeCodeNS"), 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->new("NewXSCoerceMustNS", "FTypes", sub { my($ftypes) = @_; join '', map PDL::PP::pp_line_numbers(__LINE__, "$_->datatype = $ftypes->{$_};"), sort keys %$ftypes; }), PDL::PP::Rule::Returns::EmptyString->new("NewXSCoerceMustNS"), PDL::PP::Rule::Substitute->new("NewXSCoerceMustCompSubd", "NewXSCoerceMustNS"), PDL::PP::Rule->new("NewXSFindBadStatusNS", [qw(StructName SignatureObj)], "Rule to find the bad value status of the input ndarrays", sub { my $str = "PDL_RETERROR(PDL_err, PDL->trans_check_pdls($_[0]));\n"; $str .= "char \$BADFLAGCACHE() = PDL->trans_badflag_from_inputs($_[0]);\n" if $_[1]->names_out; indent(2, $str); }), 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 !@outs ? '' : PDL::PP::indent(2, join '', # no outs, ditto "if (\$BADFLAGCACHE()) {\n", (map " \$SETPDLSTATEBAD($_);\n", @outs), "}\n"); }), # expand macros in ...BadStatusCode # PDL::PP::Rule::Substitute->new("NewXSFindBadStatusSubd", "NewXSFindBadStatusNS"), PDL::PP::Rule::Substitute->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 ) = @_; indent(2, <params;\n" : "")); if (!PDL) return (pdl_error){PDL_EFATAL, "PDL core struct is NULL, can't continue",0}; pdl_trans *$sname = PDL->create_trans(&$vtable); if (!$sname) return PDL->make_error_simple(PDL_EFATAL, "Couldn't create trans"); 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;'; 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:','',@_))[1..2])}), # if PMCode supplied, no var-args stuff PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"], [qw(PMCode NewXSHdr NewXSCHdrs? FixArgsXSOtherOutDeclSV RunFuncCall XSOtherOutSet)], "Non-varargs XS code when PMCode given", sub {make_xs_code(' CODE:','',@_[1..$#_])}), PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"], [qw(VarArgsXSHdr NewXSCHdrs? HdrCode InplaceCode RunFuncCall FtrCode XSOtherOutSet VarArgsXSReturn)], "Rule to print out XS code when variable argument list XS processing is enabled", sub {make_xs_code('','',@_)}), 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","HaveBroadcasting","NoPthread","Name", "GenericTypes","IsAffineFlag","TwoWayFlag","DefaultFlowFlag", "BadFlag"], sub { my($vname,$ptype,$rdname,$rfname,$wfname,$ffname, $sig,$affine_ok,$havebroadcasting, $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_BROADCAST' if $havebroadcasting; 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; push @op_flags, 'PDL_TRANS_OUTPUT_OTHERPAR' if $sig->other_any_out; 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'; <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.085/Basic/Gen/PP/0000755000175000017500000000000014556074541014161 5ustar osboxesosboxesPDL-2.085/Basic/Gen/PP/CType.pm0000644000175000017500000000746014422310171015532 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) = @_; $this->{WasDollar} = 1 if $str =~ s/^\$//; 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{qw(Base Chain)} = ($1, $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 @$_") } } $name = "*$name" if $opts->{AddIndirect}; return "$this->{Base} $name"; } # Useful when parsing argument decls sub protoname { return shift->{ProtoName} } sub get_copy { my($this,$from,$to) = @_; return "($to) = ($from); /* CType.get_copy */" if !@{$this->{Chain}}; # strdup loses portability :( return "($to) = malloc(strlen($from)+1); strcpy($to,$from); /* CType.get_copy */" if $this->{Base} =~ /^\s*char\s*$/; return "($to) = newSVsv($from); /* CType.get_copy */" if $this->{Base} =~ /^\s*SV\s*$/; my $code = $this->get_malloc($to,$from); return "($to) = ($from); /* CType.get_copy */" 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 .= " if(!$deref0) {$deref1=0;} /* CType.get_copy */ else {int __malloc_ind_$no; for(__malloc_ind_$no = 0; __malloc_ind_$no < $arg; __malloc_ind_$no ++) {"; $deref0 .= "[__malloc_ind_$no]"; $deref1 .= "[__malloc_ind_$no]"; $close .= "}}"; } else { confess("Invalid decl @$_") } } $code .= "$prev $deref1 = $deref0; $close"; return $code; } sub get_free { my($this,$from) = @_; my $single_ptr = @{$this->{Chain}} == 1 && $this->{Chain}[0][0] eq 'PTR'; return "SvREFCNT_dec($from); /* CType.get_free */\n" if $this->{Base} =~ /^\s*SV\s*$/ and $single_ptr; return "free($from); /* CType.get_free */\n" if $this->{Base} =~ /^\s*char\s*$/ and $single_ptr; return "" if !@{$this->{Chain}} or $this->{Chain}[0][0] eq 'PTR'; croak("Can only free one layer!\n") if @{$this->{Chain}} > 1; "free($from); /* CType.get_free */\n"; } 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 .= "$assignto = malloc(sizeof(*$assignto) * $arg); /* CType.get_malloc */\n"; } else { confess("Invalid decl (@$_)") } } return $str; } sub is_array { my ($self) = @_; @{$self->{Chain}} && @{$self->{Chain}[-1]} && $self->{Chain}[-1][0] eq 'ARR' && !$self->{Chain}[-1][1]; } 1; PDL-2.085/Basic/Gen/PP/Signature.pm0000644000175000017500000001764714417631552016474 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,$pars,$bvalflag,$otherpars) = @_; $bvalflag ||= 0; my $this = bless {}, $type; my @objects = map PDL::PP::PdlParObj->new($_,$bvalflag, $this), nospacesplit ';',$pars; $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{qw(OtherNames OtherObjs OtherAnyOut OtherFlags)} = $this->_otherPars_nft($otherpars||''); $this->{IndNamesSorted} = [ sort keys %ind2obj ]; my $i=0; my %ind2index = map +($_=>$i++), @{$this->{IndNamesSorted}}; $this->{Ind2Index} = \%ind2index; $ind2obj{$_}->set_index($ind2index{$_}) for sort keys %ind2index; $this; } sub _otherPars_nft { my ($sig,$otherpars) = @_; my $dimobjs = $sig && $sig->dims_obj; my (@names,%types,$type,$any_out,%allflags); for (nospacesplit(';',$otherpars)) { my (%flags); if (s/^\s*$PDL::PP::PdlParObj::sqbr_re\s*//) { %flags = my %lflags = map +($_=>1), split /\s*,\s*/, my $opts = $1; confess "Can't have both [io] and [o]" if $lflags{o} && $lflags{io}; my $this_out = delete($lflags{o}) || delete($lflags{io}); confess "Invalid options '$opts' in '$_'" if keys %lflags; $any_out ||= $this_out; } if (/^\s*([^=]+?)\s*=>\s*(\S+)\s*$/) { # support 'int ndim => n;' syntax my ($ctype,$dim) = ($1,$2); print "OtherPars: setting dim '$dim' from '$ctype'\n" if $::PP_VERBOSE; $type = PDL::PP::CType->new($ctype); ($sig->{Ind2Obj}{$dim} ||= $dimobjs->get_indobj_make($dim))->set_from($type); } else { $type = PDL::PP::CType->new($_); } my $name = $type->protoname; confess "Invalid OtherPars name: $name" if $PDL::PP::PdlParObj::INVALID_PAR{$name}; push @names,$name; $types{$name} = $type; $types{"${name}_count"} = PDL::PP::CType->new("PDL_Indx ${name}_count") if $type->is_array; $allflags{$name} = \%flags; } (\@names,\%types,$any_out,\%allflags); } =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, $omit_count, $with_xs, $except) = @_; $except ||= {}; return $self->{OtherNames} if $omit_count && $omit_count > 0 && !keys %$except && $with_xs; return [] if $omit_count && $omit_count < 0; my $objs = $self->otherobjs; my @raw_names = grep !$except->{$_}, @{$self->{OtherNames}}; @raw_names = map $objs->{$_}->is_array ? ($_, "${_}_count") : $_, @raw_names if !$omit_count; @raw_names = grep !$objs->{$_}{WasDollar}, @raw_names if !$with_xs; \@raw_names; } sub otherobjs { $_[0]{OtherObjs} } sub other_any_out { $_[0]{OtherAnyOut} } sub other_is_flag { my $flag = $_[2]; my $has_count = (my $without_count = $_[1]) =~ s/_count$//; return $_[0]{OtherFlags}{$_[1]} && $_[0]{OtherFlags}{$_[1]}{$flag} if !$has_count; $_[0]{OtherFlags}{$without_count} && $_[0]{OtherFlags}{$without_count}{$flag}; } sub other_is_output { &other_is_out || &other_is_io } sub other_is_out { $_[0]->other_is_flag($_[1], 'o') } sub other_out { grep $_[0]->other_is_out($_), @{$_[0]{OtherNames}} } sub other_is_io { $_[0]->other_is_flag($_[1], 'io') } sub other_io { grep $_[0]->other_is_io($_), @{$_[0]{OtherNames}} } sub allnames { my ($self, $omit_count, $with_xs, $except) = @_; [ ($omit_count && $omit_count < 0) ? (grep $self->{Objects}{$_}{FlagCreateAlways}, @{$self->{Names}}) : (grep +(!$except || !$except->{$_}) && !$self->{Objects}{$_}{FlagTemp}, @{$self->{Names}}), @{$self->othernames(@_[1..3])}, ] } sub allobjs { my $pdltype = PDL::PP::CType->new("pdl *__foo__"); +{ ( map +($_,$pdltype), @{$_[0]{Names}} ), %{$_[0]->otherobjs} }; } sub alldecls { my ($self, $omit_count, $indirect, $with_xs, $except) = @_; my $objs = $self->allobjs; my @names = @{$self->allnames($omit_count, $with_xs, $except)}; $indirect = $indirect ? { map +($_=>$self->other_is_output($_)), @names } : {}; map $objs->{$_}->get_decl($_, {VarArrays2Ptrs=>1,AddIndirect=>$indirect->{$_}}), @names; } sub getcomp { my ($self) = @_; my $objs = $self->otherobjs; my @names = @{$self->othernames(0)}; my $indirect = { map +($_=>$self->other_is_output($_)), @names }; join "\n", map " $_;", grep $_, map $objs->{$_}->get_decl($_, {VarArrays2Ptrs=>1,AddIndirect=>$indirect->{$_}}), @names; } sub getfree { my ($self,$symbol) = @_; my $objs = $self->otherobjs; join '', map $objs->{$_}->get_free("\$$symbol($_)", { VarArrays2Ptrs => 1 }), @{$self->othernames(0)}; } sub getcopy { my ($self, $to_pat) = @_; my $objs = $self->otherobjs; PDL::PP::indent(2, join '', map $objs->{$_}->get_copy($_,sprintf $to_pat,$_)."\n", @{$self->othernames(0)}); } sub realdims { my $this = shift; [ map scalar @{$this->{Objects}{$_}{RawInds}}, @{$this->{Names}} ]; } sub creating { my $this = shift; confess "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}}; confess "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.085/Basic/Gen/PP/Dims.pm0000644000175000017500000000326414405450465015414 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) = @_; my ($name, $val) = $expr =~ /^([a-zA-Z0-9]+)(?:=([0-9]+))?$/ or confess "Invalid index expr '$expr'\n"; my $indobj = $this->{$name} //= PDL::PP::Ind->new($name); $indobj->add_value($val) if defined $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 broadcasting 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} // confess "unknown index for $_[0]{Name}"} 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.085/Basic/Gen/PP/dump.pp0000644000175000017500000000410714202424244015454 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.085/Basic/Gen/PP/PdlParObj.pm0000644000175000017500000001511014417132433016321 0ustar osboxesosboxespackage PDL::PP::PdlParObj; use strict; use warnings; use Carp; use PDL::Types ':All'; our %INVALID_PAR = map +($_=>1), qw( I ); my $typeregex = join '|', map $_->ppforcetype, types; my $complex_regex = join '|', qw(real complex); our $sqbr_re = qr/\[([^]]*)\]/x; our $pars_re = qr/^ \s*(?:($complex_regex|$typeregex)\b([+]*)|)\s* # $1,2: first option then plus (?:$sqbr_re)?\s* # $3: The initial [option] part (\w+) # $4: The name \(([^)]*)\) # $5: The indices /x; my %flag2info = ( io => [[qw(FlagW)]], o => [[qw(FlagOut FlagCreat FlagW)]], oca => [[qw(FlagOut FlagCreat FlagW FlagCreateAlways)]], t => [[qw(FlagTemp FlagCreat FlagW)]], phys => [[qw(FlagPhys)]], real => [[qw(FlagTypeOverride FlagReal)]], complex => [[qw(FlagTypeOverride FlagComplex)]], (map +($_->ppforcetype => [[qw(FlagTypeOverride 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,$sqbr_opt,$name,$inds) = map $_ // '', $1,$2,$3,$4,$5; print "PDL: '$opt1$opt_plus', '$sqbr_opt', '$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 ',',$sqbr_opt),($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}); $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} = [my @objs = map $dimsobj->get_indobj_make($_), @{$this->{RawInds}}]; my %indcount; $this->{IndCounts} = [ map 0+($indcount{$_->name}++), @objs ]; $this->{IndTotCounts} = [ map $indcount{$_->name}, @objs ]; } # do the dimension checking for perl level broadcasting # 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->broadcastids)[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 = 0; for my $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_substname { my($this,$ind) = @_; $this->{IndObjs}[$ind]->name.($this->{IndTotCounts}[$ind] > 1 ? $this->{IndCounts}[$ind] : ''); } sub get_incname { my($this,$ind,$for_local) = @_; return "inc_sizes[PDL_INC_ID(__privtrans->vtable,$this->{Number},$ind)]" if !$for_local; "__inc_$this->{Name}_".$this->get_substname($ind); } sub get_incregisters { my($this) = @_; return '' if scalar(@{$this->{IndObjs}}) == 0; 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;"; } 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 $_ in ($inds) (no spaces in => value)\n"; ($1,$2)} PDL::PP::Rule::Substitute::split_cpp($inds); # Generate the text my $text = "(${pdl}_datap)[" . join('+','0', map $this->do_indterm($pdl,$_,\%subst,$context), 0..$#{$this->{IndObjs}}) . "]"; # 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) = @_; '$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) = @_; my $substname = $this->get_substname($ind); # See if substitutions my $index = delete($subst->{$substname}) // # No => get the one from the nearest context. (grep $_ eq $substname, map $_->[1], reverse @$context)[0]; confess "Access Index not found: $pdl, $ind, @{[$this->{IndObjs}[$ind]->name]} On stack:".(join ' ',map {"($_->[0],$_->[1])"} @$context)."\n" if !defined $index; return "(".($this->get_incname($ind,1))."*($index))"; } sub get_xsdatapdecl { my($this,$ctype,$nulldatacheck) = @_; 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, $nulldatacheck)"; } 1; PDL-2.085/Basic/Gen/PP/PDLCode.pm0000644000175000017500000005654514417133350015736 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 { @{$_[0]}{qw(ParNames ParObjs)} } my @code_args_always = qw(BadFlag SignatureObj GenericTypes ExtraGenericSwitches HaveBroadcasting Name); sub make_args { my ($target) = @_; ("${target}CodeParsed", ["${target}CodeUnparsed","Bad${target}CodeUnparsed?",@code_args_always]); } # Do the appropriate substitutions in the code. sub new { my($class,$code,$badcode, $handlebad, $sig,$generictypes,$extrageneric,$havebroadcasting,$name, $dont_add_brcloop, $backcode, $nulldatacheck) = @_; 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::Broadcastloop class indicating the broadcastloop # is for writeback code (typically used for writeback of data from child to parent PDL $dont_add_brcloop ||= !$havebroadcasting; # 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_BRCLOOP!\n" if $dont_add_brcloop; 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 switches ftypes_vars => {}, ftypes_type => undef, Generictypes => $generictypes, # so that MacroAccess can check it Name => $name, NullDataCheck => $nulldatacheck, }, $class; my @codes = $code; push @codes, $badcode if $handlebad && ($code ne $badcode || $badcode =~ /PDL_BAD_CODE|PDL_IF_BAD/); my (@coderefs, @sizeprivs); for my $c (@codes) { # First, separate the code into an array of C fragments (strings), # variable references (strings starting with $) and # loops (array references, 1. item = variable. my ( $broadcastloops, $coderef, $sizeprivs ) = $this->separate_code( "{$c}" ); # Now, if there is no explicit broadcastlooping in the code, # enclose everything into it. if(!$broadcastloops && !$dont_add_brcloop) { print "Adding broadcastloop...\n" if $::PP_VERBOSE; $coderef = $coderef->enter(('PDL::PP::'.($backcode ? 'BackCode' : '').'BroadcastLoop')->new); } # Enclose it all in a generic switch. my $if_gentype = ($code.($badcode//'')) =~ /PDL_IF_GENTYPE_/; $coderef = $coderef->enter(PDL::PP::GenericSwitch->new($generictypes, undef, [grep {!$extrageneric->{$_}} @$parnames],'$PRIV(__datatype)',$if_gentype)); # Do we have extra generic switches? # If we do, first reverse the hash: my %glh; push @{$glh{$extrageneric->{$_}}},$_ for sort keys %$extrageneric; my $no = 0; $coderef = $coderef->enter(PDL::PP::GenericSwitch->new($generictypes,$no++, $glh{$_},$_,$if_gentype)) for sort keys %glh; push @coderefs, $coderef; push @sizeprivs, $sizeprivs; } amalgamate_sizeprivs(@sizeprivs) if @sizeprivs > 1; my $sizeprivs = $sizeprivs[0]; my $coderef = @coderefs > 1 ? PDL::PP::BadSwitch->new( @coderefs ) : $coderefs[0]; print "SIZEPRIVSX: ",(join ',',%$sizeprivs),"\n" if $::PP_VERBOSE; 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_brcloop?'':join '', map "$_\n", 'PDL_COMMENT("broadcastloop declarations")', 'int __brcloopval;', 'register PDL_Indx __tind0,__tind1; PDL_COMMENT("counters along dim")', 'register PDL_Indx __tnpdls = $PRIV(broadcast).npdls;', 'PDL_COMMENT("dims here are how many steps along those dims")', (map "register PDL_Indx __tinc0_$parnames->[$_] = PDL_BRC_INC(\$PRIV(broadcast).incs,__tnpdls,$_,0);", 0..$#$parnames), (map "register PDL_Indx __tinc1_$parnames->[$_] = PDL_BRC_INC(\$PRIV(broadcast).incs,__tnpdls,$_,1);", 0..$#$parnames), eol_protect( "#define ".$this->broadcastloop_macroname($backcode, 'START') . " " . $this->broadcastloop_start($this->func_name($backcode)) ), eol_protect( "#define ".$this->broadcastloop_macroname($backcode, 'END') . " " . $this->broadcastloop_end ), (grep $_, map $_->get_incregisters, @$pobjs{sort keys %$pobjs}), ). $this->params_declare. $coderef->get_str($this,[]) ; $this->{Code}; } # new # amalgamate sizeprivs from Code/BadCode segments # (sizeprivs is a simple hash, with each element # containing a string - see PDL::PP::Loop) sub amalgamate_sizeprivs { my ($sizeprivs, $bad_sizeprivs) = @_; 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 } } sub eol_protect { my ($text) = @_; join " \\\n", grep /\S/, split /\n/, $text; } sub params_declare { my ($this) = @_; my ($ord,$pdls) = $this->get_pdls; my %istyped = map +($_=>1), grep $pdls->{$_}{FlagTypeOverride}, @$ord; my @decls = map $_->get_xsdatapdecl($istyped{$_->name} ? "PDL_TYPE_PARAM_".$_->name : "PDL_TYPE_OP", $this->{NullDataCheck}), map $pdls->{$_}, @$ord; my @param_names = ("PDL_TYPE_OP", map "PDL_TYPE_PARAM_$_", grep $istyped{$_}, @$ord); <{Name}_$this->{NullDataCheck} #define PDL_DECLARE_PARAMS_$this->{Name}_$this->{NullDataCheck}(@{[join ',', @param_names]}) \\ @{[join " \\\n ", @decls]} #endif EOF } sub func_name { $_[1] ? "writebackdata" : "readdata" } sub broadcastloop_macroname { my ($this, $backcode, $which) = @_; "PDL_BROADCASTLOOP_${which}_$this->{Name}_".$this->func_name($backcode); } sub broadcastloop_start { my ($this, $funcname) = @_; my ($ord,$pdls) = $this->get_pdls; <{$ord->[$_]}->do_pointeraccess." += __offsp[$_];\n", 0..$#$ord ]} , (@{[ PDL::PP::indent 2, join "", map ",".$pdls->{$ord->[$_]}->do_pointeraccess." += __tinc1_$ord->[$_] - __tinc0_$ord->[$_] * __tdims0\n", 0..$#$ord ]} ), (@{[ PDL::PP::indent 2, join "", map ",".$pdls->{$ord->[$_]}->do_pointeraccess." += __tinc0_$ord->[$_]\n", 0..$#{$ord} ]} ) ) EOF } sub broadcastloop_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, $broadcastloops_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(..) %{ |\b(?:thread|broadcast)loop\s*%\{ # broadcastloop %{ |%} # %} |$)//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 =~ /^(?:thread|broadcast)loop\s*%\{/) { my $ob = PDL::PP::BroadcastLoop->new; push @{$stack_ref->[-1]},$ob; push @$stack_ref,$ob; $$broadcastloops_ref++; } elsif($control =~ /^%}/) { pop @$stack_ref; } else { my ($rest, @add) = $this->expand($control.$code); push @{$stack_ref->[-1]}, @add; $code = $rest; } } # while: $code } # my ( $broadcastloops, $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 $broadcastloops = 0; my $sizeprivs = {}; $this->process($code, \@stack, \$broadcastloops, $sizeprivs); ( $broadcastloops, $coderef, $sizeprivs ); } # sub: separate_code() my $macro_pat = qr/\w+/; sub expand { my ($this, $text) = @_; my (undef, $pdl, $inds, $rest) = PDL::PP::Rule::Substitute::macro_extract($text, $macro_pat); 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) = PDL::PP::Rule::Substitute::split_cpp($inds); } else { ($inds, $name) = PDL::PP::Rule::Substitute::split_cpp($inds); } @add = PDL::PP::BadAccess->new($opcode,$get,$name,$inds,$this); } elsif($this->{ParObjs}{$pdl}) {@add = PDL::PP::Access->new($pdl,$inds)} else { confess "unknown construct $pdl($inds)"; } ($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 myextraindent { 0 } sub myprelude {} sub mypostlude {} sub get_str { my ($this,$parent,$context) = @_; my $str = $this->myprelude($parent,$context); $str .= PDL::PP::indent 2, $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 .= PDL::PP::indent $this->myextraindent, 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]; } sub enter { my ($this, $new) = @_; push @$new, $this; $new; } ########################### # # 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 = <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 @{[ PDL::PP::indent 2, $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_COMMENT(\"Open $_\") register PDL_Indx $_; for($_=0; $_<(__$i->[0]_size); $_++) {"; $i; } @{$this->[0]}; $text; } sub mypostlude { my($this,$parent,$context) = @_; splice @$context, - ($#{$this->[0]}+1); return join '', map "}} PDL_COMMENT(\"Close $_\")", @{$this->[0]}; } package PDL::PP::GenericSwitch; use Carp; our @ISA = "PDL::PP::Block"; # make the typetable from info in PDL::Types use PDL::Types ':All'; my %type2canonical = map +($_->ppsym=>$_,$_->identifier=>$_), types(); my @typetable = map [$_->ppsym, $_], types(); sub get_generictyperecs { my($types) = @_; my @bad = grep !$type2canonical{$_}, @$types; confess "Invalid GenericType (@bad)!" if @bad; my %wanted; @wanted{map $type2canonical{$_}->ppsym, @$types} = (); [ map $_->[1], grep exists $wanted{$_->[0]}, @typetable ]; } # Types: BSULFD sub new { my ($type,$types,$name,$varnames,$whattype,$if_gentype) = @_; my %vars; @vars{@$varnames} = (); bless [get_generictyperecs($types), $name, \%vars, $whattype, $if_gentype], $type; } sub myoffs {5} sub myextraindent { 2 } 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[switch ($this->[3]) { PDL_COMMENT("Start generic switch")\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 %istyped = map +($_=>1), grep $pdls->{$_}{FlagTypeOverride}, @$ord; my @param_ctypes = ($item->ctype, map $pdls->{$_}->adjusted_type($item)->ctype, grep $istyped{$_}, @$ord); my $decls = keys %{$this->[2]} == @$ord ? "PDL_DECLARE_PARAMS_$parent->{Name}_$parent->{NullDataCheck}(@{[join ',', @param_ctypes]})\n" : join '', map $_->get_xsdatapdecl($_->adjusted_type($item)->ctype, $parent->{NullDataCheck}), map $parent->{ParObjs}{$_}, sort keys %{$this->[2]}; my @gentype_decls = !$this->[4] ? () : map "#define PDL_IF_GENTYPE_".uc($_)."(t,f) ". ($item->$_ ? 't' : 'f')."\n", @GENTYPE_ATTRS; "case @{[$item->sym]}: {\n" . PDL::PP::indent 2, join '', @gentype_decls, $decls; } sub myitemend { my ($this,$parent,$nth) = @_; my $item = $this->[0][$nth] || return ""; join '', "\n", (!$this->[4] ? () : map "#undef PDL_IF_GENTYPE_".uc($_)."\n", @GENTYPE_ATTRS), "} 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]}; " default: 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}\n"; } #### # # This relies on PP.pm making sure that initbroadcaststruct always sets # up the two first dimensions even when they are not necessary. # package PDL::PP::BroadcastLoop; 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->broadcastloop_macroname($backcode, 'START'); } sub mypostlude {my($this,$parent,$context,$backcode) = @_; $parent->broadcastloop_macroname($backcode, 'END'); } # Simple subclass of BroadcastLoop to implement writeback code # # package PDL::PP::BackCodeBroadcastLoop; use Carp; our @ISA = "PDL::PP::BroadcastLoop"; sub myprelude { my($this,$parent,$context,$backcode) = @_; # Set backcode flag if not defined. This will make the parent # myprelude emit proper writeback code $this->SUPER::myprelude($parent, $context, $backcode // 1); } sub mypostlude { my($this,$parent,$context,$backcode) = @_; # Set backcode flag if not defined. This will make the parent # mypostlude emit proper writeback code $this->SUPER::mypostlude($parent, $context, $backcode // 1); } ########################### # # 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 switch" 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) = @_; 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 $get \$${opcode}() macro on an" . " 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 switch 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 = PDL::PP::Rule::Substitute::split_cpp($inds); confess "Macroaccess: different nos of args $pdl (@{[scalar @lst]}=@lst) vs (@{[scalar @ilst]}=@ilst)\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 switch 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 switch" 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 switch" 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)->ppsym; } 1; PDL-2.085/Basic/Gen/Makefile.PL0000644000175000017500000000130114146003631015572 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.085/Basic/Gen/pptemplate0000755000175000017500000000777114014062163015741 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.085/Basic/Gen/Inline/0000755000175000017500000000000014556074541015060 5ustar osboxesosboxesPDL-2.085/Basic/Gen/Inline/MakePdlppInstallable.pm0000644000175000017500000000531614202424257021442 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.085/Basic/Gen/Inline/Pdlpp.pm0000644000175000017500000003423014202424244016462 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.085/Basic/Gen/Inline/Makefile.PL0000644000175000017500000000040314146003631017012 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.085/Basic/Lite.pm0000644000175000017500000000214614146003631014352 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.085/Basic/Matrix.pm0000644000175000017500000002122314265027513014725 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; } sub inv { shift->transpose->SUPER::inv->transpose } =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.085/Basic/AutoLoader.pm0000644000175000017500000002052214202424257015516 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.085/Basic/Slices/0000755000175000017500000000000014556074541014353 5ustar osboxesosboxesPDL-2.085/Basic/Slices/slices.pd0000644000175000017500000024507614555164574016205 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 # $::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 broadcast slightly differently. =over 3 =item * C uses direct broadcasting for 1-D indexing across the 0 dim of C<$source>. It can broadcast over source broadcast dims or index broadcast 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 broadcasting 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 broadcasting 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 broadcasting: 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 = 'register PDL_Indx this_ind = $ind(); if( PDL_IF_BAD($ISBADVAR(this_ind,ind) ||,) this_ind<0 || this_ind>=$SIZE(n) ) { $CROAK("invalid index %"IND_FLAG" (valid range 0..%"IND_FLAG")", this_ind,$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 . ' $c() = $a(n => this_ind);', BackCode => $index_init . ' $a(n => this_ind) = $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 => pp_line_numbers(__LINE__, <<'EOF'), PDL_Indx i; for(i=0;i<$SIZE(m);i++) { PDL_Indx this_ind = $ind(m=>i); PDL_IF_BAD(if( $ISBADVAR(this_ind, ind) ) { $SETBAD(c(m=>i)); } else,) { if( this_ind<0 || this_ind >= $SIZE(n) ) { $CROAK("invalid index %"IND_FLAG" at pos %"IND_FLAG" (valid range 0..%"IND_FLAG")", this_ind, i, $SIZE(n)-1); } $c(m=>i) = $a(n=>this_ind); } } EOF BackCode => pp_line_numbers(__LINE__, <<'EOF'), PDL_Indx i; for(i=0;i<$SIZE(m);i++) { PDL_Indx this_ind = $ind(m=>i); PDL_IF_BAD(if( $ISBADVAR(this_ind, ind) ) { /* do nothing */ } else,) { if( this_ind<0 || this_ind >= $SIZE(n) ) { $CROAK("invalid index %"IND_FLAG" at pos %"IND_FLAG" (valid range 0..%"IND_FLAG")", this_ind, i, $SIZE(n)-1); } $a(n=>this_ind) = $c(m=>i); } } EOF Doc => $doc, BadDoc => 'index1d propagates BAD index elements to the output variable.' ); my $index2d_init = pp_line_numbers(__LINE__, <<'EOF'); register PDL_Indx this_ind_a = $inda(),this_ind_b = $indb(); if( PDL_IF_BAD($ISBADVAR(this_ind_a,inda) ||,) this_ind_a<0 || this_ind_a>=$SIZE(na) ) $CROAK("invalid x-index %"IND_FLAG" (valid range 0..%"IND_FLAG")", this_ind_a,$SIZE(na)-1); if( PDL_IF_BAD($ISBADVAR(this_ind_b,indb) ||,) this_ind_b<0 || this_ind_b>=$SIZE(nb) ) $CROAK("invalid y-index %"IND_FLAG" (valid range 0..%"IND_FLAG")", this_ind_b,$SIZE(nb)-1); EOF 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 . pp_line_numbers(__LINE__-1, ' $c() = $a(na => this_ind_a, nb => this_ind_b);'), BackCode => $index2d_init . pp_line_numbers(__LINE__-1, ' $a(na => this_ind_a, nb => this_ind_b) = $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 pp_def( 'rangeb', OtherPars => 'pdl *ind_pdl; SV *size_sv; 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. =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 broadcasts over both C<$index> and C<$source>. Because implicit broadcasting can happen in a couple of ways, a little thought is needed. The returned dimension list is stacked up like this: (index broadcast dims), (index dims (size)), (source broadcast 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, broadcasted 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 broadcast dims, because adding more dims to C<$source> just tacks extra dims on the end of the output. Each source broadcast 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) # Broadcast 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 = PDL::RandVar->new->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); $x($_ - 1) .= $_ for 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 broadcast 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) # nitems: total number of list elements (product of itdims) # itdim: number of index broadcast dimensions # ntsize: number of nonzero size dimensions # bsize: Number of independently specified boundary conditions # nsizes: Number of independently specified range dim sizes # sizes: array of range sizes, indexed (0..rdim-1). A zero element means # that the dimension is omitted from the child dim list. # itdims: Size of each index broadcast dimension, indexed (0..itdim-1) # corners: parent coordinates of each corner, running fastest over coord index. # (indexed 0 .. (nitems-1)*(rdim)+rdim-1) # boundary: Array containing all the boundary condition specs 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)]; char size_pdl_destroy; char ind_pdl_destroy; ', MakeComp => pp_line_numbers(__LINE__, <<'EOD-MakeComp'), pdl *size_pdl; PDL_RETERROR(PDL_err, PDL->make_physdims(ind_pdl)); $COMP(size_pdl_destroy) = $COMP(ind_pdl_destroy) = 0; /* 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"); $COMP(ind_pdl_destroy) = 1; 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 arrays 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 */ PDL_Indx i; for (i=0;i<$COMP(rdim);i++) $COMP(boundary)[i] = 0; } else { PDL_Indx i; for(i=0;i<$COMP(rdim);i++) { switch(bstr[PDLMIN(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-broadcast 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_sv == NULL) || !SvOK(size_sv) ) { // 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_sv))) /* 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"); $COMP(size_pdl_destroy) = 1; 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 broadcasts */ 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)); if ($COMP(ind_pdl_destroy)) PDL->destroy(ind_pdl); /* finished with our copy */ if ($COMP(size_pdl_destroy)) PDL->destroy(size_pdl); /* finished with our copy */ EOD-MakeComp RedoDims => pp_line_numbers(__LINE__, <<'EOD-RedoDims'), PDL_Indx stdim = $PDL(PARENT)->ndims - $COMP(rdim); PDL_Indx dim,inc; PDL_Indx i,rdvalid; // Speed bump for ludicrous cases if( $COMP(rdim) > $PDL(PARENT)->ndims+5 && $COMP(nsizes) != $COMP(rdim)) { $CROAK( "Ludicrous number of extra dims in range index; leaving child null.\n" " (%"IND_FLAG" implicit dims is > 5; index has %"IND_FLAG" dims; source has %"IND_FLAG" dim%s.)\n" " This often means that your index PDL is incorrect.\n" " To avoid this message, allocate dummy dims in\n" " the source or use %"IND_FLAG" dims in range's size field.\n", $COMP(rdim)-$PDL(PARENT)->ndims,$COMP(rdim),$PDL(PARENT)->ndims, $PDL(PARENT)->ndims>1?"s":"",$COMP(rdim) ); } if(stdim < 0) stdim = 0; /* Set dimensionality of child */ $PDL(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++; $PDL(CHILD)->dimincs[dim] = inc; inc *= ($PDL(CHILD)->dims[dim++] = $COMP(sizes)[i]); /* assignment */ } } /* Copy index broadcast dimensions to child */ for(dim=0; dim<$COMP(itdim); dim++) { $PDL(CHILD)->dimincs[dim] = inc; inc *= ($PDL(CHILD)->dims[dim] = $COMP(itdims)[dim]); /* assignment */ } /* Copy source broadcast dimensions to child */ dim = $COMP(itdim) + rdvalid; for(i=0;idimincs[dim] = inc; inc *= ($PDL(CHILD)->dims[dim++] = $PDL(PARENT)->dims[i+$COMP(rdim)]); /* assignment */ } /* Cover bizarre case where the source PDL is empty - in that case, change */ /* all non-barfing boundary conditions to truncation, since we have no data */ /* to reflect, extend, or mirror. */ if($PDL(PARENT)->dims[0] == 0) { for(dim=0; dim<$COMP(rdim); dim++) { if($COMP(boundary)[dim]) $COMP(boundary)[dim] = 1; // force truncation } } $PDL(CHILD)->datatype = $PDL(PARENT)->datatype; $SETDIMS(); EOD-RedoDims EquivCPOffsCode => pp_line_numbers(__LINE__, <<'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 broadcast 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 broadcast dims (above rdim). */ do { PDL_Indx poff1 = poff; PDL_Indx coff1 = coff; /* Accumulate the offset due to source broadcasting */ 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 broadcast iterator */ for( k=$COMP(rdim); k < pdim && (++(iter2[k]) >= $PDL(PARENT)->dims[k]); k++) iter2[k] = 0; } while(k < pdim); /* end of source-broadcast 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 ); pp_def( 'rld', GenericTypes => [ppdefs_all], Pars=>'indx a(n); b(n); [o]c(m);', PMCode =>pp_line_numbers(__LINE__, <<'EOD'), sub PDL::rld { my ($x,$y) = @_; my ($c); if ($#_ == 2) { $c = $_[2]; } else { # XXX Need to improve emulation of broadcasting 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 => pp_line_numbers(__LINE__, <<'EOF'), PDL_Indx i,j=0,an; $GENERIC(b) bv; loop (n) %{ an = $a(); bv = $b(); for (i=0;ij) = bv; j++; } %} EOF 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 ); pp_def( 'rle', GenericTypes => [ppdefs_all], Pars=>'c(n); indx [o]a(m); [o]b(m);', RedoDimsCode=>'$SIZE(m)=$SIZE(n);', PMCode =>pp_line_numbers(__LINE__, <<'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 =>pp_line_numbers(__LINE__, <<'EOF'), 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; } EOF 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 broadcast 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 ); pp_def('rlevec', Pars => "c(M,N); indx [o]a(N); [o]b(M,N)", Code =>pp_line_numbers(__LINE__, <<'EOC'), PDL_Indx cn,bn=0, sn=$SIZE(N), matches; loop (M) %{ $b(N=>0)=$c(N=>0); %} $a(N=>0) = 1; for (cn=1; cncn) != $b(N=>bn)) { matches=0; break; } %} if (matches) { $a(N=>bn)++; } else { bn++; loop (M) %{ $b(N=>bn) = $c(N=>cn); %} $a(N=>bn) = 1; } } for (bn++; bnbn) = 0; loop (M) %{ $b(N=>bn) = 0; %} } EOC Doc =><<'EOD', =for ref Run-length encode a set of vectors. Higher-order rle(), for use with qsortvec(). Given set of vectors $c, generate a vector $a with the number of occurrences of each element (where an "element" is a vector of length $M occurring in $c), and a set of vectors $b containing the unique values. As for rle(), only the elements up to the first instance of 0 in $a should be considered. Can be used together with clump() to run-length encode "values" of arbitrary dimensions. Can be used together with rotate(), cat(), append(), and qsortvec() to count N-grams over a 1d PDL. See also: L, L, L Contributed by Bryan Jurish Emoocow@cpan.orgE. EOD ); pp_def('rldvec', Pars => 'indx a(N); b(M,N); [o]c(M,N)', PMCode =>pp_line_numbers(__LINE__, <<'EOC'), sub PDL::rldvec { my ($a,$b,$c) = @_; if (!defined($c)) { # XXX Need to improve emulation of threading in auto-generating c my ($rowlen) = $b->dim(0); my ($size) = $a->sumover->max; my (undef, @dims) = $a->dims; $c = $b->zeroes($b->type,$rowlen,$size,@dims); } &PDL::_rldvec_int($a,$b,$c); return $c; } EOC Code =>pp_line_numbers(__LINE__, <<'EOC'), PDL_Indx cn=0; loop (N) %{ PDL_Indx i, nrows = $a(); for (i=0; icn) = $b(); %} cn++; } %} EOC Doc =><<'EOD' =for ref Run-length decode a set of vectors, akin to a higher-order rld(). Given a vector $a() of the number of occurrences of each row, and a set $c() of row-vectors each of length $M, run-length decode to $c(). Can be used together with clump() to run-length decode "values" of arbitrary dimensions. See also: L. Contributed by Bryan Jurish Emoocow@cpan.orgE. EOD ); pp_def('rleseq', Pars => "c(N); indx [o]a(N); [o]b(N)", Code =>pp_line_numbers(__LINE__, <<'EOC'), PDL_Indx j=0, sizeN=$SIZE(N); $GENERIC(c) coff; coff = $c(N=>0); $b(N=>0) = coff; $a(N=>0) = 0; loop (N) %{ if ($c() == coff+$a(N=>j)) { $a(N=>j)++; } else { j++; $b(N=>j) = coff = $c(); $a(N=>j) = 1; } %} for (j++; jj) = 0; $b(N=>j) = 0; } EOC Doc =><<'EOD', =for ref Run-length encode a vector of subsequences. Given a vector of $c() of concatenated variable-length, variable-offset subsequences, generate a vector $a containing the length of each subsequence and a vector $b containing the subsequence offsets. As for rle(), only the elements up to the first instance of 0 in $a should be considered. See also L. Contributed by Bryan Jurish Emoocow@cpan.orgE. EOD ); pp_def('rldseq', Pars => 'indx a(N); b(N); [o]c(M)', PMCode =>pp_line_numbers(__LINE__, <<'EOC'), sub PDL::rldseq { my ($a,$b,$c) = @_; if (!defined($c)) { my $size = $a->sumover->max; my (undef, @dims) = $a->dims; $c = $b->zeroes($b->type,$size,@dims); } &PDL::_rldseq_int($a,$b,$c); return $c; } EOC Code =>pp_line_numbers(__LINE__, <<'EOC'), size_t mi=0; loop (N) %{ size_t len = $a(), li; for (li=0; li < len; ++li, ++mi) { $c(M=>mi) = $b() + li; } %} EOC Doc =><<'EOD' =for ref Run-length decode a subsequence vector. Given a vector $a() of sequence lengths and a vector $b() of corresponding offsets, decode concatenation of subsequences to $c(), as for: $c = null; $c = $c->append($b($_)+sequence($a->type,$a($_))) foreach (0..($N-1)); See also: L. Contributed by Bryan Jurish Emoocow@cpan.orgE. EOD ); pp_add_exported('','rleND rldND'); pp_addpm(<<'EOF'); =head2 rleND =for sig Signature: (data(@vdims,N); int [o]counts(N); [o]elts(@vdims,N)) =for ref Run-length encode a set of (sorted) n-dimensional values. Generalization of rle() and vv_rlevec(): given set of values $data, generate a vector $counts with the number of occurrences of each element (where an "element" is a matrix of dimensions @vdims occurring as a sequential run over the final dimension in $data), and a set of vectors $elts containing the elements which begin a run. Really just a wrapper for clump() and rlevec(). See also: L, L. Contributed by Bryan Jurish Emoocow@cpan.orgE. =cut *PDL::rleND = \&rleND; sub rleND { my $data = shift; my @vdimsN = $data->dims; ##-- construct output pdls my $counts = $#_ >= 0 ? $_[0] : zeroes(long, $vdimsN[$#vdimsN]); my $elts = $#_ >= 1 ? $_[1] : zeroes($data->type, @vdimsN); ##-- guts: call rlevec() rlevec($data->clump($#vdimsN), $counts, $elts->clump($#vdimsN)); return ($counts,$elts); } =head2 rldND =for sig Signature: (int counts(N); elts(@vdims,N); [o]data(@vdims,N);) =for ref Run-length decode a set of (sorted) n-dimensional values. Generalization of rld() and rldvec(): given a vector $counts() of the number of occurrences of each @vdims-dimensioned element, and a set $elts() of @vdims-dimensioned elements, run-length decode to $data(). Really just a wrapper for clump() and rldvec(). See also: L, L. Contributed by Bryan Jurish Emoocow@cpan.orgE. =cut *PDL::rldND = \&rldND; sub rldND { my ($counts,$elts) = (shift,shift); my @vdimsN = $elts->dims; ##-- construct output pdl my ($data); if ($#_ >= 0) { $data = $_[0]; } else { my $size = $counts->sumover->max; ##-- get maximum size for Nth-dimension for small encodings my @countdims = $counts->dims; shift(@countdims); $data = zeroes($elts->type, @vdimsN, @countdims); } ##-- guts: call rldvec() rldvec($counts, $elts->clump($#vdimsN), $data->clump($#vdimsN)); return $data; } EOF # the perl wrapper clump is now defined in Core.pm # this is just the low level interface pp_def( '_clump_int', OtherPars => 'PDL_Indx n', P2Child => 1, RedoDims => pp_line_numbers(__LINE__, <<'EOF'), /* truncate overly long clumps to just clump existing dimensions */ if($COMP(n) > $PDL(PARENT)->ndims) $COMP(n) = $PDL(PARENT)->ndims; if($COMP(n) < -1) $COMP(n) = $PDL(PARENT)->ndims + $COMP(n) + 1; PDL_Indx nrem = ($COMP(n) == -1 ? $PDL(PARENT)->broadcastids[0] : $COMP(n)); $SETNDIMS($PDL(PARENT)->ndims - nrem + 1); PDL_Indx i, d1=1; for(i=0; idims[i]; } $PDL(CHILD)->dims[0] = d1; for(; i<$PDL(PARENT)->ndims; i++) { $PDL(CHILD)->dims[i-nrem+1] = $PDL(PARENT)->dims[i]; } $SETDIMS(); $SETDELTABROADCASTIDS(1-nrem); EOF EquivCPOffsCode => pp_line_numbers(__LINE__, <<'EOF'), PDL_Indx i; for(i=0; i<$PDL(CHILD)->nvals; i++) { $EQUIVCPOFFS(i,i); } EOF TwoWay => 1, Doc => 'internal', ); pp_def( 'xchg', OtherPars => 'PDL_Indx n1; PDL_Indx n2;', TwoWay => 1, P2Child => 1, AffinePriv => 1, EquivDimCheck =>pp_line_numbers(__LINE__, <<'EOF'), if ($COMP(n1) <0) $COMP(n1) += $PDL(PARENT)->broadcastids[0]; if ($COMP(n2) <0) $COMP(n2) += $PDL(PARENT)->broadcastids[0]; if (PDLMIN($COMP(n1),$COMP(n2)) <0 || PDLMAX($COMP(n1),$COMP(n2)) >= $PDL(PARENT)->broadcastids[0]) $CROAK("One of dims %"IND_FLAG", %"IND_FLAG" out of range: should be 0<=dim<%"IND_FLAG"", $COMP(n1),$COMP(n2),$PDL(PARENT)->broadcastids[0]); EOF EquivPDimExpr =>pp_line_numbers(__LINE__, <<'EOF'), (($CDIM == $COMP(n1)) ? $COMP(n2) : ($CDIM == $COMP(n2)) ? $COMP(n1) : $CDIM) EOF 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 broadcast() [I think] # a quicker way to do the reorder return $pdl->broadcast(@newDimOrder)->unbroadcast(0); } EOD 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 =>pp_line_numbers(__LINE__, <<'EOF'), if ($COMP(n1) <0) $COMP(n1) += $PDL(PARENT)->broadcastids[0]; if ($COMP(n2) <0) $COMP(n2) += $PDL(PARENT)->broadcastids[0]; if (PDLMIN($COMP(n1),$COMP(n2)) <0 || PDLMAX($COMP(n1),$COMP(n2)) >= $PDL(PARENT)->broadcastids[0]) $CROAK("One of dims %"IND_FLAG", %"IND_FLAG" out of range: should be 0<=dim<%"IND_FLAG"", $COMP(n1),$COMP(n2),$PDL(PARENT)->broadcastids[0]); EOF EquivPDimExpr =>pp_line_numbers(__LINE__, <<'EOF'), ( $COMP(n1) == $COMP(n2) ? $CDIM : $COMP(n1) < $COMP(n2) ? EQUIVDIM($COMP(n1),$COMP(n2),$CDIM,1) : EQUIVDIM($COMP(n1),$COMP(n2),$CDIM,-1) ) EOF 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, ' PDL_Indx nthp,nthc,nthd, cd = $COMP(whichdims)[0]; $SETNDIMS($PDL(PARENT)->ndims-$COMP(whichdims_count)+1); $DOPRIVALLOC(); $PRIV(offs) = 0; if ($COMP(whichdims)[$COMP(whichdims_count)-1] >= $PDL(PARENT)->ndims || $COMP(whichdims)[0] < 0) $CROAK("dim out of range"); nthd=0; nthc=0; for(nthp=0; nthp<$PDL(PARENT)->ndims; nthp++) if (nthd < $COMP(whichdims_count) && nthp == $COMP(whichdims)[nthd]) { if (!nthd) { $PDL(CHILD)->dims[cd] = $PDL(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($PDL(CHILD)->dims[cd] != $PDL(PARENT)->dims[nthp]) { $CROAK("Different dims %"IND_FLAG" and %"IND_FLAG"", $PDL(CHILD)->dims[cd], $PDL(PARENT)->dims[nthp]); } $PRIV(incs)[cd] += $PDL(PARENT)->dimincs[nthp]; } else { $PRIV(incs)[nthc] = $PDL(PARENT)->dimincs[nthp]; $PDL(CHILD)->dims[nthc] = $PDL(PARENT)->dims[nthp]; nthc++; } $SETDIMS(); '), PMCode =>pp_line_numbers(__LINE__, <<'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 broadcastids 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 ); 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 => pp_line_numbers(__LINE__, <<'EOF'), PDL_Indx i; if ($COMP(nthdim) < 0) /* the usual conventions */ $COMP(nthdim) += $PDL(PARENT)->ndims; if ($COMP(nthdim) < 0 || $COMP(nthdim) >= $PDL(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($PDL(PARENT)->ndims+1); $DOPRIVALLOC(); for(i=0; i<$COMP(nthdim); i++) { $PDL(CHILD)->dims[i] = $PDL(PARENT)->dims[i]; $PRIV(incs)[i] = $PDL(PARENT)->dimincs[i]; } $PDL(CHILD)->dims[i] = $PDL(PARENT)->dims[i] - $COMP(step) * ($COMP(n)-1); if ($PDL(CHILD)->dims[i] < 1) $CROAK("product of step size and number of lags too large"); $PDL(CHILD)->dims[i+1] = $COMP(n); $PRIV(incs)[i] = ($PDL(PARENT)->dimincs[i]); $PRIV(incs)[i+1] = - $PDL(PARENT)->dimincs[i] * $COMP(step); $PRIV(offs) += ($PDL(CHILD)->dims[i+1] - 1) * (-$PRIV(incs)[i+1]); i++; for(; i<$PDL(PARENT)->ndims; i++) { $PDL(CHILD)->dims[i+1] = $PDL(PARENT)->dims[i]; $PRIV(incs)[i+1] = $PDL(PARENT)->dimincs[i]; } $SETDIMS(); EOF ); pp_def( 'splitdim', Doc => <<'EOD', =for ref Splits a dimension in the parent ndarray (opposite of L). As of 2.076, throws exception if non-divisible C given, and can give negative C which then counts backwards. =for example After $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 => pp_line_numbers(__LINE__, <<'EOF'), PDL_Indx i = $COMP(nthdim); PDL_Indx nsp = $COMP(nsp); if(nsp == 0) {$CROAK("Cannot split to 0\n");} if (i < 0) i = $COMP(nthdim) += $PDL(PARENT)->ndims; if (i < 0 || i >= $PDL(PARENT)->ndims) $CROAK("nthdim %"IND_FLAG" after adjusting for negative must not be negative or greater or equal to number of dims %"IND_FLAG"\n", i, $PDL(PARENT)->ndims); if (nsp > $PDL(PARENT)->dims[i]) $CROAK("nsp %"IND_FLAG" cannot be greater than dim %"IND_FLAG"\n", nsp, $PDL(PARENT)->dims[i]); if (($PDL(PARENT)->dims[i] % nsp) != 0) $CROAK("nsp %"IND_FLAG" non-divisible into dim %"IND_FLAG"\n", nsp, $PDL(PARENT)->dims[i]); $PRIV(offs) = 0; $SETNDIMS($PDL(PARENT)->ndims+1); $DOPRIVALLOC(); for(i=0; i<$COMP(nthdim); i++) { $PDL(CHILD)->dims[i] = $PDL(PARENT)->dims[i]; $PRIV(incs)[i] = $PDL(PARENT)->dimincs[i]; } $PDL(CHILD)->dims[i] = $COMP(nsp); $PDL(CHILD)->dims[i+1] = $PDL(PARENT)->dims[i] / $COMP(nsp); $PRIV(incs)[i] = $PDL(PARENT)->dimincs[i]; $PRIV(incs)[i+1] = $PDL(PARENT)->dimincs[i] * $COMP(nsp); i++; for(; i<$PDL(PARENT)->ndims; i++) { $PDL(CHILD)->dims[i+1] = $PDL(PARENT)->dims[i]; $PRIV(incs)[i+1] = $PDL(PARENT)->dimincs[i]; } $SETDIMS(); EOF ); my $rotate_code = pp_line_numbers(__LINE__, <<'EOF'); 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( 'broadcastI', Doc => <<'EOD', =for ref internal Put some dimensions to a broadcastid. =for example $y = $x->broadcastI(0,1,5); # broadcast 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 => pp_line_numbers(__LINE__, <<'EOF'), 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 %"IND_FLAG" %"IND_FLAG" %"IND_FLAG"", i,j,$COMP(whichdims)[i]); } if($COMP(whichdims)[i] != -1) { $COMP(nrealwhichdims) ++; } } EOF RedoDims => pp_line_numbers(__LINE__, <<'EOF'), PDL_Indx nthc,i,j,flag; $SETNDIMS($PDL(PARENT)->ndims); $DOPRIVALLOC(); $PRIV(offs) = 0; nthc=0; for(i=0; i<$PDL(PARENT)->ndims; i++) { flag=0; if($PDL(PARENT)->nbroadcastids > $COMP(id) && $COMP(id) >= 0 && i == $PDL(PARENT)->broadcastids[$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; } $PDL(CHILD)->dims[nthc] = $PDL(PARENT)->dims[i]; $PRIV(incs)[nthc] = $PDL(PARENT)->dimincs[i]; nthc++; } for(i=0; i<$COMP(whichdims_count); i++) { PDL_Indx cdim,pdim; cdim = i + ($PDL(PARENT)->nbroadcastids > $COMP(id) && $COMP(id) >= 0? $PDL(PARENT)->broadcastids[$COMP(id)] : $PDL(PARENT)->ndims) - $COMP(nrealwhichdims); pdim = $COMP(whichdims)[i]; if(pdim == -1) { $PDL(CHILD)->dims[cdim] = 1; $PRIV(incs)[cdim] = 0; } else { $PDL(CHILD)->dims[cdim] = $PDL(PARENT)->dims[pdim]; $PRIV(incs)[cdim] = $PDL(PARENT)->dimincs[pdim]; } } $SETDIMS(); PDL_RETERROR(PDL_err, PDL->reallocbroadcastids($PDL(CHILD), PDLMAX($COMP(id)+1, $PDL(PARENT)->nbroadcastids))); for(i=0; i<$PDL(CHILD)->nbroadcastids-1; i++) { $PDL(CHILD)->broadcastids[i] = ($PDL(PARENT)->nbroadcastids > i ? $PDL(PARENT)->broadcastids[i] : $PDL(PARENT)->ndims) + (i <= $COMP(id) ? - $COMP(nrealwhichdims) : $COMP(whichdims_count) - $COMP(nrealwhichdims)); } $PDL(CHILD)->broadcastids[$PDL(CHILD)->nbroadcastids-1] = $PDL(CHILD)->ndims; EOF ); pp_def( 'unbroadcast', Doc => <<'EOD', =for ref All broadcasted dimensions are made real again. See [TBD Doc] for details and examples. =cut EOD P2Child => 1, TwoWay => 1, AffinePriv => 1, OtherPars => 'PDL_Indx atind;', RedoDims => pp_line_numbers(__LINE__, <<'EOF'), PDL_Indx i; $SETNDIMS($PDL(PARENT)->ndims); $DOPRIVALLOC(); $PRIV(offs) = 0; for(i=0; i<$PDL(PARENT)->ndims; i++) { PDL_Indx corc; if(i<$COMP(atind)) { corc = i; } else if(i < $PDL(PARENT)->broadcastids[0]) { corc = i + $PDL(PARENT)->ndims-$PDL(PARENT)->broadcastids[0]; } else { corc = i - $PDL(PARENT)->broadcastids[0] + $COMP(atind); } $PDL(CHILD)->dims[corc] = $PDL(PARENT)->dims[i]; $PRIV(incs)[corc] = $PDL(PARENT)->dimincs[i]; } $SETDIMS(); EOF ); 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 = PDL->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 the 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 => pp_line_numbers(__LINE__, <<'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). $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 => 'PDL_Indx 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 => pp_line_numbers(__LINE__, <<'SLICE-MC'), PDL_Indx nargs = 0; pdl_slice_args *argsptr = arglist; while (argsptr) nargs++, argsptr = argsptr->next; $COMP(nargs) = nargs; $DOCOMPALLOC(); PDL_Indx i, 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 => pp_line_numbers(__LINE__, <<'EOF'), PDL_Indx i; PDL_Indx PDIMS; PDL_Indx o_ndims_extra = PDLMAX(0, $PDL(PARENT)->ndims - $COMP(idim_top)); /* slurped dims from the arg parsing, plus any extra broadcast 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($PDL(CHILD), 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. */ $PDL(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] < $PDL(PARENT)->ndims ? $PDL(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) ) { $PDL(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($PDL(CHILD), PDL_PARENTDIMSCHANGED, 0); if(i >= $PDL(PARENT)->ndims) { $CROAK("slice has too many dims (indexes dim %"IND_FLAG"; highest is %"IND_FLAG")",i,$PDL(PARENT)->ndims-1); } else { $CROAK("slice starts out of bounds in pos %"IND_FLAG" (start is %"IND_FLAG"; source dim %"IND_FLAG" runs 0 to %"IND_FLAG")",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 * $PDL(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($PDL(CHILD), PDL_PARENTDIMSCHANGED, 0); $CROAK("slice ends out of bounds in pos %"IND_FLAG" (end is %"IND_FLAG"; source dim %"IND_FLAG" runs 0 to %"IND_FLAG")",i,end,$COMP(idim)[i],pdsize-1); } /* regularize inc */ PDL_Indx inc = $COMP(inc)[i]; if(!inc) inc = (start <= end) ? 1 : -1; $PDL(CHILD)->dims[ $COMP(odim)[i] ] = PDLMAX(0, (end - start + inc) / inc); $PRIV( incs )[ $COMP(odim)[i] ] = $PDL(PARENT)->dimincs[ $COMP(idim)[i] ] * inc; $PRIV(offs) += start * $PDL(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 broadcast dimensions as needed. idim and odim persist from the parsing loop */ /* up above. */ for(i=0; idims[ $COMP(odim_top) + i ] = $PDL(PARENT)->dims[ $COMP(idim_top) + i ]; $PRIV(incs)[ $COMP(odim_top) + i ] = $PDL(PARENT)->dimincs[ $COMP(idim_top) + i ]; } $SETDIMS(); EOF ); pp_addpm({At => '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.085/Basic/Slices/Makefile.PL0000644000175000017500000000040514112170323016303 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.085/Basic/Math/0000755000175000017500000000000014556074541014022 5ustar osboxesosboxesPDL-2.085/Basic/Math/const.c0000644000175000017500000000401214173310620015273 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.085/Basic/Math/quiet_nan.c0000644000175000017500000000034314173310620016133 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.085/Basic/Math/cpoly.c0000644000175000017500000004563614173310620015314 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.085/Basic/Math/math.pd0000644000175000017500000002227714226452055015304 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" extern double ndtri(double); '); 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( 'isfinite', Pars => 'a(); int [o]mask();', Inplace => 1, HandleBad => 1, Code =>' broadcastloop %{ $mask() = isfinite((double) $a()) != 0 PDL_IF_BAD(&& $ISGOOD($a()),); %} $PDLSTATESETGOOD(mask); ', 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 SQRTH; PDL_IF_BAD(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 => 'PDL_IF_BAD(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) = $SIZE(n)-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.085/Basic/Math/protos.h0000644000175000017500000000112414202424257015506 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.085/Basic/Math/polevl.c0000644000175000017500000000311414173310620015450 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.085/Basic/Math/mconf.h0000644000175000017500000001053114202424257015264 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.085/Basic/Math/ndtri.c0000644000175000017500000001012114173310620015263 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.085/Basic/Math/NOTES0000644000175000017500000000247613265417442014643 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.085/Basic/Math/mtherr.c0000644000175000017500000000447714173310620015465 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.085/Basic/Math/jn.c0000644000175000017500000000356214173310620014565 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.085/Basic/Math/j0.c0000644000175000017500000001274714173310620014474 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.085/Basic/Math/j1.c0000644000175000017500000001133614173310620014466 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.085/Basic/Math/ndtr.c0000644000175000017500000000546014202424257015131 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.085/Basic/Math/cpoly.h0000644000175000017500000000043614160714722015315 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.085/Basic/Math/infinity.c0000644000175000017500000000024414173310620016001 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.085/Basic/Math/yn.c0000644000175000017500000000336014173310620014600 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.085/Basic/Math/Makefile.PL0000644000175000017500000000653214202424257015771 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.085/Basic/Math/rint.c0000644000175000017500000000263414173310620015131 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.085/Basic/Pod/0000755000175000017500000000000014556074541013653 5ustar osboxesosboxesPDL-2.085/Basic/Pod/Graphics.pod0000644000175000017500000001075114202424257016112 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 broadcasting dimensions. 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], broadcasting 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 => '$SIZE(m) = $SIZE(n)-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, broadcasting will work correctly. That is, the first dimension of the output ndarray with have its dimension adjusted, but other broadcasting 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. =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(broadcastids[0]); if ($COMP(n2) <0) $COMP(n2) += $PARENT(broadcastids[0]); if (PDLMIN($COMP(n1),$COMP(n2)) <0 || PDLMAX($COMP(n1),$COMP(n2)) >= $PARENT(broadcastids[0])) $CROAK("One of dims %d, %d out of range: should be 0<=dim<%d", $COMP(n1),$COMP(n2),$PARENT(broadcastids[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. You can also have C entries that are "incomplete arrays" of C, both for input and output: OtherPars => 'pdl *ins[]', # $COMP(ins_count) will be available # OR OtherPars => '[o] pdl *outs[]', # update $COMP(outs_count) in your code Note that the output F entry does a C on the array of C pointers, so ensure that you C it in your code, without leaking. =head3 OtherPars as outputs As of 2.081, you can specify an C as an output. This looks like: pp_def('output_op', Pars => 'in(n=2)', OtherPars => '[o] PDL_Anyval v0; [o] PDL_Anyval v1', Code => ' pdl_datatypes dt = $PDL(in)->datatype; ANYVAL_FROM_CTYPE($COMP(v0), dt, $in(n=>0)); ANYVAL_FROM_CTYPE($COMP(v1), dt, $in(n=>1)); ', ); The passed-in stack SV will be mutated in place, so this code will then work: output_op([5,7], my $v0, my $v1); is_deeply [$v0,$v1], [5,7], 'output OtherPars work'; ($v0, $v1) = output_op([5,7]); # you can omit them, then they get returned is_deeply [$v0,$v1], [5,7], 'output OtherPars work 1a'; An operation with output C cannot broadcast, since that would cause undefined results. A runtime check is generated that throws an exception if any C would cause broadcasting. Note the syntax for C has C<[o]> go I the type, while it goes I the type in C. It was felt this was the best way to avoid ambiguity given C types can have C<[]> in them. This relies on the relevant C having an C entry in an XS typemap. As of 2.083, it is also possible to specify C as C<[io]>, which means they I be supplied (rather than being optional, like an C<[o]> one), but will still be updated after the operation has finished. =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('setbadtoval',HandleBad => 1, Pars => 'a(); [o]b();', OtherPars => 'double newval', Inplace => 1, CopyBadStatusCode => 'PDL->propagate_badflag( b, 0 );', ... Since this routine removes all bad values, the output ndarray had its bad flag cleared. This is then propagated to both parents and children. 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. =head3 ArgOrder Pars => 'x(); y(); [o]z()' OtherPars => 'int a; int b', ArgOrder => [qw(x y a b z)], # or, a non-reference true value to enable flexible arg-handling and # move defaultable to the end, followed by output ndarrays then OtherPars Pars => 'x(); y(); [o]z()' OtherPars => 'int a; int b', ArgOrder => 1, Allows specifying a different order for providing the operation's arguments. This affects only the generated XS (not C C) parameter list; the internal ordering of C in various C arrays is unaffected. Providing a non-reference true value enables flexible argument-handling and moves defaultable to the end, followed by output ndarrays then output C. Also, all outputs (ndarray and C) will be returned on the stack, even if supplied as arguments. It is an error to specify arguments that are not provided, or to give a false value, or to have "optional" arguments after mandatory ones. =head4 XS argument-handling change This also changes PP's XS argument handling; normally you can specify: =over =item * just the input/io arguments =item * (if the operation has default values provided) those plus values for all arguments with defaults =item * all of those plus output arguments, in other words all non-C<[t]> arguments =back With C given, "optional" arguments (outputs and ones with defaults) will be filled in from the leftmost missing one. =head3 HdrCode This is C code that is inserted in the XS function before the call to the generated C. It will have access to all the Pars and OtherPars as C values. =head3 FtrCode As of 2.083. This is C code that is inserted in the XS function after the call to the generated C. It will have access to all the Pars and OtherPars as C values. =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 broadcasting 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. The value given here (or the default, C), anywhere in the F<.pd> file, will be the package into which all PP operations get added, even for operations whose C was called I the C. This is because that package is inserted at the start of the generated XS code by C. The only way this changes is if C is called, which will add the given code (or none if an empty string is given) to the C<$::PDLPACK> package, I. For historical reasons, this cannot be changed. So, to have several different packages in one F<.pd> file, do something like this: # any pp_def up till now will get put in PDL::Pack2 pp_bless('PDL::Pack1'); pp_addxs(''); pp_def('func1', ...); pp_bless('PDL::Pack2'); pp_addxs(''); pp_def('otherfunc', ...); =head3 pp_addxs Sometimes you want to add extra XS code of your own (that is generally not involved with any broadcasting/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 broadcasting 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 their way to use it, so they shoulder 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, and are recommended to, use C. =head3 CopyBadStatusCode As of 2.079, this is deprecated due to being largely unnecessary; instead, just use C<$PDLSTATESETBAD(pdlname)> in your C section and the badflag setting will be propagated to all its parents and children. The default code here sets the bad flag of the output ndarrays 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). =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 I, sets in the C (see L) the C such that the trans will start with dataflow both forwards and backwards. Note that setting this to any value (including 0) will trigger the behaviour. =head3 HaveBroadcasting Default true. If so, generate code implementing broadcasting (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 $SETDELTABROADCASTIDS() 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 broadcast loop As of 2.075, C is a deprecated alias for this. =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 broadcasting engine around your own C code, but you can do some other things, too. =head3 pp_def Used to wrap the broadcasting 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 broadcasting 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. =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 broadcasting 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.085/Basic/Pod/QuickStart.pod0000644000175000017500000004764514215315737016466 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. All rights reserved. There is no warranty. You are allowed to copy this on the same terms as Perl itself. =cut PDL-2.085/Basic/Pod/Modules.pod0000644000175000017500000001457414233537110015766 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-dimensional image processing. =item L N-dimensional 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.085/Basic/Pod/FAQ.pod0000644000175000017500000015307314411217661014767 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 themselves 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 their 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 broadcasting (is PDL a newsreader)? Until 2.075, "threading" was used to refer to two ideas, but that ambiguity has now been resolved by using the now (as of 2022) industry-standard term "broadcasting" for the vectorisation / array-programming concept. =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), currently (as of 2.074) POSIX threads (see L). =item * PDL broadcasting 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 The connection is that broadcasting divides up independent operations that can be done in parallel. =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 broadcasting, 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 broadcasting. 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 F 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.085/Basic/Pod/Tutorials.pod0000644000175000017500000000663714202424257016350 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 broadcasting 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.085/Basic/Pod/Objects.pod0000644000175000017500000000736114416133244015746 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. All rights reserved. There is no warranty. You are allowed to copy this on the same terms as Perl itself. =cut PDL-2.085/Basic/Pod/Index.pod0000644000175000017500000002604414411646751015432 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 - Write PDL Subroutines inline with PDL::PP =item * L - making ndarrays from Perl and C/XS code =item * L - Discussion of bad value support in PDL =item * L - Tutorial for PDL's Broadcasting feature =item * L - How to diagnose and report PDL problems =item * L - A journey through PDL's documentation, from beginner to advanced. =item * L - description of the dataflow implementation and philosophy =item * L - Frequently asked questions about PDL =item * L - Introduction to the PDL::Graphics modules =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 multi-threading support in PDL =item * L - Why did we write PDL? =item * L - Quick introduction to PDL features. =item * L - A guide for Scilab users. =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 - 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 always processes 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 - handle complex numbers (DEPRECATED - use native complex) =item * L - subclass of Math::Complex with overload fallbacks =item * L - compression utilities =item * L - basic compile time constants for PDL =item * L - fundamental PDL functionality and vectorization/broadcasting =item * L - PDL development module =item * L - functions to support debugging of PDL scripts =item * L - PDL demo infrastructure =item * L - demonstrate PDL::Graphics::PGPLOT capabilities =item * L - demonstrate PDL::Graphics::PGPLOT OO capabilities =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 - 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 PROJ projection library. =item * L - PDL interface to GSL Cumulative Distribution Functions =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 linear algebra 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 - PDL 3D interface =item * L - default event handler subroutines =item * L - 3D Surface contours for TriD =item * L - PDL 3D graph object with axes =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 - 2D data browser for PDL =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 - A PDL interface to the HDF4 library. =item * L - PDL interface to the HDF4 SD library. =item * L - An interface library for HDF4 files. =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 - read/write 3D stereolithography files =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 - Module for use by L and L =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 - 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.082. PDL-2.085/Basic/Pod/MATLAB.pod0000644000175000017500000007032114202424257015311 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 broadcasting, and B. Broadcasting 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 "broadcast" 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.085/Basic/Pod/Tips.pod0000644000175000017500000000667014146003631015272 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.085/Basic/Pod/Course.pod0000644000175000017500000003555114202424257015617 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 broadcasting over implicit broadcast 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.085/Basic/Pod/Dataflow.pod0000644000175000017500000001565014226662101016114 0ustar osboxesosboxes=head1 NAME PDL::Dataflow -- description of the dataflow implementation and 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 DESCRIPTION As of 2.079, this is now a description of the current implementation, together with some design thoughts from its original author, Tuomas Lukka. Two-directional dataflow (which implements C<< ->slice() >> etc.) is fully functional, as shown in the SYNOPSIS. One-way is implemented, but with restrictions. =head1 TWO-WAY Just about any function which returns some subset of the values in some ndarray will make a binding. C<$y> has become effectively a window to some sub-elements of C<$x>. You can also define your own routines that do different types of subsets. If you don't want C<$y> to be a window to C<$x>, you must do $y = $x->slice("some parts")->sever; The C destroys the C transform, thereby turning off all dataflow between the two ndarrays. =head2 Type conversions This works, thanks to a two-way flowing transform that implements type-conversions, particularly for supplied outputs of the "wrong" type for the given transform: pdl> $a_bad = pdl double, '[1 BAD 3]'; pdl> $b_float = zeroes float, 3; pdl> $a_bad->assgn($b_float); # could be written as $b_float .= $a_bad pdl> p $b_float->badflag; 1 pdl> p $b_float; [1 BAD 3] =head1 ONE-WAY You need to explicitly turn on one-way dataflow on an ndarray to activate it for non-flowing operations, so pdl> $x = pdl 2,3,4; pdl> $x->doflow; pdl> $y = $x * 2; pdl> print $y; [4 6 8] pdl> $x->set(0,5); pdl> print $y; [10 6 8] It is not possible to turn on backwards dataflow (such as is used by C-type operations), because there is no general way for PDL (or maths, in fact) to know how to reverse most operations - consider C<$z = $x * $y>, then adding one to C<$z>. Consider the following code: $u = sequence(3,3); $u->doflow; $v = ones(3,3); $v->doflow; $w = $u + $v; $w->doflow; # must turn on for each $y = $w + 1; $y->doflow; $x = $w->diagonal(0,1); $x += 50; $z = $w + 2; What do $y and $z contain now? pdl> p $y [ [52 3 4] [ 5 56 7] [ 8 9 60] ] pdl> p $z [ [53 4 5] [ 6 57 8] [ 9 10 61] ] What about when $u is changed and a recalculation is triggered? A problem arises, in that PDL currently (as of 2.079) disallows (see F), for normal transforms, output ndarrays with flow, or output ndarrays with any parent with dataflow. So C<$u++> throws an exception. But it is currently possible to use C, which is a sort of micro-transform that calls (in the C API) C to mutate the data, then C to trigger flow updates: pdl> $u->set(1,1,90) pdl> p $y [ [ 2 3 4] [ 5 92 7] [ 8 9 10] ] You'll notice that while the setting of C<1,1> (the middle) of $u updated $y, the changes to $y that resulted from adding 50 to the diagonal (via $x, and two-way flow) got lost. This is one-way flow. =head1 LAZY EVALUATION In one-way flow context like the above, with: pdl> $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 pdl> 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: pdl> $x = pdl 2,3,4; $x->doflow; pdl> $y = pdl 5,6,7; $y->doflow; pdl> $c = $x + $y; pdl> $x->setdims([4]); pdl> $y->setdims([4]); pdl> 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. =head1 FAMILIES This is one of the more intricate concepts of dataflow. In order to make dataflow work like you'd expect, a rather strange concept must be introduced: families. Let us make a diagram of the one-way flow example - it uses a hypergraph because the transforms (with C<+>) are connectors between ndarrays (with C<*>): u* *v \ / +(plus) | 1* *w \ /|\ \ / | \ (plus)+ | +(diagonal) | | | y* | *x | | *1 |/ +(plus) | z* This is what PDL actually has in memory after the first three lines. When $x is changed, $w changes due to C being a two-way operation. If you want flow from $w, you opt in using C<< $w->doflow >> (as shown in this scenario). If you didn't, then don't enable it. If you have it but want to stop it, call C<< $ndarray->sever >>. That will destroy the ndarray's C (here, a node marked with C<+>), and as you can visually tell, will stop changes flowing thereafter. If you want to leave the flow operating, but get a copy of the ndarray at that point, use C<< $ndarray->copy >> - it will have the same data at that moment, but have no flow relationships. =head1 EVENTS There is the start of a mechanism to bind events onto changed data, intended to allow this to work: pdl> $x = pdl 2,3,4 pdl> $y = $x + 1; pdl> $c = $y * 2; pdl> $c->bind( sub { print "A now: $x, C now: $c\n" } ) pdl> PDL::dowhenidle(); A now: [2,3,4], C now: [6 8 10] pdl> $x->set(0,1); pdl> $x->set(1,1); pdl> PDL::dowhenidle(); A now: [1,1,4], C now: [4 4 10] This hooks into PDL's C which resembles Perl's, but does not currently operate. There would be many kinds of uses for this feature: self-updating charts, for instance. It is not yet fully clear whether it would be most useful to queue up changes (useful for doing asynchronously, e.g. when idle), or to activate things immediately. In the 2022 era of both GPUs and multiple cores, it is a pity that Perl's dominant model remains single-threaded on CPU, but PDL can use multi-cores for CPU processing (albeit controlled in a single-threaded style) - see L. It is planned that PDL will gain the ability to use GPUs, and there might be a way to hook that up albeit probably with an event loop to "subscribe" to GPU events. =head1 TRANSFORMATIONS PDL implements nearly everything (except for XS oddities like C) using transforms which connect ndarrays. This includes data transformations like addition, "slicing" to access/operate on subsets, and data-type conversions (which have two-way dataflow, see L). This does not currently include a resizing transformation, and C mutates its input. This is intended to change. =head1 AUTHOR Copyright(C) 1997 Tuomas J. Lukka (lukka@fas.harvard.edu). Same terms as the rest of PDL. PDL-2.085/Basic/Pod/Makefile.PL0000644000175000017500000000157314164221257015624 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.085/Basic/Lvalue.pm0000644000175000017500000000414214202424257014707 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.085/Basic/Makefile.PL0000644000175000017500000000233614146003631015072 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.085/Basic/MatrixOps/0000755000175000017500000000000014556074541015057 5ustar osboxesosboxesPDL-2.085/Basic/MatrixOps/sslib.h0000644000175000017500000000167714160714722016350 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.085/Basic/MatrixOps/matrix.c0000644000175000017500000003155614202424257016530 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.085/Basic/MatrixOps/NOTES0000644000175000017500000000147713265417442015700 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.085/Basic/MatrixOps/eigen.c0000644000175000017500000004552114202424257016310 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.085/Basic/MatrixOps/matrixops.pd0000644000175000017500000012521014417053651017426 0ustar osboxesosboxespp_addhdr(' #include '); use strict; use warnings; use PDL::Types qw(ppdefs_all); 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, broadcastable): $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 broadcasting 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 broadcast over multiple row vectors. When broadcasting 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 = !(my $was_pdl = UNIVERSAL::isa($n,'PDL')) ? zeroes($n,$n) : $n->getndims == 0 ? zeroes($n->type, $n->at(0),$n->at(0)) : undef; if (!defined $out) { my @dims = $n->dims; $out = zeroes($n->type, @dims[0, 0, 2..$#dims]); } (my $tmp = $out->diagonal(0,1))++; # work around perl -d "feature" $was_pdl ? bless $out, ref($n) : $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, $opt) = @_; $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 : PDL->zeroes(sbyte,1); } 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 (broadcastable). 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 broadcastable, 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 broadcasting 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 broadcastable (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 broadcastable, 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 broadcastable, 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 ',); ###################################################################### ### svd pp_def( "svd", HandleBad => 0, Pars => 'a(n,m); [t]w(wsize); [o]u(n,m); [o,phys]z(n); [o]v(n,n);', GenericTypes => ['D'], RedoDimsCode => ' if ($SIZE(m)<$SIZE(n)) $CROAK("svd requires input ndarrays to have m >= n; you have m=%td and n=%td. Try inputting the transpose. See the docs for svd.",$SIZE(m),$SIZE(n)); $SIZE(wsize) = $SIZE(n) * ($SIZE(m) + $SIZE(n)); ', Code => ' extern void SVD( double *W, double *Z, int nRow, int nCol ); double *t = $P(w); loop (m) %{ loop(n) %{ *t++ = $a(); %} %} SVD($P(w), $P(z), $SIZE(m), $SIZE(n)); loop (n) %{ $z() = sqrt($z()); %} t = $P(w); loop (m) %{ loop (n) %{ $u() = *t++/$z(); %} %} loop (n1) %{ loop (n0) %{ $v() = *t++; %} %} ', , Doc => q{ =for usage ($u, $s, $v) = svd($x); =for ref Singular value decomposition of a matrix. C is broadcastable. 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 broadcasting for cheap mult. $x .= $r2 x $r1; # a gets r2 x ess x r1 } },); ###################################################################### 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 broadcasting. 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 broadcasted, 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)')->zeroes; $tmprow = $tmprow->double if $tmprow->type < double; 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; } } # LAPACK cgetrf does not try fix singularity so nor do we, even though NR does my $notbig = $big->where(abs($big) < $TINY); return if !$notbig->isempty; # 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 wantarray ? ($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 wantarray ? ($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 broadcast # 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 broadcasts 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 broadcasting dimensions are compatible. # There are two possible sources of broadcast 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 broadcast dims not equal! \n"; } # (2) If X == Y then default broadcasting is ok if ( ($bnumthr==$permnumthr) and ($bdims==$permdims)->all) { print STDERR "lu_backsub: have explicit broadcast dims, goto BROADCAST_OK\n" if $PDL::debug; goto BROADCAST_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 broadcasting occurs over all # leading non-trivial (not length 1) dims of # B unless all the broadcast dims are explicitly # matched to the LU dims. BROADCAST_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 broadcasting 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 broadcasting } 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 broadcast dims $out->slice("$row:$n1") )->sumover; ($tmp = $out->index($r1)) /= $ludiag->index($r1)->dummy(0); # TODO: check broadcast 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); [o]b(m)', GenericTypes => [ppdefs_all], RedoDimsCode => '$SIZE(m) = ($SIZE(n) * ($SIZE(n)+1))/2;', Code => ' register PDL_Indx mna=0, nb=0; loop(m) %{ $b() = $a(n0 => mna, n1 => nb); mna++; if(mna > nb) {mna = 0; nb ++;} %} ', Doc => '=for ref Convert a lower-triangular square matrix to triangular vector storage. Ignores upper half of input. ', ); 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.085/Basic/MatrixOps/eigens.c0000644000175000017500000000622114202424257016465 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.085/Basic/MatrixOps/eigen.h0000644000175000017500000000120314202424257016302 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.085/Basic/MatrixOps/Makefile.PL0000644000175000017500000000071214202424257017020 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.085/Basic/MatrixOps/svd.c0000644000175000017500000001747614202424257016025 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.085/Basic/MatrixOps/matrix.h0000644000175000017500000000400014202424257016515 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.085/Basic/PDL.pm0000644000175000017500000001405314556074403014106 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 "broadcasting"), 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.085'; # 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::ParallelCPU, 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.085/Basic/Bad/0000755000175000017500000000000014556074541013617 5ustar osboxesosboxesPDL-2.085/Basic/Bad/bad.pd0000644000175000017500000005671414434766216014711 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 '); 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! 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 an ndarray 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 an ndarray with the original bad value for the associated type. =head2 check_badflag =for ref Clear the badflag 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 badflag. =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 badflag. =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! pp_addxs(<<'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_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::Bad::_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::Bad::_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::Bad::_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() = PDL_IF_BAD($ISBAD(a()),0);', 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() = PDL_IF_BAD($ISGOOD(a()),1);', 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 => q{ PDL_Indx cnt = 0; PDL_IF_BAD(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 => 'PDL_Indx cnt = PDL_IF_BAD(0,$SIZE(n)); PDL_IF_BAD(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 an ndarray and 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 an ndarray and 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' ]; } else { } # always make sure the output is "bad" # 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 => ' broadcastloop %{ /* if the bad value == 0 then all points are going to be selected ... */ if ( PDL_IF_BAD($ISBAD(mask()) ||,) $mask() ) { $SETBAD(b()); } else { $b() = $a(); } %} $PDLSTATESETBAD(b); ', GenericTypes => $A, ); # pp_def: setbadif # this is useful because $x->setbadif( $x == 23 ) # is common and that can't be done inplace 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, Code => q[ broadcastloop %{ if ( $a() == ($GENERIC(a)) $COMP(value) ) { $SETBAD(b()); } else { $b() = $a(); } %} $PDLSTATESETBAD(b); ], 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, Code => q[ int flag = 0; broadcastloop %{ 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, Code => q[ int flag = 0; broadcastloop %{ 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, Code => q[ int flag = 0; broadcastloop %{ 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, Code => q{ broadcastloop %{ if ( $ISBAD(a()) ) { $b() = $TFDEGCH(NAN,NAN,NAN,NAN+I*NAN,NAN+I*NAN,NAN+I*NAN); } else { $b() = $a(); } %} $PDLSTATESETGOOD(b); }, ); # pp_def: setbadtonan 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 => q{ PDL_IF_BAD($GENERIC(b) replace = ($GENERIC(b)) $COMP(newval);,) broadcastloop %{ $GENERIC(b) a_val = $a(); $b() = PDL_IF_BAD($ISBADVAR(a_val,a) ? replace : ,) a_val; %} }, CopyBadStatusCode => q{ PDL->propagate_badflag( b, 0 ); /* always make sure the output is "good" */ }, GenericTypes => $A, ); # pp_def: setbadtoval pp_def( 'badmask', Pars => 'a(); b(); [o]c();', Inplace => [ 'a' ], HandleBad => 1, Code => ' broadcastloop %{ $c() = ( isfinite((double) $a()) PDL_IF_BAD(&& $ISGOOD(a()),) ) ? $a() : $b(); %} $PDLSTATESETGOOD(c); ', 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('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 => q{ char anybad = 0; broadcastloop %{ PDL_IF_BAD(if ( $ISBAD(mask()) ) { $SETBAD(b()); anybad = 1; } else,) { $b() = $a(); } %} if (anybad) $PDLSTATESETBAD(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.085/Basic/Bad/Makefile.PL0000644000175000017500000000054214202424257015561 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.085/INTERNATIONALIZATION0000644000175000017500000000067113460433355015077 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.085/META.json0000644000175000017500000000520514556074541013533 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", "ExtUtils::ParseXS" : "3.21", "File::Path" : "0", "Pod::Select" : "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", "File::Path" : "0", "File::Which" : "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::Select" : "0", "Scalar::Util" : "0", "Storable" : "1.03", "Text::Balanced" : "2.05", "perl" : "5.010" }, "suggests" : { "Astro::FITS::Header" : "0", "Sys::SigAction" : "0" } }, "test" : { "requires" : { "CPAN::Meta" : "2.120900", "IPC::Cmd" : "0.72", "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.085", "x_serialization_backend" : "JSON::PP version 4.04" } PDL-2.085/DEVELOPMENT0000644000175000017500000001451214146003631013603 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.085/Example/0000755000175000017500000000000014556074541013503 5ustar osboxesosboxesPDL-2.085/Example/Fit/0000755000175000017500000000000014556074541014225 5ustar osboxesosboxesPDL-2.085/Example/Fit/lmfit_example.pl0000644000175000017500000000534214146003631017377 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.085/Example/TriD/0000755000175000017500000000000014556074541014345 5ustar osboxesosboxesPDL-2.085/Example/TriD/3dtest.pl0000644000175000017500000000050314212252616016074 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::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.085/Example/TriD/line3d.pl0000644000175000017500000000055014212252616016046 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::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.085/Example/TriD/old_trid_clip.pl0000644000175000017500000000561614014062163017503 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.085/Example/doc-pp0000755000175000017500000000137314202424244014602 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.085/Example/InlinePdlpp/0000755000175000017500000000000014556074541015721 5ustar osboxesosboxesPDL-2.085/Example/InlinePdlpp/inlppminimal.pl0000644000175000017500000000102414014062163020726 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.085/Example/InlinePdlpp/Module/0000755000175000017500000000000014556074541017146 5ustar osboxesosboxesPDL-2.085/Example/InlinePdlpp/Module/MyInlineMod.pm0000644000175000017500000000475314202424257021670 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.085/Example/InlinePdlpp/Module/t/0000755000175000017500000000000014556074541017411 5ustar osboxesosboxesPDL-2.085/Example/InlinePdlpp/Module/t/myinlinemod.t0000644000175000017500000000027214202424257022112 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.085/Example/InlinePdlpp/Module/Makefile.PL0000644000175000017500000000051714014062163021105 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.085/Example/InlinePdlpp/inlpp_link.pl0000644000175000017500000000200314014062163020372 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.085/Example/InlinePdlpp/inlpp.pl0000644000175000017500000000124214014062163017361 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.085/Example/PGPLOT/0000755000175000017500000000000014556074541014510 5ustar osboxesosboxesPDL-2.085/Example/PGPLOT/pgplot.pl0000644000175000017500000002057413457205473016361 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.085/Example/PGPLOT/std_pgplot.pl0000644000175000017500000001000713457205473017221 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.085/Example/Simplex/0000755000175000017500000000000014556074541015124 5ustar osboxesosboxesPDL-2.085/Example/Simplex/tsimp_needs_pgplot.pl0000644000175000017500000000134514014062163021345 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.085/Example/Simplex/tsimp2.pl0000644000175000017500000000372114014062163016664 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.085/Example/address-pseudonymise0000755000175000017500000000027714203677412017601 0ustar osboxesosboxes#!/usr/bin/env perl use strict; use warnings; my (%addr2number, $i); while (<>) { s:^==\d+==:==[PID]==:; s:0x([0-9a-f]+): '[ADDR'.($addr2number{$1} //= ++$i).']' :gie; print; } PDL-2.085/Example/Benchmark/0000755000175000017500000000000014556074541015375 5ustar osboxesosboxesPDL-2.085/Example/Benchmark/Bench.xs0000644000175000017500000000200114160714722016752 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.085/Example/Benchmark/time.pl0000644000175000017500000000005214146002234016646 0ustar osboxesosboxesuse PDL; use PDL::Bench; do_benchmark(); PDL-2.085/Example/Benchmark/Bench.pm0000644000175000017500000000141614202424257016743 0ustar osboxesosboxes# Old results: approx. 1.91_03: 34 secs (512, 10 iter) # With simply folded-out broadcasting: 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.085/Example/Benchmark/README.md0000644000175000017500000000033314146002234016634 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.085/Example/Benchmark/Makefile.PL0000644000175000017500000000045214146003631017333 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.085/macosx/0000755000175000017500000000000014556074541013402 5ustar osboxesosboxesPDL-2.085/macosx/README0000644000175000017500000000044213265417442014257 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.085/pdl.c0000644000175000017500000000353314202424257013026 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.085/MANIFEST.SKIP0000644000175000017500000001042714547543564014020 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$ \.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 ^Demos/TkTriD_demo.pm$ ^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/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/ ^\.cirrus\.yml ^Example/Benchmark/\.git ^cover_db/ ^nytprof(/|\.out) \.gc(ov|no|da)$ pp-\w*\.c$ ^debian/ PDL-2.085/Perldl2/0000755000175000017500000000000014556074541013414 5ustar osboxesosboxesPDL-2.085/Perldl2/Plugin/0000755000175000017500000000000014556074541014652 5ustar osboxesosboxesPDL-2.085/Perldl2/Plugin/CleanErrors.pm0000644000175000017500000000260214202424257017416 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.085/Perldl2/Plugin/PrintControl.pm0000644000175000017500000000430214202424257017633 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.085/Perldl2/Plugin/PDLCommands.pm0000644000175000017500000000561614202424257017310 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.085/Perldl2/Plugin/NiceSlice.pm0000644000175000017500000000265314202424257017043 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.085/Perldl2/Plugin/Makefile.PL0000644000175000017500000000066114146003631016612 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.085/Perldl2/pdl20000755000175000017500000000607514212512144014174 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] pdl> with_time { print +($A->matmult($B))->info, "\n" } for 1..5; =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. For shell-like C handling, you need L installed. =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.085/Perldl2/Profile/0000755000175000017500000000000014556074541015014 5ustar osboxesosboxesPDL-2.085/Perldl2/Profile/Perldl2.pm0000644000175000017500000001732214416154456016662 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'; my %plugin2deps = ( 'Completion' => [qw(PPI)], 'CompletionDriver::INC' => [qw(File::Next)], 'CompletionDriver::Keywords' => [qw(B::Keywords)], 'CompletionDriver::LexEnv' => [qw(Lexical::Persistence)], 'DDS' => [qw(Data::Dump::Streamer)], 'Interrupt' => [qw(Sys::SigAction)], 'LexEnv' => [qw(Lexical::Persistence)], 'MultiLine::PPI' => [qw(PPI)], ); sub plugins { qw( CleanErrors Commands Completion CompletionDriver::INC CompletionDriver::Keywords CompletionDriver::LexEnv CompletionDriver::Methods DDS History Interrupt 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 (my $deps = $plugin2deps{$plug}) { next if grep !eval "require $_; 1", @$deps; } $repl->load_plugin($plug); } # 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); };'); $repl->eval( q{ sub with_time (&) { require Time::HiRes; my @t = Time::HiRes::gettimeofday(); &{$_[0]}(); printf "%g ms\n", Time::HiRes::tv_interval(\@t) * 1000; } } ); $repl->eval( q{ use PDL::Demos; sub demo { if (!$_[0]) { require List::Util; my @kw = sort grep $_ ne 'pdl', PDL::Demos->keywords; my $maxlen = List::Util::max(map length, @kw); print "Use:\n"; printf " demo %-${maxlen}s # %s\n", @$_[0,1] for map [PDL::Demos->info($_)], 'pdl', @kw; return; } no strict; PDL::Demos->init($_[0]); &{$_->[0]}($_->[1]) for PDL::Demos->demo($_[0]); PDL::Demos->done($_[0]); } } ); 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.085/Perldl2/Profile/Makefile.PL0000644000175000017500000000033414146003631016751 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.085/Perldl2/TODO0000644000175000017500000003103014146003631014064 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.085/Perldl2/Script.pm0000644000175000017500000000225714202424257015213 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.085/Perldl2/README0000644000175000017500000001103614014062163014257 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.085/Perldl2/Makefile.PL0000644000175000017500000000327414146003631015357 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.085/t/0000755000175000017500000000000014556074541012353 5ustar osboxesosboxesPDL-2.085/t/clump.t0000644000175000017500000000370214146003631013645 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.085/t/thread.t0000644000175000017500000001245714226634630014013 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", <broadcast(0,1); $pb->make_physical(); $pc->make_physical(); maximum($pa->broadcast(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->broadcast(0,1),$pb->broadcast(0,1)); cmp_ok($pb->at(0,0), '==', 0, 'at(0,0)'); cmp_ok($pb->at(1,1), '==', 4, 'at(1,1)'); } { # Now, test 'unbroadcast'. my $pa = zeroes(4,5,6); my $pb = $pa->broadcast(1); my $pc = $pb->unbroadcast(2); is(join(',',$pc->dims), "4,6,5", 'unbroadcast dims'); # $pb->jdump; $pc->jdump; } { #### Now, test whether the Perl-accessible broadcast 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::broadcastover_n($pa,$pb,sub {print "ROUND: @_\n"}); # As well as with virtuals... PDL::broadcastover_n($pa->slice("-1:0,-1:0"),$pb,sub {print "ROUND: @_\n"}); } { # test compat alias still 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"}); } done_testing; PDL-2.085/t/primitive-interpolate.t0000644000175000017500000000213514547612401017066 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use Test::Exception; use PDL::LiteF; subtest interpol => sub { subtest real => sub { my $yvalues = PDL->new( 0 .. 5 ) - 20; my $xvalues = -PDL->new( 0 .. 5 ) * .5; my $x = PDL->new(-2); is( $x->interpol( $xvalues, $yvalues ), -16, "result" ); }; subtest complex => sub { my $yvalues = ( PDL->new( 0 .. 5 ) - 20 ) * ( 1 + i() ); my $xvalues = -PDL->new( 0 .. 5 ) * .5; my $x = PDL->new(-2); ok( all( $x->interpol( $xvalues, $yvalues ) == ( -16 - 16 * i ) ), "result" ); throws_ok { $x->interpol( $xvalues * i(), $yvalues ) } qr/must be real/, "x must be real"; }; }; subtest interpND => sub { my $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 ); my $y; lives_ok { $y = $x->interpND($index) } 'interpND'; ok !any( $y != $z ), "result"; }; done_testing; PDL-2.085/t/lvalue.t0000644000175000017500000000065414146003631014020 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.085/t/primitive-vector.t0000644000175000017500000004365314547612401016054 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::LiteF; use lib 't/lib'; use My::Test::Primitive; subtest 'cmpvec' => sub { ok tapprox( pdl( 1, 2, 3 )->cmpvec( pdl( 3, 2, 1 ) ), -1 ), 'less'; ok tapprox( pdl( 3, 2, 1 )->cmpvec( pdl( 1, 2, 3 ) ), 1 ), 'more'; ok tapprox( pdl( 3, 2, 1 )->cmpvec( pdl( 3, 2, 1 ) ), 0 ), 'same'; is_deeply pdl('[1 BAD]')->cmpvec( pdl( 3, 2 ) )->unpdl, [-1], 'bad before'; is_deeply pdl('[BAD 1]')->cmpvec( pdl( 3, 2 ) )->unpdl, ['BAD'], 'bad'; my $vdim = 4; my $v1 = zeroes($vdim); my $v2 = pdl($v1); $v2->set( -1, 1 ); ok $v1->cmpvec($v2) < 0, "1d:<"; ok $v2->cmpvec($v1) > 0, "1d:>"; is $v1->cmpvec($v1)->sclr, 0, "1d:=="; }; subtest 'eqvec' => sub { ok tapprox( pdl( 3, 2, 1 )->eqvec( pdl( 1, 2, 3 ) ), 0 ), 'diff'; ok tapprox( pdl( 3, 2, 1 )->eqvec( pdl( 3, 2, 1 ) ), 1 ), 'same'; is_deeply pdl('[2 1 BAD]')->eqvec( pdl( 1, 3, 2 ) )->unpdl, ['BAD'], 'bad before'; is_deeply pdl('[2 BAD 1]')->eqvec( pdl( 2, 3, 2 ) )->unpdl, ['BAD'], 'bad'; }; subtest 'uniqvec' => sub { is_deeply pdl( [ [ 0, 1 ], [ 2, 2 ], [ 0, 1 ] ] )->uniqvec->unpdl, [ [ 0, 1 ], [ 2, 2 ] ], '2x3'; is_deeply pdl( [ [ 0, 1 ] ] )->uniqvec->unpdl, [ [ 0, 1 ] ], '1x2'; is_deeply pdl( [ [ 0, 1, 2 ], [ 0, 1, 2 ], [ 0, 1, 2 ], ] )->uniqvec->unpdl, [ [ 0, 1, 2 ] ], '3x3'; }; subtest 'qsortvec' => sub { my $p2d = pdl( [ [ 1, 2 ], [ 3, 4 ], [ 1, 3 ], [ 1, 2 ], [ 3, 3 ] ] ); ok tapprox( $p2d->qsortvec, pdl( long, [ [ 1, 2 ], [ 1, 2 ], [ 1, 3 ], [ 3, 3 ], [ 3, 4 ] ] ) ), "qsortvec"; ok tapprox( $p2d->dice_axis( 1, $p2d->qsortveci ), $p2d->qsortvec ), "qsortveci"; }; subtest 'vsearchvec' => sub { my $which = pdl( long, [ [ 0, 0 ], [ 0, 0 ], [ 0, 1 ], [ 0, 1 ], [ 1, 0 ], [ 1, 0 ], [ 1, 1 ], [ 1, 1 ] ] ); my $find = $which->slice(",0:-1:2"); ok tapprox( $find->vsearchvec($which), pdl( long, [ 0, 2, 4, 6 ] ) ), "match"; ok tapprox( pdl( [ -1, -1 ] )->vsearchvec($which), 0 ), "<<"; ok tapprox( pdl( [ 2, 2 ] )->vsearchvec($which), $which->dim(1) - 1 ), ">>"; }; subtest 'unionvec' => sub { my $vtype = long; my $universe = pdl( $vtype, [ [ 0, 0 ], [ 0, 1 ], [ 1, 0 ], [ 1, 1 ] ] ); my $v1 = $universe->dice_axis( 1, pdl( [ 0, 1, 2 ] ) ); my $v2 = $universe->dice_axis( 1, pdl( [ 1, 2, 3 ] ) ); my ( $c, $nc ) = $v1->unionvec($v2); ok tapprox( $c, pdl( $vtype, [ [ 0, 0 ], [ 0, 1 ], [ 1, 0 ], [ 1, 1 ], [ 0, 0 ], [ 0, 0 ] ] ) ), "list:c"; is $nc, $universe->dim(1), "list:nc"; my $cc = $v1->unionvec($v2); ok tapprox( $cc, $universe ), "scalar"; }; subtest 'intersectvec' => sub { my $vtype = long; my $universe = pdl( $vtype, [ [ 0, 0 ], [ 0, 1 ], [ 1, 0 ], [ 1, 1 ] ] ); my $v1 = $universe->dice_axis( 1, pdl( [ 0, 1, 2 ] ) ); my $v2 = $universe->dice_axis( 1, pdl( [ 1, 2, 3 ] ) ); my ( $c, $nc ) = $v1->intersectvec($v2); ok tapprox( $c, pdl( $vtype, [ [ 0, 1 ], [ 1, 0 ], [ 0, 0 ] ] ) ), "list:c"; is $nc->sclr, 2, "list:nc"; my $cc = $v1->intersectvec($v2); ok tapprox( $cc, $universe->slice(",1:2") ), "scalar"; }; subtest 'setdiffvec' => sub { my $vtype = long; my $universe = pdl( $vtype, [ [ 0, 0 ], [ 0, 1 ], [ 1, 0 ], [ 1, 1 ] ] ); my $v1 = $universe->dice_axis( 1, pdl( [ 0, 1, 2 ] ) ); my $v2 = $universe->dice_axis( 1, pdl( [ 1, 2, 3 ] ) ); my ( $c, $nc ) = $v1->setdiffvec($v2); ok tapprox( $c, pdl( $vtype, [ [ 0, 0 ], [ 0, 0 ], [ 0, 0 ] ] ) ), "list:c"; is $nc, 1, "list:nc"; my $cc = $v1->setdiffvec($v2); ok tapprox( $cc, pdl( $vtype, [ [ 0, 0 ] ] ) ), "scalar"; }; subtest '*_sorted' => sub { my $all = sequence(20); my $amask = ( $all % 2 ) == 0; my $bmask = ( $all % 3 ) == 0; my $alpha = $all->where($amask); my $beta = $all->where($bmask); ok tapprox( scalar( $alpha->union_sorted($beta) ), $all->where( $amask | $bmask ) ), "union_sorted"; ok tapprox( scalar( $alpha->intersect_sorted($beta) ), $all->where( $amask & $bmask ) ), "intersect_sorted"; ok tapprox( scalar( $alpha->setdiff_sorted($beta) ), $all->where( $amask & $bmask->not ) ), "setdiff_sorted"; }; ##-------------------------------------------------------------- ## dim-checks and implicit broadcast dimensions ## + see https://github.com/moocow-the-bovine/PDL-VectorValued/issues/4 subtest 'broadcast_dimensions' => sub { ##-- unionvec my $empty = zeroes( 3, 0 ); my $uw = pdl( [ [ -3, -2, -1 ], [ 1, 2, 3 ] ] ); my $wx = pdl( [ [ 1, 2, 3 ], [ 4, 5, 6 ] ] ); my $xy = pdl( [ [ 4, 5, 6 ], [ 7, 8, 9 ] ] ); # unionvec: basic ok tapprox( scalar( $uw->unionvec($wx) ), pdl( [ [ -3, -2, -1 ], [ 1, 2, 3 ], [ 4, 5, 6 ] ] ) ), "unionvec - broadcast dims - uw+wx"; ok tapprox( scalar( $uw->unionvec($xy) ), pdl( [ [ -3, -2, -1 ], [ 1, 2, 3 ], [ 4, 5, 6 ], [ 7, 8, 9 ] ] ) ), "unionvec - broadcast dims - uw+xy"; ok tapprox( scalar( $empty->unionvec($wx) ), $wx ), "unionvec - broadcast dims - 0+wx"; ok tapprox( scalar( $wx->unionvec($empty) ), $wx ), "unionvec - broadcast dims - wx+0"; ok tapprox( scalar( $empty->unionvec($empty) ), $empty ), "unionvec - broadcast dims - 0+0"; # unionvec: broadcasting my $k = 2; my $kempty = $empty->slice(",,*$k"); my $kuw = $uw->slice(",,*$k"); my $kwx = $wx->slice(",,*$k"); my $kxy = $xy->slice(",,*$k"); ok tapprox( scalar( $kuw->unionvec($wx) ), pdl( [ [ -3, -2, -1 ], [ 1, 2, 3 ], [ 4, 5, 6 ] ] )->slice(",,*$k") ), "unionvec - broadcast dims - uw(*k)+wx"; ok tapprox( scalar( $kuw->unionvec($xy) ), pdl( [ [ -3, -2, -1 ], [ 1, 2, 3 ], [ 4, 5, 6 ], [ 7, 8, 9 ] ] ) ->slice(",,*$k") ), "unionvec - broadcast dims - uw(*k)+xy"; ok tapprox( scalar( $kempty->unionvec($wx) ), $kwx ), "unionvec - broadcast dims - 0(*k)+wx"; ok tapprox( scalar( $kwx->unionvec($empty) ), $kwx ), "unionvec - broadcast dims - wx(*k)+0"; ok tapprox( scalar( $kempty->unionvec($empty) ), $kempty ), "unionvec - broadcast dims - 0(*k)+0"; ##-- intersectvec my $needle0 = pdl( [ [ -3, -2, -1 ] ] ); my $needle1 = pdl( [ [ 1, 2, 3 ] ] ); my $needles = pdl( [ [ -3, -2, -1 ], [ 1, 2, 3 ] ] ); my $haystack = pdl( [ [ 1, 2, 3 ], [ 4, 5, 6 ], [ 7, 8, 9 ], [ 10, 11, 12 ] ] ); # intersectvec: basic ok tapprox( scalar( $needle0->intersectvec($haystack) ), $empty ), "intersectvec - broadcast dims - needle0&haystack"; ok tapprox( scalar( $needle1->intersectvec($haystack) ), $needle1 ), "intersectvec - broadcast dims - needle1&haystack"; ok tapprox( scalar( $needles->intersectvec($haystack) ), $needle1 ), "intersectvec - broadcast dims - needles&haystack"; ok tapprox( scalar( $haystack->intersectvec($haystack) ), $haystack ), "intersectvec - broadcast dims - haystack&haystack"; ok tapprox( scalar( $haystack->intersectvec($empty) ), $empty ), "intersectvec - broadcast dims - haystack&empty"; ok tapprox( scalar( $empty->intersectvec($haystack) ), $empty ), "intersectvec - broadcast dims - empty&haystack"; # intersectvec: broadcasting my $kneedle0 = $needle0->slice(",,*$k"); my $kneedle1 = $needle1->slice(",,*$k"); my $kneedles = pdl( [ [ [ -3, -2, -1 ] ], [ [ 1, 2, 3 ] ] ] ); my $khaystack = $haystack->slice(",,*$k"); ok tapprox( scalar( $kneedle0->intersectvec($haystack) ), $kempty ), "intersectvec - broadcast dims - needle0(*k)&haystack"; ok tapprox( scalar( $kneedle1->intersectvec($haystack) ), $kneedle1 ), "intersectvec - broadcast dims - needle1(*k)&haystack"; ok tapprox( scalar( $kneedles->intersectvec($haystack) ), pdl( [ [ [ 0, 0, 0 ] ], [ [ 1, 2, 3 ] ] ] ) ), "intersectvec - broadcast dims - needles(*k)&haystack"; ok tapprox( scalar( $khaystack->intersectvec($haystack) ), $khaystack ), "intersectvec - broadcast dims - haystack(*k)&haystack"; ok tapprox( scalar( $khaystack->intersectvec($empty) ), $kempty ), "intersectvec - broadcast dims - haystack(*k)&empty"; ok tapprox( scalar( $kempty->intersectvec($haystack) ), $kempty ), "intersectvec - broadcast dims - empty(*k)&haystack"; ##-- setdiffvec # setdiffvec: basic ok tapprox( scalar( $haystack->setdiffvec($needle0) ), $haystack ), "setdiffvec - broadcast dims - haystack-needle0"; ok tapprox( scalar( $haystack->setdiffvec($needle1) ), $haystack->slice(",1:-1") ), "setdiffvec - broadcast dims - haystack-needle1"; ok tapprox( scalar( $haystack->setdiffvec($needles) ), $haystack->slice(",1:-1") ), "setdiffvec - broadcast dims - haystack-needles"; ok tapprox( scalar( $haystack->setdiffvec($haystack) ), $empty ), "setdiffvec - broadcast dims - haystack-haystack"; ok tapprox( scalar( $haystack->setdiffvec($empty) ), $haystack ), "setdiffvec - broadcast dims - haystack-empty"; ok tapprox( scalar( $empty->setdiffvec($haystack) ), $empty ), "setdiffvec - broadcast dims - empty-haystack"; # setdiffvec: broadcasting ok tapprox( scalar( $khaystack->setdiffvec($needle0) ), $khaystack ), "setdiffvec - broadcast dims - haystack(*k)-needle0"; ok tapprox( scalar( $khaystack->setdiffvec($needle1) ), $khaystack->slice(",1:-1,") ), "setdiffvec - broadcast dims - haystack(*k)-needle1"; ok tapprox( scalar( $khaystack->setdiffvec($needles) ), $khaystack->slice(",1:-1,") ), "setdiffvec - broadcast dims - haystack(*k)-needles"; ok tapprox( scalar( $khaystack->setdiffvec($haystack) ), $kempty ), "setdiffvec - broadcast dims - haystack(*k)-haystack"; ok tapprox( scalar( $khaystack->setdiffvec($empty) ), $khaystack ), "setdiffvec - broadcast dims - haystack(*k)-empty"; ok tapprox( scalar( $kempty->setdiffvec($haystack) ), $kempty ), "setdiffvec - broadcast dims - empty(*k)-haystack"; }; ## intersectvec tests as suggested by ETJ/mowhawk2 ## + see https://github.com/moocow-the-bovine/PDL-VectorValued/issues/4 subtest intersect_implicit_dims => sub { # intersectvec: from ETJ/mowhawk2 a la https://stackoverflow.com/a/71446817/3857002 my $toto = pdl( [ 1, 2, 3 ], [ 4, 5, 6 ] ); my $titi = pdl( 1, 2, 3 ); my $notin = pdl( 7, 8, 9 ); my ($c); ok tapprox( $c = intersectvec( $titi, $toto ), [ [ 1, 2, 3 ] ] ), 'intersectvec - implicit dims - titi&toto'; ok tapprox( $c = intersectvec( $notin, $toto ), zeroes( 3, 0 ) ), 'intersectvec - implicit dims - notin&toto'; ok tapprox( $c = intersectvec( $titi->dummy(1), $toto ), [ [ 1, 2, 3 ] ] ), 'intersectvec - implicit dims - titi(*1)&toto'; ok tapprox( $c = intersectvec( $notin->dummy(1), $toto ), zeroes( 3, 0 ) ), 'intersectvec - implicit dims - notin(*1)&toto'; my $needle0_in = pdl( [ 1, 2, 3 ] ); # 3 my $needle0_notin = pdl( [ 9, 9, 9 ] ); # 3 my $needle_in = $needle0_in->dummy(1); # 3x1: [[1 2 3]] my $needle_notin = $needle0_notin->dummy(1); # 3x1: [[-3 -2 -1]] my $needles = pdl( [ [ 1, 2, 3 ], [ 9, 9, 9 ] ] ) ; # 3x2: $needle0_in->cat($needle0_notin) my $haystack = pdl( [ [ 1, 2, 3 ], [ 4, 5, 6 ] ] ); # 3x2 sub intersect_ok { my ( $label, $a, $b, $c_want, $nc_want, $c_sclr_want ) = @_; my ( $c, $nc ) = intersectvec( $a, $b ); my $c_sclr = intersectvec( $a, $b ); ok tapprox( $c, $c_want ), "$label - result"; ok tapprox( $nc, $nc_want ), "$label - counts"; ok tapprox( $c_sclr, $c_sclr_want ), "$label - scalar"; } intersect_ok( 'intersectvec - implicit dims - needle0_in&haystack', $needle0_in, $haystack, [ [ 1, 2, 3 ] ], 1, [ [ 1, 2, 3 ] ] ); intersect_ok( 'intersectvec - implicit dims - needle_in&haystack', $needle_in, $haystack, [ [ 1, 2, 3 ] ], 1, [ [ 1, 2, 3 ] ] ); intersect_ok( 'intersectvec - implicit dims - needle0_notin&haystack', $needle0_notin, $haystack, [ [ 0, 0, 0 ] ], 0, zeroes( 3, 0 ) ); intersect_ok( 'intersectvec - implicit dims - needle_notin&haystack', $needle_notin, $haystack, [ [ 0, 0, 0 ] ], 0, zeroes( 3, 0 ) ); intersect_ok( 'intersectvec - implicit dims - needles&haystack', $needles, $haystack, [ [ 1, 2, 3 ], [ 0, 0, 0 ] ], 1, [ [ 1, 2, 3 ] ] ); # now we want to know whether each needle is "in" one by one, not really # a normal intersect, so we insert a dummy in haystack in order to broadcast # the "nc" needs to come back as a 4x2 my $needles8 = pdl( [ [ [ 1, 2, 3 ], [ 4, 5, 6 ], [ 8, 8, 8 ], [ 8, 8, 8 ] ], [ [ 4, 5, 6 ], [ 9, 9, 9 ], [ 1, 2, 3 ], [ 9, 9, 9 ] ] ] ); # 3x4x2 # need to manipulate above into suitable inputs for intersect to get right output # + dummy dim here also ensures singleton query-vector-sets are (trivially) sorted my $needles8x = $needles8->slice(",*1,,"); # 3x*x4x2 # dummy of size 1 inserted in dim 1 # haystack: no changes needed; don't need same number of dims, broadcast engine will add dummy/1s at top my $haystack8 = $haystack; my $c_want8 = [ [ [ [ 1, 2, 3 ] ], [ [ 4, 5, 6 ] ], [ [ 0, 0, 0 ] ], [ [ 0, 0, 0 ] ] ], [ [ [ 4, 5, 6 ] ], [ [ 0, 0, 0 ] ], [ [ 1, 2, 3 ] ], [ [ 0, 0, 0 ] ] ], ]; my $nc_want8 = [ [ 1, 1, 0, 0 ], [ 1, 0, 1, 0 ] ]; intersect_ok( 'intersectvec - implicit dims - needles8x&haystack8', $needles8x, $haystack8, $c_want8, $nc_want8, $c_want8 ); }; ## dim-checks and implicit broadcast dimensions ## + analogous to https://github.com/moocow-the-bovine/PDL-VectorValued/issues/4 subtest v_broadcast_dimensions => sub { # data: basic my $empty = zeroes(0); my $v1_2 = pdl( [ 1, 2 ] ); my $v3_4 = pdl( [ 3, 4 ] ); my $v1_4 = $v1_2->cat($v3_4)->flat; # data: broadcasting my $k = 2; my $kempty = $empty->slice(",*$k"); my $kv1_2 = $v1_2->slice(",*$k"); my $kv3_4 = $v3_4->slice(",*$k"); my $kv1_4 = $v1_4->slice(",*$k"); #-- union_sorted ok tapprox( scalar( $v1_2->union_sorted($v3_4) ), $v1_4 ), "union_sorted - broadcast dims - 12+34"; ok tapprox( scalar( $v3_4->union_sorted($v1_4) ), $v1_4 ), "union_sorted - broadcast dims - 34+1234"; ok tapprox( scalar( $empty->union_sorted($v1_4) ), $v1_4 ), "union_sorted - broadcast dims - 0+1234"; ok tapprox( scalar( $v1_4->union_sorted($empty) ), $v1_4 ), "union_sorted - broadcast dims - 1234+0"; ok tapprox( scalar( $empty->union_sorted($empty) ), $empty ), "union_sorted - broadcast dims - 0+0"; # ok tapprox( scalar( $kv1_2->union_sorted($v3_4) ), $kv1_4 ), "union_sorted - broadcast dims - 12(*k)+34"; ok tapprox( scalar( $kv3_4->union_sorted($v1_4) ), $kv1_4 ), "union_sorted - broadcast dims - 34(*k)+1234"; ok tapprox( scalar( $kempty->union_sorted($v1_4) ), $kv1_4 ), "union_sorted - broadcast dims - 0(*k)+1234"; ok tapprox( scalar( $kv1_4->union_sorted($empty) ), $kv1_4 ), "union_sorted - broadcast dims - 1234(*k)+0"; ok tapprox( scalar( $kempty->union_sorted($empty) ), $kempty ), "union_sorted - broadcast dims - 0(*k)+0"; #-- intersect_sorted ok tapprox( scalar( $v1_2->intersect_sorted($v3_4) ), $empty ), "intersect_sorted - broadcast dims - 12&34"; ok tapprox( scalar( $v3_4->intersect_sorted($v1_4) ), $v3_4 ), "intersect_sorted - broadcast dims - 34&1234"; ok tapprox( scalar( $empty->intersect_sorted($v1_4) ), $empty ), "intersect_sorted - broadcast dims - 0&1234"; ok tapprox( scalar( $v1_4->intersect_sorted($empty) ), $empty ), "intersect_sorted - broadcast dims - 1234&0"; ok tapprox( scalar( $empty->intersect_sorted($empty) ), $empty ), "intersect_sorted - broadcast dims - 0&0"; # ok tapprox( scalar( $kv1_2->intersect_sorted($v3_4) ), $kempty ), "intersect_sorted - broadcast dims - 12(*k)&34"; ok tapprox( scalar( $kv3_4->intersect_sorted($v1_4) ), $kv3_4 ), "intersect_sorted - broadcast dims - 34(*k)&1234"; ok tapprox( scalar( $kempty->intersect_sorted($v1_4) ), $kempty ), "intersect_sorted - broadcast dims - 0(*k)&1234"; ok tapprox( scalar( $kv1_4->intersect_sorted($empty) ), $kempty ), "intersect_sorted - broadcast dims - 1234(*k)&0"; ok tapprox( scalar( $kempty->intersect_sorted($empty) ), $kempty ), "intersect_sorted - broadcast dims - 0(*k)&0"; #-- setdiff_sorted ok tapprox( scalar( $v1_2->setdiff_sorted($v3_4) ), $v1_2 ), "setdiff_sorted - broadcast dims - 12-34"; ok tapprox( scalar( $v3_4->setdiff_sorted($v1_4) ), $empty ), "setdiff_sorted - broadcast dims - 34-1234"; ok tapprox( scalar( $v1_4->setdiff_sorted($empty) ), $v1_4 ), "setdiff_sorted - broadcast dims - 1234-0"; ok tapprox( scalar( $empty->setdiff_sorted($v1_4) ), $empty ), "setdiff_sorted - broadcast dims - 0-1234"; ok tapprox( scalar( $empty->setdiff_sorted($empty) ), $empty ), "setdiff_sorted - broadcast dims - 0-0"; # ok tapprox( scalar( $kv1_2->setdiff_sorted($v3_4) ), $kv1_2 ), "setdiff_sorted - broadcast dims - 12(*k)-34"; ok tapprox( scalar( $kv3_4->setdiff_sorted($v1_4) ), $kempty ), "setdiff_sorted - broadcast dims - 34(*k)-1234"; ok tapprox( scalar( $kv1_4->setdiff_sorted($empty) ), $kv1_4 ), "setdiff_sorted - broadcast dims - 1234(*k)-0"; ok tapprox( scalar( $kempty->setdiff_sorted($v1_4) ), $kempty ), "setdiff_sorted - broadcast dims - 0(*k)-1234"; ok tapprox( scalar( $kempty->setdiff_sorted($empty) ), $kempty ), "setdiff_sorted - broadcast dims - 0(*k)-0"; }; done_testing; PDL-2.085/t/math.t0000644000175000017500000000467014202424244013463 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.085/t/pthread.t0000644000175000017500000001310714415317170014161 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.085/t/primitive-setops.t0000644000175000017500000000252514547612401016060 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::LiteF; use lib 't/lib'; use My::Test::Primitive; subtest 'setops' => sub { my $temp = sequence(10); my $x = which( ( $temp % 2 ) == 0 ); my $y = which( ( $temp % 3 ) == 0 ); ok( tapprox( setops( $x, 'AND', $y ), pdl( [ 0, 6 ] ) ), "setops AND" ); ok( tapprox( intersect( $x, $y ), pdl( [ 0, 6 ] ) ), "intersect same as setops AND" ); ok( tapprox( setops( $x, 'OR', $y ), pdl( [ 0, 2, 3, 4, 6, 8, 9 ] ) ), "setops OR" ); ok( tapprox( setops( $x, 'XOR', $y ), pdl( [ 2, 3, 4, 8, 9 ] ) ), "setops XOR" ); }; subtest 'intersect' => sub { my $intersect_test = intersect( pdl( 1, -5, 4, 0 ), pdl( 0, 3, -5, 2 ) ); ok tapprox( $intersect_test, pdl( -5, 0 ) ), 'Intersect test values'; }; subtest 'AND' => sub { # based on cases supplied by @jo-37 my @cases = ( [ pdl(1), empty(), empty() ], [ ones(1), empty(), empty() ], [ ones(4), empty(), empty() ], [ sequence(4), empty(), empty() ], [ pdl(1), ones(2), ones(1) ], [ ones(1), ones(2), ones(1) ], [ ones(4), ones(2), ones(1) ], [ sequence(4), ones(2), ones(1) ], ); ok tapprox( setops( $_->[0], 'AND', $_->[1] ), $_->[2] ), "$_->[0] AND $_->[1]" for @cases; }; done_testing; PDL-2.085/t/thread_def.t0000644000175000017500000000367214216003230014611 0ustar osboxesosboxesuse Test::More; 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'); # make sure compat alias works thread_define 'tline(a(n);b(n))', over { $_[0] .= $_[1]; }; # not very useful examples but simple and test the essentials broadcast_define 'tassgn(a(n,m);[o] b())', over { # sumover($_[0],$_[1]); $_[1] .= $_[0]->sum; }; broadcast_define 'ttext(a(n=3)), NOtherPars => 1', over { ${$_[1]} .= sprintf("%.3f %.3f %.3f,\n",$_[0]->list); #join(' ',$_[0]->list) . ",\n"; }; broadcast_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 -> broadcastdim note "testing tprint\n"; $pa = sequence(3); $pb = pdl [1]; my $text = ""; tprint($pa, $pb, \$text); is $text, '[1 1 1]'; # cut down from PDL::Apply which got broken by 2.057_01 thread_define '_apply_slice_ND(data(n);sl(2,m);[o]output(m)),NOtherPars=>2', over { _apply_slice_1D($_[1], ones($_[0]->type), my $output = null, @_[0,3,4]); $_[2] .= $output; }; thread_define '_apply_slice_1D(slices(n);dummy();[o]output()),NOtherPars=>3', over { my $func = $_[4]; my $args = $_[5]; my $data = slice($_[3], $_[0]->unpdl); $_[2] .= PDL::Core::topdl($data->$func(@$args)); }; my $x = sequence(5,3,2); my $slices = indx([0,2], [1,3], [2,4]); my $y = null; lives_ok { _apply_slice_ND($x, $slices, $y, 'sum', []) }; done_testing; PDL-2.085/t/config.t0000644000175000017500000000044514146003631013773 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.085/t/primitive-stats.t0000644000175000017500000000326414547612401015702 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::LiteF; use lib 't/lib'; use My::Test::Primitive; # provide independent copies of test data. sub IM { PDL->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, ] ] ); } subtest 'default type' => sub { my @statsRes = IM->stats; ok( tapprox( $statsRes[0], 5.36 ), "mean" ); ok( tapprox( $statsRes[1], 4.554 ), "prms" ); ok( tapprox( $statsRes[2], 3 ), "median" ); ok( tapprox( $statsRes[3], 1 ), "min" ); ok( tapprox( $statsRes[4], 13 ), "max" ); ok( tapprox( $statsRes[6], 4.462 ), "rms" ); }; subtest 'short' => sub { my @statsRes = IM->short->stats; # Make sure that stats are promoted to floating-point ok( tapprox( $statsRes[0], 5.36 ), "short mean" ); ok( tapprox( $statsRes[1], 4.554 ), "short prms" ); ok( tapprox( $statsRes[2], 3 ), "short median" ); ok( tapprox( $statsRes[3], 1 ), "short min" ); ok( tapprox( $statsRes[4], 13 ), "short max" ); ok( tapprox( $statsRes[6], 4.462 ), "short rms" ); }; subtest 'weights' => sub { my $ones = ones( 5, 5 ); my @statsRes = IM->stats($ones); ok( tapprox( $statsRes[0], 5.36 ), "trivial weights mean" ); ok( tapprox( $statsRes[1], 4.554 ), "trivial weights prms" ); ok( tapprox( $statsRes[2], 3 ), "trivial weights median" ); ok( tapprox( $statsRes[3], 1 ), "trivial weights min" ); ok( tapprox( $statsRes[4], 13 ), "trivial weights max" ); ok( tapprox( $statsRes[6], 4.462 ), "trivial weights rms" ); }; done_testing; PDL-2.085/t/bigmem.t0000644000175000017500000000303614202424257013771 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 # broadcast_define # broadcast # diagonal # broadcast[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.085/t/reduce.t0000644000175000017500000000070014020771662013776 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.085/t/primitive-selector.t0000644000175000017500000001546614553555460016403 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use Test::Exception; use PDL::LiteF; use lib 't/lib'; use My::Test::Primitive; subtest 'where' => sub { subtest 'where' => sub { 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 ) ), ">" ); ok( tapprox( $c->where($y), PDL->pdl( 10, 11, 12, 17, 18, 20, 21 ) ), "mask" ); }; subtest 'where_both' => sub { my $y = sequence(10) + 2; my ( $big, $small ) = where_both( $y, $y > 5 ); $big += 2, $small -= 1; ok tapprox( $big, pdl('[8 9 10 11 12 13]') ), 'big + 2 is right'; ok tapprox( $small, pdl('[1 2 3 4]') ), 'small - 2 is right'; ok tapprox( $y, pdl('[1 2 3 4 8 9 10 11 12 13]') ), 'dataflow affected orig'; }; subtest 'whereND' => sub { is_deeply( [ zeroes( 2, 3, 1 )->whereND( pdl '0 0' )->dims ], [ 0, 3, 1 ] ); is_deeply( [ zeroes( 2, 0 )->whereND( pdl '1 1' )->dims ], [ 2, 0 ] ); subtest '1D' => sub { my $x = sequence( 4, 3, 2 ); my $y = pdl( 0, 1, 1, 0 ); my $c = whereND( $x, $y ); is_deeply( [ $c->dims ], [ 2, 3, 2 ] ); ok tapprox( $c, pdl q[[[1 2] [5 6] [9 10]] [[13 14] [17 18] [21 22]]] ), "[4]"; }; subtest 'nD' => sub { my $x = sequence( 4, 3, 2 ); my $y = pdl q[ 0 0 1 1 ; 0 1 0 0 ; 1 0 0 0 ]; my $c = whereND( $x, $y ); is_deeply( [ $c->dims ], [ 4, 2 ] ); ok tapprox( $c, pdl q[ 2 3 5 8 ; 14 15 17 20 ] ), "[4,3]"; }; subtest 'vs where' => sub { my $x = sequence( 4, 3, 2 ); my $y = ( random($x) < 0.3 ); my $c = whereND( $x, $y ); my $where = where( $x, $y ); ok tapprox( $c->squeeze, $where ), "vs where" or diag "x=$x\ny=$y\nwhere=$where\nc=$c"; }; subtest 'lvalue' => sub { # Make sure whereND functions as an lvalue: my $x = sequence( 4, 3 ); my $y = pdl( 0, 1, 1, 1 ); lives_ok { $x->whereND($y) *= -1 } 'lvalue multiply'; ok( all( $x->slice("1:-1") < 0 ), 'works' ); }; subtest 'sf.net bug 3415115' => sub { # sf.net bug #3415115, whereND fails to handle all zero mask case my $x = sequence( 4, 3 ); my $y = zeros(4); my $c = whereND( $x, $y ); ok( $c->isempty, 'all-zeros mask' ); }; }; }; subtest 'which' => sub { subtest 'which' => sub { subtest 'heterogenous values' => sub { my $y = PDL->pdl( 4, 3, 1, 0, 0, 0, 0, 5, 2, 0, 3, 6 ); ok( tapprox( $y->which, PDL->pdl( 0, 1, 2, 7, 8, 10, 11 ) ), "heterogenous values" ); }; ok zeroes(3)->which->isempty, 'all zeroes returns empty'; # Test bad handling in selector subtest 'bad value' => sub { my $y = xvals(3); ok( tapprox( $y->which, PDL->pdl( 1, 2 ) ), "only good" ); setbadat $y, 1; ok( tapprox( $y->which, PDL->pdl( [2] ) ), "good & bad" ); setbadat $y, 0; setbadat $y, 2; is( $y->which->nelem, 0, "only bad" ); }; }; subtest 'which_both' => sub { my $which_both_test = pdl( 1, 4, -2, 0, 5, 0, 1 ); my ( $nonzero, $zero ) = which_both($which_both_test); ok tapprox( $nonzero, pdl( 0, 1, 2, 4, 6 ) ), 'nonzero indices'; ok tapprox( $zero, pdl( 3, 5 ) ), 'zero indices'; }; subtest 'whichND' => sub { subtest 'Nontrivial case gives correct coordinates' => sub { my $r = xvals( 10, 10 ) + 10 * yvals( 10, 10 ); my $x = whichND( $r % 12 == 0 ); is_deeply( $x->unpdl, [ [ 0, 0 ], [ 2, 1 ], [ 4, 2 ], [ 6, 3 ], [ 8, 4 ], [ 0, 6 ], [ 2, 7 ], [ 4, 8 ], [ 6, 9 ] ] ); is $x->type, 'indx', 'returns indx-type'; }; subtest 'Empty case gives matching Empty' => sub { my $r = xvals( 10, 10 ) + 10 * yvals( 10, 10 ); my $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"; }; subtest 'Scalar PDLs are treated as 1-PDLs' => sub { my $x = whichND( pdl(5) ); is $x->nelem, 1, "whichND scalar PDL"; is $x, 0, "whichND scalar PDL"; is $x->type, 'indx', "returns indx ndarray for scalar ndarray mask"; }; subtest 'Scalar empty case returns a 1-D vector of size 0' => sub { my $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', "returns indx-type ndarray for scalar empty case"; }; subtest 'Empty case returns Empty' => sub { my $y = whichND( which( pdl(0) ) ); is $y->nelem, 0, "whichND of Empty mask"; is $y->type, 'indx', "returns indx-type ndarray for empty case"; }; subtest 'whichND(Empty[2x0x2]) should return Empty[3x0]' => sub { my $y = whichND( zeroes( 2, 0, 2 ) ); is_deeply [ $y->dims ], [ 3, 0 ]; }; subtest 'regression' => sub { my $r = zeroes( 7, 7 ); $r->set( 3, 4, 1 ); is_deeply( $r->whichND->unpdl, [ [ 3, 4 ] ], 'was failing on 32-bit' ); }; subtest 'torture test' => sub { my $a1 = PDL->sequence( 10, 10, 3, 4 ); my ( $x, $y, $z, $w ) = whichND( $a1 == 203 )->mv( 0, -1 )->dog; ok( $a1->at( $x->list, $y->list, $z->list, $w->list ) == 203, "whichND" ); }; }; }; subtest 'uniq' => sub { ok tapprox( sequence(4)->uniq, sequence(4) ), 'heterogeneous'; ok tapprox( ones(4)->uniq, ones(1) ), 'repeated homogenous'; ok tapprox( empty()->uniq, empty() ), 'empty'; ok tapprox( pdl( [ [1] ] )->uniq, ones(1) ), '2-deep uniq flattens'; # Data::Frame relies }; subtest 'uniqind' => sub { my $x = pdl( [ 0, 1, 2, 2, 0, 1 ] ); my $y = $x->uniqind; is_deeply( $y->unpdl, [ 0, 1, 3 ] ); is $y->ndims, 1, "uniqind"; subtest 'SF bug 3076570' => sub { my $y = pdl( 1, 1, 1, 1, 1 )->uniqind; # SF bug 3076570 ok( !$y->isempty ); ok all( $y == pdl( [0] ) ), 'uniqind'; is $y->ndims, 1, 'ndims'; }; }; done_testing; PDL-2.085/t/constants.t0000644000175000017500000000056614146003631014546 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.085/t/01-pptest.t0000644000175000017500000004105714417552272014302 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)" }); pp_addhdr(' void ppcp(PDL_Byte *dst, PDL_Byte *src, int len); '); # test the $P vaffine behaviour # when 'phys' flag is in. pp_def('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_def('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_def( 'fsumover', Pars => 'a1(n); float [o]b();', Code => 'PDL_Float tmp = 0; loop(n) %{ tmp += $a1(); %} $b() = tmp;' ); # test GENERIC with type+ qualifier pp_def( '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_def('setdim', Pars => '[o] a(n)', OtherPars => 'int ns => n', Code => 'loop(n) %{ $a() = n; %}', ); pp_def("gelsd", Pars => '[io,phys]A(m,n); [io,phys]B(p,q); [phys]rcond(); [o,phys]s(r); int [o,phys]rank();int [o,phys]info()', RedoDimsCode => '$SIZE(r) = PDLMIN($SIZE(m),$SIZE(n));', GenericTypes => ['F'], Code => '$CROAK("croaking");' ); pp_def('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_def( '_flatten_into', Pars => "in(m); indx b(m); [o] idx(m)", Code => ' loop(m) %{ $idx() = $in(); %} ', ); pp_addhdr << 'EOH'; void tinplace_c2(int n, PDL_Float* data1, PDL_Float* data2); EOH pp_def('fooflow2', Pars => '[io]a(n);[io]b(n)', GenericTypes => ['F'], Code => 'tinplace_c2($SIZE(n),$P(a),$P(b));', ); pp_def( 'broadcastloop_continue', Pars => 'in(); [o] out()', Code => q[ int cnt = 0; threadloop %{ if ( ++cnt %2 ) continue; $out() = $in(); %} ], ); pp_def('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_def('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_def('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_def('polyfill_pp', Pars => 'int [io] 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_def('output_op', Pars => 'in(n=2)', OtherPars => '[o] PDL_Anyval v0; [o] PDL_Anyval v1', Code => ' pdl_datatypes dt = $PDL(in)->datatype; ANYVAL_FROM_CTYPE($COMP(v0), dt, $in(n=>0)); ANYVAL_FROM_CTYPE($COMP(v1), dt, $in(n=>1)); ', ); pp_def('output_op2', Pars => 'in(n=2); [o] out()', OtherPars => '[o] PDL_Anyval v0; [o] PDL_Anyval v1', Code => ' pdl_datatypes dt = $PDL(in)->datatype; ANYVAL_FROM_CTYPE($COMP(v0), dt, $in(n=>0)); ANYVAL_FROM_CTYPE($COMP(v1), dt, $in(n=>1)); ', ); pp_def('output_op3', Pars => 'in(n=2); [o] out()', OtherPars => '[o] PDL_Anyval v0; [o] PDL_Anyval v1', Code => ' pdl_datatypes dt = $PDL(in)->datatype; ANYVAL_FROM_CTYPE($COMP(v0), dt, $in(n=>0)); ANYVAL_FROM_CTYPE($COMP(v1), dt, $in(n=>1)); ', PMCode => 'sub PDL::output_op3 { goto &PDL::_output_op3_int }', ); pp_def('incomp_dim', Pars => '[o] a();', OtherPars => 'PDL_Indx d[];', Code => '$a() = $COMP(d_count);', ); pp_addhdr(' typedef NV NV_ADD1; '); pp_add_typemaps(string=><<'EOT'); TYPEMAP: < 'int [o] out()', OtherPars => '[io] NV_ADD1 v1', Code => '$out() = $COMP(v1); $COMP(v1) = 8;', ); pp_def('incomp_in', Pars => '[o] out()', OtherPars => 'pdl *ins[]', RedoDimsCode => <<'EOC', pdl **ins = $COMP(ins); PDL_Indx i; for (i = 0; i < $COMP(ins_count); i++) { pdl *in = ins[i]; PDL_RETERROR(PDL_err, PDL->make_physdims(in)); if (in->ndims != 1) $CROAK("input ndarray %"IND_FLAG" has %"IND_FLAG" dims, not 1", i, in->ndims); if (!$PRIV(bvalflag) && (in->state & PDL_BADVAL)) $PRIV(bvalflag) = 1; } EOC Code => <<'EOC', pdl **ins = $COMP(ins); PDL_Indx i; for (i = 0; i < $COMP(ins_count); i++) PDL_RETERROR(PDL_err, PDL->make_physical(ins[i])); $out() = 0; for (i = 0; i < $COMP(ins_count); i++) { pdl *in = ins[i]; PDL_Indx j; #define X_CAT_INNER(datatype_in, ctype_in, ppsym_in, ...) \ PDL_DECLARE_PARAMETER_BADVAL(ctype_in, 0, in, (in), 1) \ for(j=0; jnvals; j++) { \ if ($PRIV(bvalflag) && PDL_ISBAD(in_physdatap[j], in_badval, ppsym_in)) continue; \ $out() += in_physdatap[j]; \ } PDL_GENERICSWITCH(PDL_TYPELIST2_ALL, in->datatype, X_CAT_INNER, $CROAK("Not a known data type code=%d", in->datatype)) #undef X_CAT_INNER } EOC ); pp_def('incomp_out', Pars => 'in(n)', OtherPars => 'PDL_Indx howmany; [o] pdl *outs[]', HandleBad => 1, CallCopy => 0, GenericTypes => [PDL::Types::ppdefs_all()], Code => <<'EOC', pdl **outs = malloc(($COMP(outs_count) = $COMP(howmany)) * sizeof(pdl*)); $COMP(outs) = outs; PDL_Indx i, ndims = $PDL(in)->ndims, dims[ndims]; for (i = 0; i < ndims; i++) dims[i] = $PDL(in)->dims[i]; for (i = 0; i < $COMP(outs_count); i++) { pdl *o = outs[i] = PDL->pdlnew(); if (!o) { for (i--; i >= 0; i--) PDL->destroy(outs[i]); free(outs); $CROAK("Failed to create ndarray"); } o->datatype = $PDL(in)->datatype; PDL_err = PDL->setdims(o, dims, ndims); if (PDL_err.error) { for (; i >= 0; i--) PDL->destroy(outs[i]); free(outs); return PDL_err; } PDL_err = PDL->allocdata(o); if (PDL_err.error) { for (; i >= 0; i--) PDL->destroy(outs[i]); free(outs); return PDL_err; } PDL_DECLARE_PARAMETER_BADVAL($GENERIC(in), 0, o, (o), 1) loop(n) %{ o_datap[n] = $in(); %} } EOC ); pp_def('index_prec', # check $a(n=>x+1) works Pars => 'in(n); [o]out()', Code => 'loop (n) %{ if (n > 1) $out() += $in(n=>n-1); %}', ); pp_def("diff_central", Pars => 'double x(); double [o] res();', OtherPars => 'SV* function;', Code => ';', ); # 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 "broadcastloop" appears, later automatic broadcastloops # will not be generated, even if the original broadcastloop 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_def('or2', Pars => 'a(); b(); [o]c();', OtherPars => 'int swap; char *ign; int ign2', OtherParsDefaults => { swap => 0, ign=>'""', ign2=>0 }, ArgOrder => 1, Code => '$c() = $a() | $b();', GenericTypes => [qw(A B S U L K N P Q)], ); # from HMM pp_def('logadd', Pars => 'a(); b(); [o]c()', GenericTypes => [qw(F D LD)], Inplace=>['a'], ##-- can run inplace on a() Code => ';', ); pp_def('ftr', Pars => 'a(); [o]b()', Code => ';', FtrCode => " sv_setiv(perl_get_sv(\"main::FOOTERVAL\",TRUE), 1);\n", ); 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-broadcastloop 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 foop($x,($y=null)); ok( tapprox($x,$y) ) or diag $y; foop($x->transpose,($y=null)); ok( tapprox($x->transpose,$y) ) or diag $y; my $vaff = $x->dummy(2,3)->xchg(1,2); foop($vaff,($y=null)); ok( tapprox($vaff,$y) ) or diag ($vaff, $vaff->dump); eval { foop($x,($y=pdl([1]))) }; isnt $@, '', '[phys] with multi-used mismatched dim of 1 throws exception'; eval { foop(pdl([1]),($y=pdl([1]))) }; is $@, '', '[phys] with multi-used matched dim of 1 no exception'; eval { foop1($x,($y=pdl([1]))) }; is $@, '', '[phys] with single-used dim of 1 no exception'; # float qualifier $x = ones(byte,3000); 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); nsumover($x,($y=null)); is( $y->get_datatype, (($PDL_L > $_->[0]) ? $PDL_L : $_->[0]) ); is( $y->at, 3000 ); } setdim(($x=null),10); is( join(',',$x->dims), "10" ); ok( tapprox($x,sequence(10)) ); { my @msg; local $SIG{__WARN__} = sub { push @msg, @_ }; eval { nan(2,2)->gelsd(nan(2,2), -3) }; like $@, qr/croaking/, 'right error message'; is_deeply \@msg, [], 'no warnings' or diag explain \@msg; } # this used to segv under solaris according to Karl { my $ny=7; $x = double xvals zeroes (20,$ny); 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 { _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(''); fooflow2($sl11, $sl22); ok(all $xx->slice('(0)') == 599); ok(all $xx->slice('(1)') == 699); # test that continues in a broadcastloop work { my $in = sequence(10); my $got = $in->zeroes; my $exp = $in->copy; my $tmp = $exp->where( ! ($in % 2) ); $tmp .= 0; broadcastloop_continue( $in, $got ); ok( tapprox( $got, $exp ), "continue works in broadcastloop" ) or do { diag "got : $got"; diag "expected: $exp" }; } Cpow(sequence(2), 1); polyfill_pp(zeroes(5,5), ones(2,3), 1); eval { polyfill_pp(ones(2,3), 1) }; like $@, qr/Usage/; is succ(2)."", 3, 'test pp_add_macros works'; output_op([5,7], my $v0, my $v1); is_deeply [$v0,$v1], [5,7], 'output OtherPars work'; ($v0, $v1) = output_op([5,7]); is_deeply [$v0,$v1], [5,7], 'output OtherPars work 1a'; eval { output_op(sequence(2,3), my $v0, my $v1) }; isnt $@, '', 'broadcast with output OtherPars throws'; output_op2([5,7], my $n=PDL->null, my $v0_2, my $v1_2); is_deeply [$v0_2,$v1_2], [5,7], 'output OtherPars work 2'; (undef, $v0_2, $v1_2) = output_op2([5,7]); is_deeply [$v0_2,$v1_2], [5,7], 'output OtherPars work 2a'; eval { output_op2(sequence(2,3), my $n=PDL->null, my $v0_2, my $v1_2) }; like $@, qr/Can't broadcast/, 'broadcast with output OtherPars throws 2'; output_op3([5,7], my $out3 = PDL->null, my $v0_3, my $v1_3); is_deeply [$v0_3,$v1_3], [5,7], 'output OtherPars work 3' or diag "got: ",$v0_3," ",$v1_3; incomp_dim(my $o = PDL->null, [0..3]); is "$o", 4; $o = incomp_dim([0..3]); is "$o", 4; $o = typem(my $oth = 3); is "$o", 4; is "$oth", 7; typem($o = PDL->null, $oth = 3); is "$o", 4; is "$oth", 7; incomp_in($o = PDL->null, [sequence(3), sequence(byte, 4)]); is "$o", 9; $o = incomp_in([sequence(3), sequence(byte, 4)]); is "$o", 9; my $one_bad = sequence(byte, 4); $one_bad->badflag(1); $one_bad->badvalue(2); $o = incomp_in([sequence(3), $one_bad]); is "$o", 7; incomp_in($o = PDL->null, []); is "$o", 0; incomp_in($o = PDL->null, undef); is "$o", 0; eval { incomp_in($o = PDL->null, 'hello') }; isnt $@, ''; incomp_out(sequence(3), 2, my $nds); is 0+@$nds, 2; is +($nds->[0]//'undef').'', "[0 1 2]"; $nds = incomp_out(sequence(3), 2); is 0+@$nds, 2; is +($nds->[0]//'undef').'', "[0 1 2]"; is index_prec(sequence(2,6)->slice('(1)')).'', 24, 'index precedence OK'; eval { diff_central(pdl(1), sub {}) }; is $@, ''; { 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 broadcastloop. 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 broadcastloop does not work') or diag("\$x is $x and \$y is $y"); } } eval { is ''.or2(pdl(1), pdl(1), 0), '1' }; is $@, ''; eval { ldouble(4)->logadd(3) }; is $@, ''; undef $main::FOOTERVAL; ftr(1); is $main::FOOTERVAL, 1; done_testing; EOF ); do_tests(\%PPTESTFILES); sub do_tests { my ($hash, $error_re, $dir) = @_; 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); }, $dir, ); } 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.085/t/primitive-vsearch.t0000644000175000017500000003721714547612401016204 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use Test::Exception; use PDL::LiteF; use lib 't/lib'; use My::Test::Primitive; # 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 tapprox( vsearch( $so->{x}, $so->{x}, { mode => $mode } ), $so->{equal} ), 'equal elements'; my $badmask = $so->{x}->random < 0.25; my $badx = $so->{x}->setbadif( $badmask ); my $bad_eq = $so->{equal}->setbadif( $badmask ); ok tapprox( vsearch( $badx, $so->{x}, { mode => $mode } ), $bad_eq ), 'equal elements w/ bad vals'; ok tapprox( vsearch( $so->{x} - 5, $so->{x}, { mode => $mode } ), $so->{nequal_m} ), 'non-equal elements x[i] < xs[i] (check lower bound)'; ok tapprox( vsearch( $so->{x} + 5, $so->{x}, { mode => $mode } ), $so->{nequal_p} ), 'non-equal elements x[i] > xs[i] (check upper bound)'; # 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 tapprox( $so->{xdup}{set}->index( vsearch( $so->{xdup}{values}, $so->{xdup}{set}, { mode => $mode } ) + ( $so->{xdup}{idx_offset} || 0 ) ), $so->{xdup}{values} ), 'duplicates values'; # if there are guarantees about which duplicates are returned, test it if ( exists $so->{xdup}{idx} ) { ok tapprox( vsearch( $so->{xdup}{values}, $so->{xdup}{set}, { mode => $mode } ), $so->{xdup}{idx} ), 'duplicate indices'; } 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 vsearch( $value, $so->{x}, { mode => $mode } ) ->sclr, $exp, "$label: ($idx, $offset)"; } } } }; } ok tapprox( vsearch( $ones, $ones, { mode => $mode } )->uniq->squeeze, $data->{all_the_same_element} ), 'all the same element'; }; } # 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 tapprox( $indx0, $indx1 ), 'explicit ndarray == implicit ndarray'; } subtest regressions => sub { subtest '$xs->is_empty' => sub { lives_ok { pdl( [0] )->vsearch_bin_inclusive( pdl( [] ) ) }; }; }; done_testing; PDL-2.085/t/primitive-misc.t0000644000175000017500000000412614555743012015477 0ustar osboxesosboxesuse Test::More; use PDL::LiteF; use PDL::Types; use lib 't/lib'; use My::Test::Primitive; subtest 'why are these tested in Primitive?' => sub { subtest 'xvals type' => sub { my $xvals = ones( byte, 300 )->xvals; is $xvals->at(280), 280,'non-overflow xvals from byte ndarray'; is xvals(short, 2)->type, 'short', 'xvals respects specified type'; }; subtest 'empty ndarray' => sub { my $x = which ones(4) > 2; my $y = $x->long; my $c = $x->double; ok( isempty $x, "isempty" ); ok( $y->avg == 0, "avg of Empty" ); ok( !any isfinite $c->average, "isfinite of Empty" ); }; }; subtest norm => sub { my $x = pdl('[[i 2+3i] [4+5i 6+7i]]'); ok tapprox $x->norm, pdl( [ [ 0.267261 * i, 0.534522 + 0.801783 * i ], [ 0.356348 + 0.445435 * i, 0.534522 + 0.623609 * i ], ] ), 'native complex norm works' or diag $x->norm; }; subtest glue => sub { my $x = xvals( 2, 2, 2 ); my $y = yvals( 2, 2, 2 ); my $c = zvals( 2, 2, 2 ); is_deeply $x->glue( 1, $y, $c )->unpdl, [ [ [ 0, 1 ], [ 0, 1 ], [ 0, 0 ], [ 1, 1 ], [ 0, 0 ], [ 0, 0 ] ], [ [ 0, 1 ], [ 0, 1 ], [ 0, 0 ], [ 1, 1 ], [ 1, 1 ], [ 1, 1 ] ] ]; }; subtest 'fibonacci' => sub { my $fib = fibonacci(15); my $fib_ans = pdl( 1, 1, 2, 3, 5, 8, 13, 21, 34, 55, 89, 144, 233, 377, 610 ); ok tapprox( $fib, $fib_ans ), 'Fibonacci sequence'; }; subtest 'indadd' => sub { my $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" ); }; # diag one2nd is undocumented. subtest 'one2nd' => sub { my $a1 = zeroes( 3, 4, 5 ); my $indices = pdl( 0, 1, 4, 6, 23, 58, 59 ); my ( $x, $y, $z ) = $a1->one2nd($indices); ok tapprox( $x, pdl( 0, 1, 1, 0, 2, 1, 2 ) ), "one2nd x"; ok tapprox( $y, pdl( 0, 0, 1, 2, 3, 3, 3 ) ), "one2nd y"; ok tapprox( $z, pdl( 0, 0, 0, 0, 1, 4, 4 ) ), "one2nd z"; }; done_testing; PDL-2.085/t/ops-bitwise.t0000644000175000017500000000075114202424257014777 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.085/t/func.pdl0000644000175000017500000000015213265417442014002 0ustar osboxesosboxes # Test file for autoloader.t sub func { my $x = shift; return ($x**3 + 2); }; 1; # OK status PDL-2.085/t/primitive-random.t0000644000175000017500000000231714547612401016022 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use Test::Exception; use PDL::LiteF; use lib 't/lib'; use My::Test::Primitive; TODO: { local $TODO = 'Some CPAN Testers fails for OpenBSD'; subtest 'random' => sub { # check that our random functions work with Perl's srand # local $TODO = ; subtest 'random and srand' => sub { srand 5; my $r1 = random 10; srand 5; my $r2 = random 10; ok( tapprox( $r1, $r2 ), "random and srand" ); }; subtest 'grandom and srand' => sub { srand 10; my $r1 = grandom 10; srand 10; my $r2 = grandom 10; ok( tapprox( $r1, $r2 ), "grandom and srand" ); }; }; } subtest 'types' => sub { subtest 'random' => sub { my $type; lives_ok { $type = random()->type } 'random()'; is( $type, 'double', 'defaults to double' ); }; subtest 'randsym' => sub { my $type; lives_ok { $type = randsym()->type } 'randsym()'; is( $type, 'double', 'defaults to double' ); }; }; subtest 'regressions' => sub { # Test some operations with empty ndarrays lives_ok { random( 1, 1, 0 )->type } 'empty ndarray'; # used to segfault }; done_testing; PDL-2.085/t/bad.t0000644000175000017500000005160014415317170013260 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; { my $a_bad = pdl double, '[1 BAD 3]'; my $b_double = zeroes double, 3; $a_bad->assgn($b_double); ok $b_double->badflag, 'b_double badflag set'; is $b_double.'', '[1 BAD 3]', 'b_double got badval'; my $b_float = zeroes float, 3; $a_bad->assgn($b_float); ok $b_float->badflag, 'b_float badflag set'; is $b_float.'', '[1 BAD 3]', 'b_float got badval'; } # 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 empty()->setbadtoval(20); # shouldn't segfault $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 = zeroes(20,30); $y = $x->slice('0:10,0:10'); $c = $y->slice(',(2)'); ok !$c->badflag, 'no badflag on slice-child of good'; $x->badflag(1); ok $c->badflag, 'badflag on same slice-child of good set to bad'; $c->badflag(0); ok !$x->badflag, 'badflag now off for slice-parent of bad slice-child set to good'; $x = pdl '1 BAD'; ok any($x > 0), 'any with some badvals just omits them'; ok all($x > 0), 'all with some badvals just omits them'; ## $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( $x->badflag, 0, "direct pdl badflag cleared using inplace setbadtoval()" ); is( $y->badflag, 0, "child pdl 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); # broadcast over n() is( PDL::Core::string( isbad($y) ), "[1 0]", "broadcast 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 \S*nan 2 3 -?0 \S*nan 2 3 -?0 \S*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 \S*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 => 1, }, { 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 => 1, } ]; 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.085/t/pp_line_numbers.t0000644000175000017500000000326614413745716015731 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 broadcastloop */ loop (n) %{ /* line 17, Line after loop */ %} /* line 19, Line after close of loop */ %} /* line 21, Line after close of broadcastloop */ }), 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.085/t/matrix.t0000644000175000017500000000213414325015522014030 0ustar osboxesosboxesuse strict; use warnings; use PDL::LiteF; use Test::More; use PDL::Matrix; use PDL::MatrixOps; my $m = mpdl([[1,2,1],[2,0,3],[1,1,1]]); # matrix with determinant 1 my $tol = 1e-6; note "determinant: ",$m->det; ok approx($m->det, 1, $tol), "det" or diag 'got: ', $m->det; ok approx($m->determinant, 1, $tol), "determinant"; is ref(identity($m)), 'PDL::Matrix', 'identity of mpdl right class'; is ref(my $from_scalar = identity(vpdl 3)), 'PDL::Matrix', 'identity of mpdl right class'; is $from_scalar.'', <inv; my $gotmethmul = $gotmeth x $v; isa_ok $gotmeth, 'PDL::Matrix', '$mpdl->inv right class'; ok all(approx $gotmethmul, $expected, $tol), '$mpdl->inv mult correct'; done_testing; PDL-2.085/t/primitive-clip.t0000644000175000017500000000220714547612401015467 0ustar osboxesosboxesuse Test::More; use PDL::LiteF; sub IM { PDL->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, ] ] ); } is_deeply( IM->hclip(5)->unpdl, [ [ 1, 2, 3, 3, 5 ], [ 2, 3, 4, 5, 5 ], [ 5, 5, 5, 5, 5 ], [ 1, 3, 1, 3, 1 ], [ 5, 5, 2, 2, 2, ] ], 'hclip' ); is_deeply( IM->lclip(5)->unpdl, [ [ 5, 5, 5, 5, 5 ], [ 5, 5, 5, 5, 6 ], [ 13, 13, 13, 13, 13 ], [ 5, 5, 5, 5, 5 ], [ 10, 10, 5, 5, 5, ] ], 'lclip' ); is_deeply( IM->clip( 5, 7 )->unpdl, [ [ 5, 5, 5, 5, 5 ], [ 5, 5, 5, 5, 6 ], [ 7, 7, 7, 7, 7 ], [ 5, 5, 5, 5, 5 ], [ 7, 7, 5, 5, 5, ] ], 'clip' ); subtest 'with NaN badvalue' => sub { my $im = sequence(3); $im->badvalue( nan() ); $im->badflag(1); $im->set( 1, nan() ); my $clipped = $im->lclip(0); is_deeply $clipped->unpdl, [0, 'BAD', 2], 'ISBAD() works when badvalue is NaN'; }; done_testing; PDL-2.085/t/inlinepdlpp.t0000644000175000017500000000243214202424257015046 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.085/t/croak.t0000644000175000017500000000353414146003631013627 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.085/t/inline-with.t0000644000175000017500000000432114551015716014761 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; require Parse::RecDescent; # As of 2024, GHA is caching locallib without this but only on 5.10. Inline::C is broken without it 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.085/t/primitive-append.t0000644000175000017500000000322414556052645016017 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use Test::Exception; use PDL::LiteF; is_deeply( append( zeroes( 2, 0 ), zeroes( 3, 0 ) )->shape->unpdl, [ 5, 0 ], 'multi-dim empty shape' ); is_deeply( append( pdl( 1, 2, 3, 4 ), 2 )->unpdl, [ 1, 2, 3, 4, 2 ], '[4], [1]' ); subtest '$output = append (null,null) ' => sub { my $output = append( null, null ); ok !$output->isnull, 'returns non-null'; ok $output->isempty, 'returns empty'; }; subtest 'append(null, null, $output)' => sub { my $output = zeroes(1); append( null, null, $output ); is_deeply( $output->unpdl, [0], q{user's ndarray is unchanged} ); }; subtest 'output ndarray has different shape' => sub { subtest 'output => [1]; required [2]. output too small' => sub { my $output = zeroes(1); throws_ok { append( pdl(1), pdl(2), $output ) } qr/dim has size 1/; }; subtest 'output => [3,1]; required [2]' => sub { my $output = zeroes(3,1); throws_ok { append( pdl(1), pdl(2), $output ) } qr/dim has size 3/; }; subtest 'output => null; required [2]' => sub { my $output = null; append( pdl(1), pdl(2), $output ); is_deeply( $output->unpdl, [ 1, 2 ], q{full append } ); }; }; subtest types => sub { is( append( zeroes( float, 2, 0 ), zeroes( 3, 0 ) )->type, 'float', 'float + double = float' ); my $b1 = indx( 1, 2 ); is $b1->type, 'indx', '$indx_pdl is an indx pdl'; $b1 = $b1->append(-1); is $b1->type, 'indx', 'append($indx_pdl, -1) returns an indx pdl'; is $b1. '', '[1 2 -1]', 'append($indx_pdl, -1) correct content'; }; done_testing; PDL-2.085/t/scope.t0000644000175000017500000000274114146003631013640 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.085/t/ufunc.t0000644000175000017500000002116514547604050013657 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use PDL::LiteF; use PDL::Types; use lib 't/lib'; use My::Test::Primitive; 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"; my $ind_double = zeroes($p2d->dim(1)); $p2d->qsortveci($ind_double); # shouldn't segfault! is $ind_double.'', '[3 0 2 4 1]'; eval { empty()->medover }; # shouldn't segfault isnt $@, '', 'exception for percentile on empty ndarray'; # 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 = empty(); $x = $empty->maximum; ok( $x->nelem==1, "maximum over an empty dim yields 1 value"); is $x.'', 'BAD', "max of empty nonbad float gives BAD"; # test bad value handling with max $empty->badflag(1); $x = $empty->maximum; ok( $x->isbad, "bad flag gets set on max over an empty dim"); #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'; # provide indepdent copies of test data. sub 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" ); # provide indepdent copies of test data. sub IM { PDL->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, ] ] ); } subtest 'minmax' => sub { my @minMax = IM->minmax; ok( $minMax[0] == 1, "minmax min" ); ok( $minMax[1] == 13, "minmax max" ); }; subtest dsumover => sub { my $x = ones( byte, 3000 ); my $y; dsumover( $x, ( $y = null ) ); is( $y->get_datatype, $PDL_D, "get_datatype" ); is( $y->at, 3000, "at" ); }; subtest 'minimum_n_ind' => sub { subtest 'usage' => sub { 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 ) ), "usage 1" ); $q = minimum_n_ind( $p, 5 ); ok( tapprox( $q, pdl( 0, 6, 7, 1, 9 ) ), "usage 2" ); minimum_n_ind( $p, $q = null, 5 ); ok( tapprox( $q, pdl( 0, 6, 7, 1, 9 ) ), "usage 3" ); }; subtest 'BAD' => sub { my $p = pdl '[1 BAD 3 4 7 9 1 1 6 2 5]'; my $q = zeroes 5; minimum_n_ind $p, $q; is $q. '', '[0 6 7 9 2]', "BAD"; }; subtest 'insufficient good' => sub { my $p = pdl '[1 BAD 3 4 BAD BAD]'; my $q = zeroes 5; minimum_n_ind $p, $q; is $q. '', '[0 2 3 BAD BAD]', "insufficient good"; }; subtest 'bad & good' => sub { my $p = pdl '[1 BAD 3 4 BAD BAD 3 1 5 8 9]'; my $q = zeroes 5; minimum_n_ind $p, $q; is $q. '', '[0 7 2 6 3]', "some bad, sufficient good"; } }; done_testing; PDL-2.085/t/basic.t0000644000175000017500000001007114243274035013611 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 $a1->inplace->xvals; my $got = $a1->slice('(10),(0),(0)'); ok tapprox($got, 10), 'inplace xvals works' or diag "got:$got"; } { 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]; eval { hist ($x,15,15,0.1) }; # shouldn't segfault! isnt $@, '', 'error thrown'; 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.085/t/pdl_from_string.t0000644000175000017500000003641714146003631015726 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.085/t/slice.t0000644000175000017500000003660314556005220013633 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 = mslice($x, 0.5); ok(tapprox($y, 1), "func 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"); $y = $x->splitdim(-1,1); is_deeply [$y->dims], [3,1,3], 'splitdims negative nthdim works' or diag explain [$y->dims]; $y = $x->splitdim(1,1); is_deeply [$y->dims], [3,1,3], 'splitdims works' or diag explain [$y->dims]; $y = $x->splitdim(1,2); eval { $y->make_physdims }; like($@, qr/non-divisible/, "splitdims error non-divisible"); $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"); # Broadcast 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("") }; like $@, qr/is null/, 'null->slice exception'; 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->which->dummy(0,$pa->getndims)->make_physical; my $s = $indices->index(0); $s %= 7; is $indices.'', <slice(",,*3"); my $pnd2 = (10 *(sequence(long, 2,3 )+1))->slice(",,*2"); my $pnd3 = (100*(sequence(long, 2,3,2)+1)); my $p_nd = $pnd1->mv(-1,0)->append($pnd2->mv(-1,0))->append($pnd3->mv(-1,0))->mv(0,-1); my $pf_expect_nd = pdl(long,[3,2,1,1,0,0,0]); my $pv_expect_nd = zeroes($p_nd->type, $p_nd->dims); (my $tmp=$pv_expect_nd->slice(",,0:3")) .= $p_nd->dice_axis(-1,[0,3,5,6]); ## 9..10: test rleND(): Nd my ($pf_nd,$pv_nd) = rleND($p_nd); ok all(approx($pf_nd, $pf_expect_nd)), "rleND():Nd:counts"; ok all(approx($pv_nd, $pv_expect_nd)), "rleND():Nd:elts"; ## 11..11: test rldND(): Nd my $pd_nd = rldND($pf_nd,$pv_nd); ok all(approx($pd_nd, $p_nd)), "rldND():Nd"; ## 12..12: test enumvec(): nd my $v_nd = $p_nd->clump(2); my $k_nd = $v_nd->enumvec(); ok all(approx($k_nd, pdl(long,[0,1,2,0,1,0,0]))), "enumvec():Nd"; ## 13..17: test rldseq(), rleseq() my $lens = pdl(long,[qw(3 0 1 4 2)]); my $offs = (($lens->xvals+1)*100)->short; my $seqs = zeroes(short, 0); $seqs = $seqs->append(sequence(short,$_)) foreach ($lens->list); $seqs += $lens->rld($offs); my $seqs_got = $lens->rldseq($offs); is $seqs_got->type, $seqs->type, "rldseq():type"; ok all(approx($seqs_got, $seqs)), "rldseq():data"; my ($len_got,$off_got) = $seqs->rleseq(); is $off_got->type, $seqs->type, "rleseq():type"; ok all(approx($len_got->where($len_got), $lens->where($lens))), "rleseq():lens"; ok all(approx($off_got->where($len_got), $offs->where($lens))), "rleseq():offs"; done_testing; PDL-2.085/t/pdlchar.t0000644000175000017500000000242314223506155014146 0ustar osboxesosboxes## Test of PDL::Char subclass -- treating byte PDLs as matrices of fixed strings use Test::More; use PDL::LiteF; use PDL::Char; use strict; use warnings; { my $pa = PDL::Char->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{'' }; { my $cp = PDL::Char->new(['aa'..'af'],['ba'..'bf']); my $got = $cp->dice('X',[0],[0]); is $got.'', "[\n [ 'aa' ] \n] \n", 'can dice a P:C'; } done_testing; PDL-2.085/t/matrixops.t0000644000175000017500000002437514417053750014574 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 broadcast 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 broadcast 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"); } { my $idc = identity(zeroes(cdouble, 2, 2)); is $idc->type, 'cdouble'; } { # bug in inv for native-complex - GH#403 my $p = pdl [[ 1+i(), 0], [0, 2+2*i() ] ]; my $p_inv; lives_ok { $p_inv = $p->inv } "native-complex inv runs OK"; ok(tapprox(matmult($p,$p_inv),identity(2)), "native-complex 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 broadcasted 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])), "broadcasted determinant"); } { my $m2=pdl[[-2,-2,-2],[-1,-1,-2],[0,0,-2]]; isa_ok $m2->det, 'PDL', 'det of singular always returns ndarray'; } { ### 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"); } } { # 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"; } { squaretotri(my $x=sequence(3,3), my $y=zeroes(6)); is $y.'', "[0 3 4 6 7 8]", 'squaretotri with output arg given'; eval {squaretotri($x, zeroes(7))}; like $@, qr/dim has size 7/; $y = squaretotri($x); is $y.'', "[0 3 4 6 7 8]", 'squaretotri with no output arg given'; $y = squaretotri(sequence(3,3,2)); is $y.'', " [ [ 0 3 4 6 7 8] [ 9 12 13 15 16 17] ] ", 'squaretotri broadcasts right'; } done_testing; PDL-2.085/t/lib/0000755000175000017500000000000014556074541013121 5ustar osboxesosboxesPDL-2.085/t/lib/My/0000755000175000017500000000000014556074541013506 5ustar osboxesosboxesPDL-2.085/t/lib/My/Test/0000755000175000017500000000000014556074541014425 5ustar osboxesosboxesPDL-2.085/t/lib/My/Test/Primitive.pm0000644000175000017500000000074714547600611016734 0ustar osboxesosboxesuse strict; use warnings; use PDL::LiteF; sub tapprox { my ( $x, $y ) = @_; $_ = pdl($_) for $x, $y; if ( ( my $dims_x = join( ',', $x->dims ) ) ne ( my $dims_y = join( ',', $y->dims ) ) ) { diag "APPROX: $x $y\n"; diag "UNEQDIM: |$dims_x| |$dims_y|\n"; return 0; } return 1 if $x->isempty and $y->isempty; my $d = max( abs( $x - $y ) ); if ( $d >= 0.01 ) { diag "got=$x expected=$y\n"; } $d < 0.01; } 1; PDL-2.085/t/nat_complex.t0000644000175000017500000001350314415317170015043 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, "expected=".(-$ref->slice("0,")->squeeze + 1); 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).""; my $nan_re = qr/nan|ind/i; like $asin_2, $nan_re, 'perl scalar 2 treated as real'; $asin_2 = PDL::asin(2.0).""; like $asin_2, $nan_re, 'perl scalar 2.0 treated as real'; $asin_2 = PDL::asin(byte 2).""; like $asin_2, $nan_re, 'real byte treated as real'; $asin_2 = PDL::asin(double 2).""; like $asin_2, $nan_re, 'real double treated as real'; $asin_2 = PDL::asin(pdl 2).""; like $asin_2, $nan_re, '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.085/t/pp_croaking.t0000644000175000017500000000767714416361731015050 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: $@"); 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'; eval { pp_def( "func", Code => ';', Pars => "I(m);", ) }; like $@, qr/Invalid Pars name/; eval { pp_def( "func", Code => ';', Pars => "x(m);", OtherPars => 'int I;', ) }; like $@, qr/Invalid OtherPars name/; eval { pp_def( "func", Code => ';', Pars => "[o] a();", Inplace => ['a'], ) }; like $@, qr/is actually output/; eval { pp_def( "func", Code => ';', Pars => "a(m);", Inplace => 1, ) }; like $@, qr/Inplace does not know name of output/; eval { pp_def( "func", Code => ';', Pars => "[o] a(m);", Inplace => 1, ) }; like $@, qr/Inplace does not know name of input/; eval { pp_def( "func", Code => ';', Pars => "[o] a(m);", Inplace => ['a', 'b', 'c'], ) }; like $@, qr/Inplace array-ref/; eval { pp_def( "func", Code => ';', Pars => "a(); [o] b();", Inplace => ['a', 'b'], ) }; is $@, ''; eval { pp_def( "func", Code => ';', Pars => "a(); b();", Inplace => ['a', 'b'], ) }; like $@, qr/Inplace output arg b not \[o]/; eval { pp_def( "func", Code => ';', Pars => "a(); [o] b(m);", Inplace => ['a', 'b'], ) }; like $@, qr/Inplace args a and b different number of dims/; eval { pp_def( "func", Code => ';', Pars => "a(n); [o] b(m);", Inplace => ['a', 'b'], ) }; is $@, '', 'different but non-fixed dims OK'; eval { pp_def( "func", Code => ';', Pars => "a(n=2); [o] b(m);", Inplace => ['a', 'b'], ) }; is $@, '', 'one fixed dim OK'; eval { pp_def( "func", Code => ';', Pars => "a(n=2); [o] b(m=3);", Inplace => ['a', 'b'], ) }; like $@, qr/Inplace Pars a and b inds n=2 and m=3 not compatible/; eval { pp_def( "func", Code => ';', Pars => "a(n=2); [o] b(m=3);", OtherPars => "int x; char *y", ArgOrder => [qw(a x y)], ) }; like $@, qr/missed params/; eval { pp_def( "func", Code => ';', Pars => "a(n=2); [o] b(m=3);", OtherPars => "int x; char *y", ArgOrder => [qw(a x y b c)], ) }; like $@, qr/too many params/; eval { pp_def( "func", Code => ';', Pars => "a(n=2); [o] b(m=3);", OtherPars => "int x; char *y", ArgOrder => [qw(a x b y)], ) }; like $@, qr/optional argument/; eval { pp_def( "func", Code => ';', Pars => "a(n=2); [o] b(m=3);", OtherPars => "int x; char *y", ArgOrder => 1, ) }; is $@, '', 'non-ref true value OK'; eval { pp_def( "func", Code => ';', Pars => "a(n=2); [o] b(m=3);", OtherPars => "int x; char *y", ArgOrder => [qw(a x y b)], ) }; is $@, '', 'valid order OK'; eval { pp_def( "func", Code => ';', Pars => "a(n=2); [o] b(m=3);", GenericTypes => [qw(B INVALID)], ) }; like $@, qr/INVALID/, 'invalid GenericTypes caught'; my $got = [PDL::PP::reorder_args(my $sig = PDL::PP::Signature->new( "a(n=2); [o] b(m=3);", 1, "int x; char *y" ), {})]; is_deeply $got, [qw(a x y b)], 'right reorder no defaults' or diag explain $got; is_deeply $got = [PDL::PP::reorder_args($sig, {x=>1})], [qw(a y x b)], 'right reorder with default' or diag explain $got; is_deeply $got = [PDL::PP::reorder_args($sig = PDL::PP::Signature->new( "a(n=2); [o] b(m=3);", 1, "[o] int x; char *y; double z" ), {})], [qw(a y z b x)], 'right reorder, output other, no defaults' or diag explain $got; is_deeply $got = [PDL::PP::reorder_args($sig, {y=>'""'})], [qw(a z y b x)], 'right reorder, output other, with default' or diag explain $got; done_testing; PDL-2.085/t/subclass.t0000644000175000017500000002664114422363203014354 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) ) ; is ref($z), "PDL::Derived3", "create derived instance"; #### Check the type after incrementing: $z++; is ref($z), "PDL::Derived3", "check type after incrementing"; #### Check the type after performing sumover: my $y = $z->sumover; is ref($y), "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; local $SIG{__WARN__} = sub { push @w, @_ }; my $w = $x + $z; is ref($w), "PDL::Derived3", "check type after adding"; is "@w", '', 'no warnings'; } #### Check the type after calling null: my $a1 = PDL::Derived3->null(); is ref($a1), "PDL::Derived3", "check type after calling null"; ##### Check the type for a biops2 operation: my $w = ($x == $z); is ref($w), "PDL::Derived3", "check type for biops2 operation"; ##### Check the type for a biops3 operation: $w = ($x | $z); is ref($w), "PDL::Derived3", "check type for biops3 operation"; ##### Check the type for a ufuncs1 operation: $w = sqrt($z); is ref($w), "PDL::Derived3", "check type for ufuncs1 operation"; ##### Check the type for a ufuncs1f operation: $w = sin($z); is ref($w), "PDL::Derived3", "check type for ufuncs1f operation"; ##### Check the type for a ufuncs2 operation: $w = ! $z; is ref($w), "PDL::Derived3", "check type for ufuncs2 operation"; ##### Check the type for a ufuncs2f operation: $w = log $z; is ref($w), "PDL::Derived3", "check type for ufuncs2f operation"; ##### Check the type for a bifuncs operation: $w = $z**2; is ref($w), "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'); is ref($w), "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]; return $class->SUPER::new($data) if ref($data) ne 'PDL'; # if not object, inherited constructor my $self = $class->initialize; $self->{PDL} = $data; return $self; } ####### Initialize function. This over-ridden function is called by the PDL constructors sub initialize { $::INIT_CALLED = 1; 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 { $::COPY_CALLED = 1; 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; $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; $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; $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; $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,] ]); { my @w; local $SIG{__WARN__} = sub { push @w, @_ }; # Check for PDL::sumover being called by sum is $im->sum, 176, "PDL::sumover is called by sum"; # result will be = 134 if derived sumover # is not called, 176 if it is called. is "@w", '', 'no warnings'; } ### Test over-ride of minmaximum: $main::OVERRIDEWORKED = 0; my @minMax = $im->minmax; is $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); is $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); ($x, $y, $z, $w) = whichND($a1 == 203)->mv(0,-1)->dog; is $main::OVERRIDEWORKED, 1, "whichND worked"; # whitebox test condition, uugh! # Check to see if the clip functions return a derived object: is ref( $im->clip(5,7) ), "PDL::Derived4", "clip returns derived object"; is ref( $im->hclip(5) ), "PDL::Derived4", "hclip returns derived object"; is ref( $im->lclip(5) ), "PDL::Derived4", "lclip returns derived object"; $::COPY_CALLED = $::INIT_CALLED = 0; my $im2 = $im + 1; ok !$::COPY_CALLED, 'no copy'; ok $::INIT_CALLED, 'yes init'; $::COPY_CALLED = $::INIT_CALLED = 0; $im++; ok !$::COPY_CALLED, 'no copy'; ok !$::INIT_CALLED, 'no init'; ########### 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(); is $w->{someThingElse}, 24, "$op subclassed object correctly"; } done_testing; PDL-2.085/t/autoload.t0000644000175000017500000000162014202424257014336 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.085/t/core.t0000644000175000017500000004355214556074307013501 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 $p = sequence(100); # big enough to not fit in "value" field my $ref = $p->get_dataref; $p->reshape(3); # small enough now $p->upd_data; } for (@PDL::Core::EXPORT_OK) { next if $_ eq 'mslice'; # bizarrely, this is callable but not "defined" no strict 'refs'; ok defined &{"PDL::Core::$_"}, "PDL::Core-exported $_ exists"; } is sequence(3,2)->dup(0, 2).'', ' [ [0 1 2 0 1 2] [3 4 5 3 4 5] ] ', 'dup'; is sequence(3,2)->dupN(2, 3).'', ' [ [0 1 2 0 1 2] [3 4 5 3 4 5] [0 1 2 0 1 2] [3 4 5 3 4 5] [0 1 2 0 1 2] [3 4 5 3 4 5] ] ', 'dupN'; is sequence(3,2)->inflateN(2, 3).'', ' [ [0 0 1 1 2 2] [0 0 1 1 2 2] [0 0 1 1 2 2] [3 3 4 4 5 5] [3 3 4 4 5 5] [3 3 4 4 5 5] ] ', 'inflateN'; 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)"; eval { zeroes(0)->max ? 1 : 0 }; like $@, qr/bad.*conditional/, 'badvalue as boolean is error'; # 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)"; eval { my $y = zeroes(1,3); $y .= sequence(2,3); }; isnt $@, '', 'scaling-up of output dim 1 throws error'; eval { my $y = zeroes(1); $y .= zeroes(0) + 1; }; isnt $@, '', 'scaling-down of output dim 1 throws error'; # test reshape with no args my $x = ones 3,1,4; my $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); my $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); ok $x->isnull, 'pdl(null) gives 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);}; is($@, '', "zeroes accepts empty PDL specification"); eval { $y = pdl($x,sequence(2,0,1)); }; is $@, ''; ok all(pdl($y->dims) == pdl(2,0,1,2)), "concatenating two empties gives an empty"; eval { $y = pdl($x,sequence(2,1,1)); }; is $@, ''; ok 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) }; is $@, ''; ok all(pdl($y->dims)==pdl(2,1,1,2)), "concatenating an empty and a scalar on the right works"; eval { $y = pdl(5,$x) }; is $@, ''; ok 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"); # cat problems eval {cat(1, pdl(1,2,3), {}, 6)}; isnt($@, '', '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))}; isnt($@, '', '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))}; isnt($@, '', '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));}; is($@, '', 'cat(pdl(1),pdl(2,3)) succeeds'); is_deeply [$x->dims], [2,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=sequence(float,5)+float(0.2); # 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 = empty(); is $empty->type->enum, 0, 'empty() gives lowest-numbered type'; is empty(float)->type, 'float', 'empty(float) works'; 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"); eval { $null->long }; like $@, qr/null/, 'null->long gives right error'; $x = short pdl(3,4,5,6); eval { $x->reshape(2,2);}; is($@, '', "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.085/t/00-report-prereqs.t0000644000175000017500000001347614547551550015762 0ustar osboxesosboxesuse 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.085/t/primitive-matmult.t0000644000175000017500000000375014547612401016227 0ustar osboxesosboxesuse strict; use warnings; use Test::More; use Test::Exception; use PDL::LiteF; use lib 't/lib'; use My::Test::Primitive; # provide independent copies of test data. sub IM { PDL->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, ] ] ); } ok( ( IM() x IM() )->sum == 3429, "matrix multiplication" ); subtest 'complex' => sub { # complex matmult my $cm1 = pdl('1 1+i 1'); my $cm2 = pdl('2 3 i')->transpose; ok tapprox( $cm1 x $cm2, pdl('[[5+4i]]') ), 'complex matmult'; throws_ok { scalar $cm1->transpose x $cm2 } qr/mismatch/, 'good error on mismatch matmult'; }; sub PA { pdl [ [ 1, 2, 3, 0 ], [ 1, -1, 2, 7 ], [ 1, 0, 0, 1 ] ] } sub PB { pdl [ [ 1, 1 ], [ 0, 2 ], [ 0, 2 ], [ 1, 1 ] ] } sub PC { pdl [ [ 1, 11 ], [ 8, 10 ], [ 2, 2 ] ] } sub EQ { float [ [ 1, 1, 1, 1 ] ] } subtest 'test fiducials: 3x4 x 4x2' => sub { ok tapprox( PA() x PB(), PC() ); matmult( PA, PB, my $res = null ); ok tapprox( $res, PC ), 'res=null'; }; subtest 'sliced input' => sub { my $pa_sliced = PA->dummy( 0, 3 )->dummy( -1, 3 )->make_physical->slice('(1),,,(1)'); ok tapprox( PC, $pa_sliced x PB ); }; subtest 'output = zeroes(2,3)' => sub { my $res = zeroes( 2, 3 ); matmult( PA, PB, $res ); ok tapprox( PC, $res ), 'res=zeroes'; }; subtest 'output = ones(2,3)' => sub { my $res = ones( 2, 3 ); matmult( PA, PB, $res ); ok tapprox( PC, $res ), 'res=ones'; }; # Check collapse: output should be a 1x2... ok tapprox( EQ() x PB(), pdl( [ [ 2, 6 ] ] ) ), '([4x1] x [2x4] -> [1x2])'; # Check dimensional exception: mismatched dims should throw an error throws_ok { PB() x EQ(); } qr/mismatch in matmult/, '[2x4] x [4x1] --> error (2 != 1)'; ok tapprox( PB() x 2, PB() * 2, 'ndarray x Perl scalar' ); ok tapprox( pdl(3) x PB(), PB() *3 ), '1D ndarray x ndarray'; done_testing; PDL-2.085/t/bool.t0000644000175000017500000000113314146003631013454 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.085/t/ops.t0000644000175000017500000002204014555765265013350 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.*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.*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'); } { my @w; local $SIG{__WARN__} = sub { push @w, @_ }; # 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'); is_deeply \@w, [], 'no warnings' or diag explain \@w; } { # atan2 ok (all( approx(atan2(pdl(1,1), pdl(1,1)), ones(2) * atan2(1,1))), 'atan2'); ok (all( approx(PDL::atan2(pdl(1,1), pdl(1,1)), ones(2) * PDL::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'); $pa .= 1; eval {(my $tmp = $pa->inplace) += 1}; is $@, '', 'inplace += worked'; is $pa.'', 2, 'inplace += right value after'; } { # 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'); } #### 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' if $Config{ivsize} >= 8; 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 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", 12) 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"; # 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"; #and for big numbers (bigger than INT_MAX=2147483647) my $INT_MAX = 2147483647; 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"; cmp_ok ulonglong($INT_MAX*4)%2, '==', 0, "big ulonglong 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"; my $u = pdl(ulonglong, [0,1]); my $compl = ~$u; is "$compl", '[18446744073709551615 18446744073709551614]', 'ULL get stringified right'; } is(~pdl(1,2,3) ."", '[-2 -3 -4]', 'bitwise negation'); is((pdl(1,2,3) ^ pdl(4,5,6))."", '[5 7 5]' , 'bitwise xor' ); { my $startgood = sequence(10); my $hasbad = sequence(5); $hasbad->inplace->setvaltobad(3); $startgood->slice('0:4') .= $hasbad; ok $startgood->badflag, 'startgood badflag now true'; ok $startgood->nbad == 1, 'badflag propagation with .='; } is_deeply [(zeroes(1,1,0) & zeroes(1,1,0))->dims], [1,1,0]; # used to segfault done_testing; PDL-2.085/t/constructor.t0000644000175000017500000001622614404760251015124 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.*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" ); is( $y->slice("(1),(0)").'', 'BAD', "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"; is( $y->slice("(1),(0)").'', 'BAD', "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.085/m51.fits0000644000175000017500000220660013460433355013402 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.085/utils/0000755000175000017500000000000014556074541013250 5ustar osboxesosboxesPDL-2.085/utils/perldlpp.pl0000755000175000017500000000262714202424257015430 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.085/win32/0000755000175000017500000000000014556074541013052 5ustar osboxesosboxesPDL-2.085/win32/INSTALL0000644000175000017500000001231314014062163014065 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.085/win32/win32f77.pl0000644000175000017500000000542013265417442014673 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.085/PDLdb.pl0000644000175000017500000115511014202424257013365 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.085/Doc/0000755000175000017500000000000014556074541012615 5ustar osboxesosboxesPDL-2.085/Doc/scantree.pl0000644000175000017500000000452614411721551014753 0ustar osboxesosboxesuse strict; use warnings; use PDL::Doc; use Getopt::Std; use Config; use Cwd; require PDL; # always needed to pick up PDL::VERSION our $opt_v = 0; getopts('v'); my $dirarg = shift @ARGV; my $outdb = shift @ARGV; my $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"; } unlink $outdb if -e $outdb; my $onldc = PDL::Doc->new; $onldc->outfile($outdb); foreach my $dir (@dirs) { $onldc->scantree($dir."/PDL",$opt_v); $onldc->scan($dir."/PDL.pm",$opt_v) if (-s $dir."/PDL.pm"); } print STDERR "saving...\n"; $onldc->savedb(); my @mods = $onldc->search('module:',['Ref'],1); my @mans = $onldc->search('manual:',['Ref'],1); my @scripts = $onldc->search('script:',['Ref'],1); my $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.085/Doc/Doc.pm0000644000175000017500000007032714411725036013661 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; 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|CONSTRUCTORS|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') { return $this->SUPER::command($cmd,$txt,$line_num,$pod_para) if $txt =~ /^The\s/; # heuristic to deal with GSL::CDF descriptive =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}; die "no function defined\n" 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 = PDL::Doc->new($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 users to remind themselves of names, calling conventions and typical usage of the multitude of functions at their 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 they 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 automatically 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 strict; use warnings; use PDL::Core ''; use File::Basename; use PDL::Doc::Config; use File::Spec::Functions qw(file_name_is_absolute abs2rel rel2abs catdir catfile); use Cwd (); # to help Debian packaging =head1 INSTANCE METHODS =head2 new $onlinedc = PDL::Doc->new('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 my $fh, $fi or barf "can't open database $fi, scan docs first"; binmode $fh; my ($plen,$txt); while (read $fh, $plen,2) { my ($len) = unpack "S", $plen; read $fh, $txt, $len; my ($sym, $module, @a) = split chr(0), $txt; push @a, "" if @a % 2; # Add null string at end if necessary -- solves bug with missing REF section. $this->{SYMS}{$sym}{$module} = { @a, Dbfile => $fi }; # keep the origin pdldoc.db path } 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}; $val->{File} = abs2rel($fi, dirname($this->{Outfile})) #store paths to *.pm files relative to pdldoc.db if file_name_is_absolute($fi) && -f $fi; 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). To see what it has stored in it in JSON format: perl -MPDL::Doc -MJSON::PP -e \ 'print encode_json +PDL::Doc->new(PDL::Doc::_find_inc([qw(PDL pdldoc.db)]))->gethash' | json_pp -json_opt pretty,canonical 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 { $_[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 = PDL::PodParser->new; $parser->{verbose} = $verbose; eval { $parser->parse_from_filehandle($infile,$outfile) }; warn "cannot parse '$file' ($@)" if $@ and $@ ne "no function defined\n"; my $hash = $this->{SYMS} ||= {}; my $n = 0; $_->{File} = $file2, $n++ for values %{ $parser->{SYMHASH} }; while (my ($key,$val) = each %{ $parser->{SYMHASH} }) { #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 = PDL::PodParser->new; $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 { return if $File::Find::name !~ /\.(?:pm|pod)$/; return if $File::Find::name =~ /(?:Index\.pod|PP\.pm)$/ or $File::Find::dir =~ m#/PP#; printf "%-20s", $_.'...'; $ntot += my $n = $this->scan($File::Find::name,$verbose); print "\t$n functions\n"; }; File::Find::find($sub,$dir); print "\nfound $ntot functions\n"; $ntot; } =head2 funcdocs extract the complete documentation about a function from its source file using the PDL::PodParser 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}; $file = Cwd::abs_path($file) if file_name_is_absolute($file); $dbf = Cwd::abs_path($dbf); # help Debian packaging $file = rel2abs($file, dirname($dbf)) if !file_name_is_absolute($file) && $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("PDL::Stats"); # add PDL::Stats, PDL::Stats::GLM, ... =for ref The C function allows you to add POD from a particular Perl module (and as of PDL 2.083, in fact all modules starting with that as a prefix) that you've installed somewhere in C<@INC>. It searches for the active PDL document database and the module's .pod and .pm files, and scans and indexes the module(s) into the database. C is meant to be added to your module's Makefile as part of the installation script. This is done automatically by L, but if the top level of your distribution is Perl modules (like L), then add a C manually in the F: use PDL::Core::Dev; sub MY::postamble { my $oneliner = PDL::Core::Dev::_oneliner(qq{exit if \$ENV{DESTDIR}; use PDL::Doc; eval { PDL::Doc::add_module(shift); }}); qq|\ninstall :: pure_install\n\t$oneliner \$(NAME)\n|; } =cut sub _find_inc { my ($what, $want_dir) = @_; my @ret; for my $dir (@INC) { my $ent = $want_dir ? catdir($dir, @$what) : catfile($dir, @$what); push @ret, $ent if $want_dir ? -d $ent : -f $ent; } @ret; } sub add_module { my ($module) = @_; my ($file) = _find_inc([qw(PDL pdldoc.db)], 0); die "Unable to find docs database - therefore not updating it.\n" if !defined $file; die "No write permission for $file - not updating docs database.\n" if !-w $file; print "Found docs database $file\n"; my $pdldoc = PDL::Doc->new($file); my @pkg = my @mfile = split /::/, $module; my $mlast = pop @mfile; my @found = map _find_inc([@mfile, $mlast.$_]), qw(.pm .pod); die "Unable to find a .pm or .pod file in \@INC for module $module\n" if !@found; $pdldoc->ensuredb; my $n = 0; $n += $pdldoc->scan($_) for @found; print "Added @found, $n functions.\n"; $n += $pdldoc->scantree($_) for _find_inc(\@pkg, 1); eval { $pdldoc->savedb; }; warn $@ if $@; print "PDL docs database updated - total $n functions.\n"; } =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 ($file) = _find_inc([qw(PDL pdldoc.db)], 0); die "Unable to find docs database!\n" unless defined $file; print "Found docs database $file\n"; my $pdldoc = PDL::Doc->new($file); # 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 map "$_->[0]\n", @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/broadcasting 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.085/Doc/mkpdlfuncpod0000644000175000017500000000432014410227460015212 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 = StrHandle->new; 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.085/Doc/Doc/0000755000175000017500000000000014556074541013322 5ustar osboxesosboxesPDL-2.085/Doc/Doc/Perldl.pm0000644000175000017500000004517414411716160015103 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 use Cwd; # to help Debian packaging $PDL::onlinedoc = PDL::Doc->new(FindStdFile()); # Find std file sub FindStdFile { my ($f) = PDL::Doc::_find_inc([qw(PDL pdldoc.db)], 0); warn("Unable to find PDL/pdldoc.db in ".join(":",@INC)."\n"), return if !defined $f; print "Found docs database $f\n" if $PDL::verbose; print "Type 'help' for online help\n" if $PDL::verbose; return $f; } # 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 = Pod::PlainText->new( 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 && $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 = Cwd::abs_path($dbf); # help Debian packaging $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 broadcasting. See L and 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 { 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]); } 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 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.085/Doc/Doc/Config.pm.PL0000644000175000017500000000253114146003631015363 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.085/Doc/README0000644000175000017500000000576213265417442013504 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.085/Doc/Makefile.PL0000644000175000017500000000207214146003631014553 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.085/GENERATED/0000755000175000017500000000000014556074541013406 5ustar osboxesosboxesPDL-2.085/GENERATED/PDL/0000755000175000017500000000000014556074562014030 5ustar osboxesosboxesPDL-2.085/GENERATED/PDL/Fit/0000755000175000017500000000000014556074552014551 5ustar osboxesosboxesPDL-2.085/GENERATED/PDL/Fit/Gaussian.pm0000644000175000017500000000751314556074552016667 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 4 "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 123 "Gaussian.pm" *fitgauss1d = \&PDL::fitgauss1d; *fitgauss1dr = \&PDL::fitgauss1dr; #line 191 "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 153 "Gaussian.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/Image2D.pm0000644000175000017500000010603014556074561015575 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 crop cc8compt cc4compt ccNcompt polyfill pnpoly polyfillv rotnewsz rot2d bilin2d rescale2d fitwarp2d applywarp2d warp2d 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; my %boundary2value = (Reflect=>1, Truncate=>2, Replicate=>3); #line 51 "Image2D.pm" =head1 FUNCTIONS =cut =head2 conv2d =for sig Signature: (a(m,n); kern(p,q); [o]b(m,n); indx [t]mapi(isize); indx [t]mapj(jsize); int opt) =for ref 2D convolution of an array with a kernel (smoothing) For large kernels, using a FFT routine, such as L, 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 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, (!($opt && exists $$opt{Boundary}))?0:$boundary2value{$$opt{Boundary}} ); return $c; } *conv2d = \&PDL::conv2d; =head2 med2d =for sig Signature: (a(m,n); kern(p,q); [o]b(m,n); double+ [t]tmp(pq); indx [t]mapi(isize); indx [t]mapj(jsize); 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 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, (!($opt && exists $$opt{Boundary}))?0:$boundary2value{$$opt{Boundary}} ); return $c; } *med2d = \&PDL::med2d; =head2 med2df =for sig Signature: (a(m,n); [o]b(m,n); indx [t]mapi(isize); indx [t]mapj(jsize); int p_size=>p; int q_size=>q; 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 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, (!($opt && exists $$opt{Boundary}))?0:$boundary2value{$$opt{Boundary}} ); return $c; } *med2df = \&PDL::med2df; =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 *box2d = \&PDL::box2d; =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 *patch2d = \&PDL::patch2d; =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 *patchbad2d = \&PDL::patchbad2d; =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 Jenness =for bad Bad values are excluded from the search. If all pixels are bad then the output is set bad. =cut *max2d_ind = \&PDL::max2d_ind; =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 *centroid2d = \&PDL::centroid2d; #line 798 "image2d.pd" =head2 crop =for ref Return bounding box of given mask in an C ndarray, so it can broadcast. Use other operations (such as L, or L with a colour vector) to create a mask suitable for your application. =for example $x1x2y1y2 = crop($image); =cut *crop = \&PDL::crop; sub PDL::crop { my ($mask) = @_; $mask->xchg(0,1)->orover->_which_int(my $out = null, null); $out->badflag(1); $out->badvalue(-1); my ($x1, $x2) = $out->minmaximum; $mask->orover->_which_int($out = null, null); $out->badflag(1); $out->badvalue(-1); my ($y1, $y2) = $out->minmaximum; $x1->cat($x2, $y1, $y2)->mv(-1,0); } #line 828 "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 508 "Image2D.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 *ccNcompt = \&PDL::ccNcompt; #line 997 "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 1054 "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 1137 "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 735 "Image2D.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 *rot2d = \&PDL::rot2d; =head2 bilin2d =for sig Signature: (Int(n,m); [io] 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 *bilin2d = \&PDL::bilin2d; =head2 rescale2d =for sig Signature: (Int(m,n); [io] 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 *rescale2d = \&PDL::rescale2d; #line 1442 "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 1271 "Image2D.pm" =head2 warp2d =for sig Signature: (img(m,n); ldouble px(np,np); ldouble py(np,np); [o] warp(m,n); ldouble [t] poly(np); ldouble [t] kernel(ns); char *kernel_type; double noval; int nsamples => ns) =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. =for bad warp2d 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 # 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; } } 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}, _get_kernel_size() ); return $out; } *warp2d = \&PDL::warp2d; =head2 warp2d_kernel =for sig Signature: ([o] x(n); [o] k(n); ldouble [t] kernel(n); char *name; PDL_Indx nsize => n) =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" ); =for bad warp2d_kernel 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 sub PDL::warp2d_kernel ($) { my $kernel = _check_kernel( shift, "warp2d_kernel" ); &PDL::_warp2d_kernel_int( my $x=PDL->null, my $k=PDL->null, $kernel, _get_kernel_size() ); return ( $x, $k ); } *warp2d_kernel = \&PDL::warp2d_kernel; #line 31 "image2d.pd" =head1 AUTHORS Copyright (C) Karl Glazebrook 1997 with additions by Robin Williams (rjrw@ast.leeds.ac.uk), Tim Jenness (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 1499 "Image2D.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/FFT.pm0000644000175000017500000002343614556074552015014 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 6 "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 103 "FFT.pm" =head1 FUNCTIONS =cut =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 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; } } *fft = \&PDL::fft; =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 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; } } *ifft = \&PDL::ifft; #line 185 "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 388 "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 462 "FFT.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GIS/0000755000175000017500000000000014556074552014451 5ustar osboxesosboxesPDL-2.085/GENERATED/PDL/GIS/Proj.pm0000644000175000017500000001202014556074552015714 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 ; BEGIN { use Alien::proj; if ($^O =~ /MSWin32/ and $Alien::proj::VERSION le '1.25') { $ENV{PATH} = join ';', (Alien::proj->bin_dirs, $ENV{PATH}); } } #line 26 "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 45 "Proj.pm" =head1 FUNCTIONS =cut #line 71 "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 73 "Proj.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 *fwd_transform = \&PDL::fwd_transform; =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 *inv_transform = \&PDL::inv_transform; #line 220 "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 39 "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 222 "Proj.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/Bad.pm0000644000175000017500000004221314556074542015054 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 badmask 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 19 "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 66 "Bad.pm" =head1 FUNCTIONS =cut #line 62 "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 79 "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 an ndarray 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 an ndarray with the original bad value for the associated type. =head2 check_badflag =for ref Clear the badflag 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 badflag. =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 badflag. =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 288 "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::Bad::_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::Bad::_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::Bad::_default_badvalue_int($num); } ############################################################ ############################################################ #line 273 "Bad.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 *isbad = \&PDL::isbad; =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 *isgood = \&PDL::isgood; =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 *nbadover = \&PDL::nbadover; =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 *ngoodover = \&PDL::ngoodover; #line 512 "bad.pd" *nbad = \&PDL::nbad; sub PDL::nbad { my($x) = @_; my $tmp; $x->clump(-1)->nbadover($tmp=PDL->nullcreate($x) ); return $tmp; } #line 512 "bad.pd" *ngood = \&PDL::ngood; sub PDL::ngood { my($x) = @_; my $tmp; $x->clump(-1)->ngoodover($tmp=PDL->nullcreate($x) ); return $tmp; } #line 524 "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 an ndarray and 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 an ndarray and 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 532 "Bad.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 *setbadif = \&PDL::setbadif; =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 *setvaltobad = \&PDL::setvaltobad; =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 *setnantobad = \&PDL::setnantobad; =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 *setinftobad = \&PDL::setinftobad; =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 *setnonfinitetobad = \&PDL::setnonfinitetobad; =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 *setbadtonan = \&PDL::setbadtonan; =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 *setbadtoval = \&PDL::setbadtoval; =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 *badmask = \&PDL::badmask; =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 *copybad = \&PDL::copybad; =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 *locf = \&PDL::locf; #line 1070 "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 936 "Bad.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/ImageND.pm0000644000175000017500000003666514556074561015651 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 4 "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 broadcasted 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 53 "ImageND.pm" =head1 FUNCTIONS =cut #line 95 "imagend.pd" use Carp; #line 66 "ImageND.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 # 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; } *convolve = \&PDL::convolve; #line 225 "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 173 "ImageND.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 # 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)->dupN($r); } 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; } } *rebin = \&PDL::rebin; #line 378 "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 454 "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 399 "ImageND.pm" =head2 convolveND =for sig Signature: (k0(); pdl *k; pdl *aa; pdl *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 broadcasted 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 broadcast over kernels. That could/should be fixed. The broadcasting 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 broadcastloop. The direct copying code uses PP primarily for the generic typing: it includes its own broadcastloops. =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 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 = PDL::Options->new( { 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 broadcast 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; } *convolveND = \&PDL::convolveND; #line 34 "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 626 "ImageND.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/Transform/0000755000175000017500000000000014556074562016003 5ustar osboxesosboxesPDL-2.085/GENERATED/PDL/Transform/Proj4.pm0000644000175000017500000113205714556074562017350 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::Transform::Proj4; our @EXPORT_OK = qw(t_proj t_proj_adams_hemi t_proj_adams_ws1 t_proj_adams_ws2 t_proj_aea t_proj_aeqd t_proj_affine t_proj_airy t_proj_aitoff t_proj_alsk t_proj_apian t_proj_august t_proj_axisswap t_proj_bacon t_proj_bertin1953 t_proj_bipc t_proj_boggs t_proj_bonne t_proj_calcofi t_proj_cart t_proj_cass t_proj_cc t_proj_ccon t_proj_cea t_proj_chamb t_proj_col_urban t_proj_collg t_proj_comill t_proj_crast t_proj_defmodel t_proj_deformation t_proj_denoy t_proj_eck1 t_proj_eck2 t_proj_eck3 t_proj_eck4 t_proj_eck5 t_proj_eck6 t_proj_eqc t_proj_eqdc t_proj_eqearth t_proj_etmerc t_proj_euler t_proj_fahey t_proj_fouc t_proj_fouc_s t_proj_gall t_proj_geoc t_proj_geocent t_proj_geogoffset t_proj_geos t_proj_gins8 t_proj_gn_sinu t_proj_gnom t_proj_goode t_proj_gs48 t_proj_gs50 t_proj_gstmerc t_proj_guyou t_proj_hammer t_proj_hatano t_proj_healpix t_proj_helmert t_proj_hgridshift t_proj_horner t_proj_igh t_proj_igh_o t_proj_imw_p t_proj_isea t_proj_kav5 t_proj_kav7 t_proj_krovak t_proj_labrd t_proj_laea t_proj_lagrng t_proj_larr t_proj_lask t_proj_latlon t_proj_latlong t_proj_lcc t_proj_lcca t_proj_leac t_proj_lee_os t_proj_longlat t_proj_lonlat t_proj_loxim t_proj_lsat t_proj_mbt_fps t_proj_mbt_s t_proj_mbtfpp t_proj_mbtfpq t_proj_mbtfps t_proj_merc t_proj_mil_os t_proj_mill t_proj_misrsom t_proj_moll t_proj_molobadekas t_proj_molodensky t_proj_murd1 t_proj_murd2 t_proj_murd3 t_proj_natearth t_proj_natearth2 t_proj_nell t_proj_nell_h t_proj_nicol t_proj_noop t_proj_nsper t_proj_nzmg t_proj_ob_tran t_proj_ocea t_proj_oea t_proj_omerc t_proj_ortel t_proj_ortho t_proj_patterson t_proj_pconic t_proj_peirce_q t_proj_pipeline t_proj_poly t_proj_pop t_proj_push t_proj_putp1 t_proj_putp2 t_proj_putp3 t_proj_putp3p t_proj_putp4p t_proj_putp5 t_proj_putp5p t_proj_putp6 t_proj_putp6p t_proj_qsc t_proj_qua_aut t_proj_rhealpix t_proj_robin t_proj_rouss t_proj_rpoly t_proj_s2 t_proj_sch t_proj_set t_proj_sinu t_proj_somerc t_proj_stere t_proj_sterea t_proj_tcc t_proj_tcea t_proj_times t_proj_tinshift t_proj_tissot t_proj_tmerc t_proj_tobmerc t_proj_topocentric t_proj_tpeqd t_proj_tpers t_proj_unitconvert t_proj_ups t_proj_urm5 t_proj_urmfps t_proj_utm t_proj_vandg t_proj_vandg2 t_proj_vandg3 t_proj_vandg4 t_proj_vgridshift t_proj_vitk1 t_proj_wag1 t_proj_wag2 t_proj_wag3 t_proj_wag4 t_proj_wag5 t_proj_wag6 t_proj_wag7 t_proj_webmerc t_proj_weren t_proj_wink1 t_proj_wink2 t_proj_wintri t_proj_xyzgridshift _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 27 "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 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 353 "Proj4.pd" =head1 FUNCTIONS =head2 t_proj This is the main entry point for the generalized interface. See above on its usage. =cut #line 451 "Proj4.pd" =head2 t_proj_adams_hemi Autogenerated transformation function for Proj4 projection code adams_hemi. The full name for this projection is Adams Hemisphere in a Square. =cut sub t_proj_adams_hemi { 'PDL::Transform::Proj4::adams_hemi'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_adams_ws1 Autogenerated transformation function for Proj4 projection code adams_ws1. The full name for this projection is Adams World in a Square I. =cut sub t_proj_adams_ws1 { 'PDL::Transform::Proj4::adams_ws1'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_adams_ws2 Autogenerated transformation function for Proj4 projection code adams_ws2. The full name for this projection is Adams World in a Square II. =cut sub t_proj_adams_ws2 { 'PDL::Transform::Proj4::adams_ws2'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_aea Autogenerated transformation function for Proj4 projection code aea. The full name for this projection is Albers Equal Area. Projection Parameters =for options =over 4 =item lat_1 =item lat_2 =back =cut sub t_proj_aea { 'PDL::Transform::Proj4::aea'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_aeqd Autogenerated transformation function for Proj4 projection code aeqd. The full name for this projection is Azimuthal Equidistant. Projection Parameters =for options =over 4 =item guam =item lat_0 =back =cut sub t_proj_aeqd { 'PDL::Transform::Proj4::aeqd'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_affine Autogenerated transformation function for Proj4 projection code affine. The full name for this projection is Affine transformation. =cut sub t_proj_affine { 'PDL::Transform::Proj4::affine'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_airy Autogenerated transformation function for Proj4 projection code airy. The full name for this projection is Airy. Projection Parameters =for options =over 4 =item lat_b =item no_cut =back =cut sub t_proj_airy { 'PDL::Transform::Proj4::airy'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_aitoff Autogenerated transformation function for Proj4 projection code aitoff. The full name for this projection is Aitoff. =cut sub t_proj_aitoff { 'PDL::Transform::Proj4::aitoff'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_alsk Autogenerated transformation function for Proj4 projection code alsk. The full name for this projection is Modified Stereographic of Alaska. =cut sub t_proj_alsk { 'PDL::Transform::Proj4::alsk'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_apian Autogenerated transformation function for Proj4 projection code apian. The full name for this projection is Apian Globular I. =cut sub t_proj_apian { 'PDL::Transform::Proj4::apian'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_august Autogenerated transformation function for Proj4 projection code august. The full name for this projection is August Epicycloidal. =cut sub t_proj_august { 'PDL::Transform::Proj4::august'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_axisswap Autogenerated transformation function for Proj4 projection code axisswap. The full name for this projection is Axis ordering. =cut sub t_proj_axisswap { 'PDL::Transform::Proj4::axisswap'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_bacon Autogenerated transformation function for Proj4 projection code bacon. The full name for this projection is Bacon Globular. =cut sub t_proj_bacon { 'PDL::Transform::Proj4::bacon'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_bertin1953 Autogenerated transformation function for Proj4 projection code bertin1953. The full name for this projection is Bertin 1953. =cut sub t_proj_bertin1953 { 'PDL::Transform::Proj4::bertin1953'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_bipc Autogenerated transformation function for Proj4 projection code bipc. The full name for this projection is Bipolar conic of western hemisphere. =cut sub t_proj_bipc { 'PDL::Transform::Proj4::bipc'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_boggs Autogenerated transformation function for Proj4 projection code boggs. The full name for this projection is Boggs Eumorphic. =cut sub t_proj_boggs { 'PDL::Transform::Proj4::boggs'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_bonne Autogenerated transformation function for Proj4 projection code bonne. The full name for this projection is Bonne (Werner lat_1=90). Projection Parameters =for options =over 4 =item lat_1 =back =cut sub t_proj_bonne { 'PDL::Transform::Proj4::bonne'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_calcofi Autogenerated transformation function for Proj4 projection code calcofi. The full name for this projection is Cal Coop Ocean Fish Invest Lines/Stations. =cut sub t_proj_calcofi { 'PDL::Transform::Proj4::calcofi'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_cart Autogenerated transformation function for Proj4 projection code cart. The full name for this projection is Geodetic/cartesian conversions. =cut sub t_proj_cart { 'PDL::Transform::Proj4::cart'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_cass Autogenerated transformation function for Proj4 projection code cass. The full name for this projection is Cassini. =cut sub t_proj_cass { 'PDL::Transform::Proj4::cass'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_cc Autogenerated transformation function for Proj4 projection code cc. The full name for this projection is Central Cylindrical. =cut sub t_proj_cc { 'PDL::Transform::Proj4::cc'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_ccon Autogenerated transformation function for Proj4 projection code ccon. The full name for this projection is Central Conic. Projection Parameters =for options =over 4 =item lat_1 =back =cut sub t_proj_ccon { 'PDL::Transform::Proj4::ccon'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_cea Autogenerated transformation function for Proj4 projection code cea. The full name for this projection is Equal Area Cylindrical. Projection Parameters =for options =over 4 =item lat_ts =back =cut sub t_proj_cea { 'PDL::Transform::Proj4::cea'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_chamb Autogenerated transformation function for Proj4 projection code chamb. The full name for this projection is Chamberlin Trimetric. Projection Parameters =for options =over 4 =item lat_1 =item lat_2 =item lat_3 =item lon_1 =item lon_2 =item lon_3 =back =cut sub t_proj_chamb { 'PDL::Transform::Proj4::chamb'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_col_urban Autogenerated transformation function for Proj4 projection code col_urban. The full name for this projection is Colombia Urban. Projection Parameters =for options =over 4 =item h_0 =back =cut sub t_proj_col_urban { 'PDL::Transform::Proj4::col_urban'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_collg Autogenerated transformation function for Proj4 projection code collg. The full name for this projection is Collignon. =cut sub t_proj_collg { 'PDL::Transform::Proj4::collg'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_comill Autogenerated transformation function for Proj4 projection code comill. The full name for this projection is Compact Miller. =cut sub t_proj_comill { 'PDL::Transform::Proj4::comill'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_crast Autogenerated transformation function for Proj4 projection code crast. The full name for this projection is Craster Parabolic (Putnins P4). =cut sub t_proj_crast { 'PDL::Transform::Proj4::crast'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_defmodel Autogenerated transformation function for Proj4 projection code defmodel. The full name for this projection is Deformation model. =cut sub t_proj_defmodel { 'PDL::Transform::Proj4::defmodel'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_deformation Autogenerated transformation function for Proj4 projection code deformation. The full name for this projection is Kinematic grid shift. =cut sub t_proj_deformation { 'PDL::Transform::Proj4::deformation'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_denoy Autogenerated transformation function for Proj4 projection code denoy. The full name for this projection is Denoyer Semi-Elliptical. =cut sub t_proj_denoy { 'PDL::Transform::Proj4::denoy'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_eck1 Autogenerated transformation function for Proj4 projection code eck1. The full name for this projection is Eckert I. =cut sub t_proj_eck1 { 'PDL::Transform::Proj4::eck1'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_eck2 Autogenerated transformation function for Proj4 projection code eck2. The full name for this projection is Eckert II. =cut sub t_proj_eck2 { 'PDL::Transform::Proj4::eck2'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_eck3 Autogenerated transformation function for Proj4 projection code eck3. The full name for this projection is Eckert III. =cut sub t_proj_eck3 { 'PDL::Transform::Proj4::eck3'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_eck4 Autogenerated transformation function for Proj4 projection code eck4. The full name for this projection is Eckert IV. =cut sub t_proj_eck4 { 'PDL::Transform::Proj4::eck4'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_eck5 Autogenerated transformation function for Proj4 projection code eck5. The full name for this projection is Eckert V. =cut sub t_proj_eck5 { 'PDL::Transform::Proj4::eck5'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_eck6 Autogenerated transformation function for Proj4 projection code eck6. The full name for this projection is Eckert VI. =cut sub t_proj_eck6 { 'PDL::Transform::Proj4::eck6'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_eqc Autogenerated transformation function for Proj4 projection code eqc. The full name for this projection is Equidistant Cylindrical (Plate Carree). Projection Parameters =for options =over 4 =item lat_00 =item lat_ts =back =cut sub t_proj_eqc { 'PDL::Transform::Proj4::eqc'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_eqdc Autogenerated transformation function for Proj4 projection code eqdc. The full name for this projection is Equidistant Conic. Projection Parameters =for options =over 4 =item lat_1 =item lat_2 =back =cut sub t_proj_eqdc { 'PDL::Transform::Proj4::eqdc'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_eqearth Autogenerated transformation function for Proj4 projection code eqearth. The full name for this projection is Equal Earth. =cut sub t_proj_eqearth { 'PDL::Transform::Proj4::eqearth'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_etmerc Autogenerated transformation function for Proj4 projection code etmerc. The full name for this projection is Extended Transverse Mercator. =cut sub t_proj_etmerc { 'PDL::Transform::Proj4::etmerc'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_euler Autogenerated transformation function for Proj4 projection code euler. The full name for this projection is Euler. Projection Parameters =for options =over 4 =item lat_1 =item lat_2 =back =cut sub t_proj_euler { 'PDL::Transform::Proj4::euler'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_fahey Autogenerated transformation function for Proj4 projection code fahey. The full name for this projection is Fahey. =cut sub t_proj_fahey { 'PDL::Transform::Proj4::fahey'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_fouc Autogenerated transformation function for Proj4 projection code fouc. The full name for this projection is Foucaut. =cut sub t_proj_fouc { 'PDL::Transform::Proj4::fouc'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_fouc_s Autogenerated transformation function for Proj4 projection code fouc_s. The full name for this projection is Foucaut Sinusoidal. =cut sub t_proj_fouc_s { 'PDL::Transform::Proj4::fouc_s'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_gall Autogenerated transformation function for Proj4 projection code gall. The full name for this projection is Gall (Gall Stereographic). =cut sub t_proj_gall { 'PDL::Transform::Proj4::gall'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_geoc Autogenerated transformation function for Proj4 projection code geoc. The full name for this projection is Geocentric Latitude. =cut sub t_proj_geoc { 'PDL::Transform::Proj4::geoc'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_geocent Autogenerated transformation function for Proj4 projection code geocent. The full name for this projection is Geocentric. =cut sub t_proj_geocent { 'PDL::Transform::Proj4::geocent'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_geogoffset Autogenerated transformation function for Proj4 projection code geogoffset. The full name for this projection is Geographic Offset. =cut sub t_proj_geogoffset { 'PDL::Transform::Proj4::geogoffset'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_geos Autogenerated transformation function for Proj4 projection code geos. The full name for this projection is Geostationary Satellite View. Projection Parameters =for options =over 4 =item h =back =cut sub t_proj_geos { 'PDL::Transform::Proj4::geos'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_gins8 Autogenerated transformation function for Proj4 projection code gins8. The full name for this projection is Ginsburg VIII (TsNIIGAiK). =cut sub t_proj_gins8 { 'PDL::Transform::Proj4::gins8'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_gn_sinu Autogenerated transformation function for Proj4 projection code gn_sinu. The full name for this projection is General Sinusoidal Series. Projection Parameters =for options =over 4 =item m =item n =back =cut sub t_proj_gn_sinu { 'PDL::Transform::Proj4::gn_sinu'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_gnom Autogenerated transformation function for Proj4 projection code gnom. The full name for this projection is Gnomonic. =cut sub t_proj_gnom { 'PDL::Transform::Proj4::gnom'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_goode Autogenerated transformation function for Proj4 projection code goode. The full name for this projection is Goode Homolosine. =cut sub t_proj_goode { 'PDL::Transform::Proj4::goode'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_gs48 Autogenerated transformation function for Proj4 projection code gs48. The full name for this projection is Modified Stereographic of 48 U.S.. =cut sub t_proj_gs48 { 'PDL::Transform::Proj4::gs48'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_gs50 Autogenerated transformation function for Proj4 projection code gs50. The full name for this projection is Modified Stereographic of 50 U.S.. =cut sub t_proj_gs50 { 'PDL::Transform::Proj4::gs50'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_gstmerc Autogenerated transformation function for Proj4 projection code gstmerc. The full name for this projection is Gauss-Schreiber Transverse Mercator (aka Gauss-Laborde Reunion). Projection Parameters =for options =over 4 =item k_0 =item lat_0 =item lon_0 =back =cut sub t_proj_gstmerc { 'PDL::Transform::Proj4::gstmerc'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_guyou Autogenerated transformation function for Proj4 projection code guyou. The full name for this projection is Guyou. =cut sub t_proj_guyou { 'PDL::Transform::Proj4::guyou'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_hammer Autogenerated transformation function for Proj4 projection code hammer. The full name for this projection is Hammer & Eckert-Greifendorff. Projection Parameters =for options =over 4 =item M =item W =back =cut sub t_proj_hammer { 'PDL::Transform::Proj4::hammer'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_hatano Autogenerated transformation function for Proj4 projection code hatano. The full name for this projection is Hatano Asymmetrical Equal Area. =cut sub t_proj_hatano { 'PDL::Transform::Proj4::hatano'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_healpix Autogenerated transformation function for Proj4 projection code healpix. The full name for this projection is HEALPix. Projection Parameters =for options =over 4 =item rot_xy =back =cut sub t_proj_healpix { 'PDL::Transform::Proj4::healpix'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_helmert Autogenerated transformation function for Proj4 projection code helmert. The full name for this projection is 3(6)-, 4(8)- and 7(14)-parameter Helmert shift. =cut sub t_proj_helmert { 'PDL::Transform::Proj4::helmert'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_hgridshift Autogenerated transformation function for Proj4 projection code hgridshift. The full name for this projection is Horizontal grid shift. =cut sub t_proj_hgridshift { 'PDL::Transform::Proj4::hgridshift'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_horner Autogenerated transformation function for Proj4 projection code horner. The full name for this projection is Horner polynomial evaluation. =cut sub t_proj_horner { 'PDL::Transform::Proj4::horner'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_igh Autogenerated transformation function for Proj4 projection code igh. The full name for this projection is Interrupted Goode Homolosine. =cut sub t_proj_igh { 'PDL::Transform::Proj4::igh'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_igh_o Autogenerated transformation function for Proj4 projection code igh_o. The full name for this projection is Interrupted Goode Homolosine Oceanic View. =cut sub t_proj_igh_o { 'PDL::Transform::Proj4::igh_o'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_imw_p Autogenerated transformation function for Proj4 projection code imw_p. The full name for this projection is International Map of the World Polyconic. Projection Parameters =for options =over 4 =item lat_1 =item lat_2 =item lon_1 =back =cut sub t_proj_imw_p { 'PDL::Transform::Proj4::imw_p'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_isea Autogenerated transformation function for Proj4 projection code isea. The full name for this projection is Icosahedral Snyder Equal Area. =cut sub t_proj_isea { 'PDL::Transform::Proj4::isea'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_kav5 Autogenerated transformation function for Proj4 projection code kav5. The full name for this projection is Kavraisky V. =cut sub t_proj_kav5 { 'PDL::Transform::Proj4::kav5'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_kav7 Autogenerated transformation function for Proj4 projection code kav7. The full name for this projection is Kavraisky VII. =cut sub t_proj_kav7 { 'PDL::Transform::Proj4::kav7'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_krovak Autogenerated transformation function for Proj4 projection code krovak. The full name for this projection is Krovak. =cut sub t_proj_krovak { 'PDL::Transform::Proj4::krovak'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_labrd Autogenerated transformation function for Proj4 projection code labrd. The full name for this projection is Laborde. =cut sub t_proj_labrd { 'PDL::Transform::Proj4::labrd'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_laea Autogenerated transformation function for Proj4 projection code laea. The full name for this projection is Lambert Azimuthal Equal Area. =cut sub t_proj_laea { 'PDL::Transform::Proj4::laea'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_lagrng Autogenerated transformation function for Proj4 projection code lagrng. The full name for this projection is Lagrange. Projection Parameters =for options =over 4 =item W =back =cut sub t_proj_lagrng { 'PDL::Transform::Proj4::lagrng'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_larr Autogenerated transformation function for Proj4 projection code larr. The full name for this projection is Larrivee. =cut sub t_proj_larr { 'PDL::Transform::Proj4::larr'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_lask Autogenerated transformation function for Proj4 projection code lask. The full name for this projection is Laskowski. =cut sub t_proj_lask { 'PDL::Transform::Proj4::lask'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_latlon Autogenerated transformation function for Proj4 projection code latlon. The full name for this projection is Lat/long (Geodetic alias). =cut sub t_proj_latlon { 'PDL::Transform::Proj4::latlon'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_latlong Autogenerated transformation function for Proj4 projection code latlong. The full name for this projection is Lat/long (Geodetic alias). =cut sub t_proj_latlong { 'PDL::Transform::Proj4::latlong'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_lcc Autogenerated transformation function for Proj4 projection code lcc. The full name for this projection is Lambert Conformal Conic. Projection Parameters =for options =over 4 =item k_0 =item lat_0 =item lat_1 =item lat_2 =back =cut sub t_proj_lcc { 'PDL::Transform::Proj4::lcc'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_lcca Autogenerated transformation function for Proj4 projection code lcca. The full name for this projection is Lambert Conformal Conic Alternative. Projection Parameters =for options =over 4 =item lat_0 =back =cut sub t_proj_lcca { 'PDL::Transform::Proj4::lcca'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_leac Autogenerated transformation function for Proj4 projection code leac. The full name for this projection is Lambert Equal Area Conic. Projection Parameters =for options =over 4 =item lat_1 =item south =back =cut sub t_proj_leac { 'PDL::Transform::Proj4::leac'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_lee_os Autogenerated transformation function for Proj4 projection code lee_os. The full name for this projection is Lee Oblated Stereographic. =cut sub t_proj_lee_os { 'PDL::Transform::Proj4::lee_os'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_longlat Autogenerated transformation function for Proj4 projection code longlat. The full name for this projection is Lat/long (Geodetic alias). =cut sub t_proj_longlat { 'PDL::Transform::Proj4::longlat'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_lonlat Autogenerated transformation function for Proj4 projection code lonlat. The full name for this projection is Lat/long (Geodetic). =cut sub t_proj_lonlat { 'PDL::Transform::Proj4::lonlat'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_loxim Autogenerated transformation function for Proj4 projection code loxim. The full name for this projection is Loximuthal. =cut sub t_proj_loxim { 'PDL::Transform::Proj4::loxim'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_lsat Autogenerated transformation function for Proj4 projection code lsat. The full name for this projection is Space oblique for LANDSAT. Projection Parameters =for options =over 4 =item lsat =item path =back =cut sub t_proj_lsat { 'PDL::Transform::Proj4::lsat'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_mbt_fps Autogenerated transformation function for Proj4 projection code mbt_fps. The full name for this projection is McBryde-Thomas Flat-Pole Sine (No. 2). =cut sub t_proj_mbt_fps { 'PDL::Transform::Proj4::mbt_fps'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_mbt_s Autogenerated transformation function for Proj4 projection code mbt_s. The full name for this projection is McBryde-Thomas Flat-Polar Sine (No. 1). =cut sub t_proj_mbt_s { 'PDL::Transform::Proj4::mbt_s'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_mbtfpp Autogenerated transformation function for Proj4 projection code mbtfpp. The full name for this projection is McBride-Thomas Flat-Polar Parabolic. =cut sub t_proj_mbtfpp { 'PDL::Transform::Proj4::mbtfpp'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_mbtfpq Autogenerated transformation function for Proj4 projection code mbtfpq. The full name for this projection is McBryde-Thomas Flat-Polar Quartic. =cut sub t_proj_mbtfpq { 'PDL::Transform::Proj4::mbtfpq'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_mbtfps Autogenerated transformation function for Proj4 projection code mbtfps. The full name for this projection is McBryde-Thomas Flat-Polar Sinusoidal. =cut sub t_proj_mbtfps { 'PDL::Transform::Proj4::mbtfps'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_merc Autogenerated transformation function for Proj4 projection code merc. The full name for this projection is Mercator. Projection Parameters =for options =over 4 =item lat_ts =back =cut sub t_proj_merc { 'PDL::Transform::Proj4::merc'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_mil_os Autogenerated transformation function for Proj4 projection code mil_os. The full name for this projection is Miller Oblated Stereographic. =cut sub t_proj_mil_os { 'PDL::Transform::Proj4::mil_os'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_mill Autogenerated transformation function for Proj4 projection code mill. The full name for this projection is Miller Cylindrical. =cut sub t_proj_mill { 'PDL::Transform::Proj4::mill'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_misrsom Autogenerated transformation function for Proj4 projection code misrsom. The full name for this projection is Space oblique for MISR. Projection Parameters =for options =over 4 =item path =back =cut sub t_proj_misrsom { 'PDL::Transform::Proj4::misrsom'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_moll Autogenerated transformation function for Proj4 projection code moll. The full name for this projection is Mollweide. =cut sub t_proj_moll { 'PDL::Transform::Proj4::moll'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_molobadekas Autogenerated transformation function for Proj4 projection code molobadekas. The full name for this projection is Molodensky-Badekas transformation. =cut sub t_proj_molobadekas { 'PDL::Transform::Proj4::molobadekas'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_molodensky Autogenerated transformation function for Proj4 projection code molodensky. The full name for this projection is Molodensky transform. =cut sub t_proj_molodensky { 'PDL::Transform::Proj4::molodensky'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_murd1 Autogenerated transformation function for Proj4 projection code murd1. The full name for this projection is Murdoch I. Projection Parameters =for options =over 4 =item lat_1 =item lat_2 =back =cut sub t_proj_murd1 { 'PDL::Transform::Proj4::murd1'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_murd2 Autogenerated transformation function for Proj4 projection code murd2. The full name for this projection is Murdoch II. Projection Parameters =for options =over 4 =item lat_1 =item lat_2 =back =cut sub t_proj_murd2 { 'PDL::Transform::Proj4::murd2'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_murd3 Autogenerated transformation function for Proj4 projection code murd3. The full name for this projection is Murdoch III. Projection Parameters =for options =over 4 =item lat_1 =item lat_2 =back =cut sub t_proj_murd3 { 'PDL::Transform::Proj4::murd3'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_natearth Autogenerated transformation function for Proj4 projection code natearth. The full name for this projection is Natural Earth. =cut sub t_proj_natearth { 'PDL::Transform::Proj4::natearth'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_natearth2 Autogenerated transformation function for Proj4 projection code natearth2. The full name for this projection is Natural Earth 2. =cut sub t_proj_natearth2 { 'PDL::Transform::Proj4::natearth2'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_nell Autogenerated transformation function for Proj4 projection code nell. The full name for this projection is Nell. =cut sub t_proj_nell { 'PDL::Transform::Proj4::nell'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_nell_h Autogenerated transformation function for Proj4 projection code nell_h. The full name for this projection is Nell-Hammer. =cut sub t_proj_nell_h { 'PDL::Transform::Proj4::nell_h'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_nicol Autogenerated transformation function for Proj4 projection code nicol. The full name for this projection is Nicolosi Globular. =cut sub t_proj_nicol { 'PDL::Transform::Proj4::nicol'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_noop Autogenerated transformation function for Proj4 projection code noop. The full name for this projection is No operation. =cut sub t_proj_noop { 'PDL::Transform::Proj4::noop'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_nsper Autogenerated transformation function for Proj4 projection code nsper. The full name for this projection is Near-sided perspective. Projection Parameters =for options =over 4 =item h =back =cut sub t_proj_nsper { 'PDL::Transform::Proj4::nsper'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_nzmg Autogenerated transformation function for Proj4 projection code nzmg. The full name for this projection is New Zealand Map Grid. =cut sub t_proj_nzmg { 'PDL::Transform::Proj4::nzmg'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_ob_tran Autogenerated transformation function for Proj4 projection code ob_tran. The full name for this projection is General Oblique Transformation. Projection Parameters =for options =over 4 =item o_alpha =item o_lat_1 =item o_lat_2 =item o_lat_c =item o_lat_p =item o_lon_1 =item o_lon_2 =item o_lon_c =item o_lon_p =item o_proj =back =cut sub t_proj_ob_tran { 'PDL::Transform::Proj4::ob_tran'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_ocea Autogenerated transformation function for Proj4 projection code ocea. The full name for this projection is Oblique Cylindrical Equal Area. Projection Parameters =for options =over 4 =item lat_1 =item lat_2 =item lon_1 =item lon_2 =back =cut sub t_proj_ocea { 'PDL::Transform::Proj4::ocea'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_oea Autogenerated transformation function for Proj4 projection code oea. The full name for this projection is Oblated Equal Area. Projection Parameters =for options =over 4 =item m =item n =item theta =back =cut sub t_proj_oea { 'PDL::Transform::Proj4::oea'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_omerc Autogenerated transformation function for Proj4 projection code omerc. The full name for this projection is Oblique Mercator. Projection Parameters =for options =over 4 =item alpha =item gamma =item lat_1 =item lat_2 =item lon_1 =item lon_2 =item lonc =item no_off =back =cut sub t_proj_omerc { 'PDL::Transform::Proj4::omerc'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_ortel Autogenerated transformation function for Proj4 projection code ortel. The full name for this projection is Ortelius Oval. =cut sub t_proj_ortel { 'PDL::Transform::Proj4::ortel'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_ortho Autogenerated transformation function for Proj4 projection code ortho. The full name for this projection is Orthographic. =cut sub t_proj_ortho { 'PDL::Transform::Proj4::ortho'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_patterson Autogenerated transformation function for Proj4 projection code patterson. The full name for this projection is Patterson Cylindrical. =cut sub t_proj_patterson { 'PDL::Transform::Proj4::patterson'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_pconic Autogenerated transformation function for Proj4 projection code pconic. The full name for this projection is Perspective Conic. Projection Parameters =for options =over 4 =item lat_1 =item lat_2 =back =cut sub t_proj_pconic { 'PDL::Transform::Proj4::pconic'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_peirce_q Autogenerated transformation function for Proj4 projection code peirce_q. The full name for this projection is Peirce Quincuncial. =cut sub t_proj_peirce_q { 'PDL::Transform::Proj4::peirce_q'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_pipeline Autogenerated transformation function for Proj4 projection code pipeline. The full name for this projection is Transformation pipeline manager. =cut sub t_proj_pipeline { 'PDL::Transform::Proj4::pipeline'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_poly Autogenerated transformation function for Proj4 projection code poly. The full name for this projection is Polyconic (American). =cut sub t_proj_poly { 'PDL::Transform::Proj4::poly'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_pop Autogenerated transformation function for Proj4 projection code pop. The full name for this projection is Retrieve coordinate value from pipeline stack. =cut sub t_proj_pop { 'PDL::Transform::Proj4::pop'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_push Autogenerated transformation function for Proj4 projection code push. The full name for this projection is Save coordinate value on pipeline stack. =cut sub t_proj_push { 'PDL::Transform::Proj4::push'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_putp1 Autogenerated transformation function for Proj4 projection code putp1. The full name for this projection is Putnins P1. =cut sub t_proj_putp1 { 'PDL::Transform::Proj4::putp1'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_putp2 Autogenerated transformation function for Proj4 projection code putp2. The full name for this projection is Putnins P2. =cut sub t_proj_putp2 { 'PDL::Transform::Proj4::putp2'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_putp3 Autogenerated transformation function for Proj4 projection code putp3. The full name for this projection is Putnins P3. =cut sub t_proj_putp3 { 'PDL::Transform::Proj4::putp3'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_putp3p Autogenerated transformation function for Proj4 projection code putp3p. The full name for this projection is Putnins P3'. =cut sub t_proj_putp3p { 'PDL::Transform::Proj4::putp3p'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_putp4p Autogenerated transformation function for Proj4 projection code putp4p. The full name for this projection is Putnins P4'. =cut sub t_proj_putp4p { 'PDL::Transform::Proj4::putp4p'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_putp5 Autogenerated transformation function for Proj4 projection code putp5. The full name for this projection is Putnins P5. =cut sub t_proj_putp5 { 'PDL::Transform::Proj4::putp5'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_putp5p Autogenerated transformation function for Proj4 projection code putp5p. The full name for this projection is Putnins P5'. =cut sub t_proj_putp5p { 'PDL::Transform::Proj4::putp5p'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_putp6 Autogenerated transformation function for Proj4 projection code putp6. The full name for this projection is Putnins P6. =cut sub t_proj_putp6 { 'PDL::Transform::Proj4::putp6'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_putp6p Autogenerated transformation function for Proj4 projection code putp6p. The full name for this projection is Putnins P6'. =cut sub t_proj_putp6p { 'PDL::Transform::Proj4::putp6p'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_qsc Autogenerated transformation function for Proj4 projection code qsc. The full name for this projection is Quadrilateralized Spherical Cube. =cut sub t_proj_qsc { 'PDL::Transform::Proj4::qsc'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_qua_aut Autogenerated transformation function for Proj4 projection code qua_aut. The full name for this projection is Quartic Authalic. =cut sub t_proj_qua_aut { 'PDL::Transform::Proj4::qua_aut'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_rhealpix Autogenerated transformation function for Proj4 projection code rhealpix. The full name for this projection is rHEALPix. Projection Parameters =for options =over 4 =item north_square =item south_square =back =cut sub t_proj_rhealpix { 'PDL::Transform::Proj4::rhealpix'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_robin Autogenerated transformation function for Proj4 projection code robin. The full name for this projection is Robinson. =cut sub t_proj_robin { 'PDL::Transform::Proj4::robin'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_rouss Autogenerated transformation function for Proj4 projection code rouss. The full name for this projection is Roussilhe Stereographic. =cut sub t_proj_rouss { 'PDL::Transform::Proj4::rouss'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_rpoly Autogenerated transformation function for Proj4 projection code rpoly. The full name for this projection is Rectangular Polyconic. Projection Parameters =for options =over 4 =item lat_ts =back =cut sub t_proj_rpoly { 'PDL::Transform::Proj4::rpoly'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_s2 Autogenerated transformation function for Proj4 projection code s2. The full name for this projection is S2. =cut sub t_proj_s2 { 'PDL::Transform::Proj4::s2'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_sch Autogenerated transformation function for Proj4 projection code sch. The full name for this projection is Spherical Cross-track Height. Projection Parameters =for options =over 4 =item h_0 =item phdg_0 =item plat_0 =item plon_0 =back =cut sub t_proj_sch { 'PDL::Transform::Proj4::sch'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_set Autogenerated transformation function for Proj4 projection code set. The full name for this projection is Set coordinate value. =cut sub t_proj_set { 'PDL::Transform::Proj4::set'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_sinu Autogenerated transformation function for Proj4 projection code sinu. The full name for this projection is Sinusoidal (Sanson-Flamsteed). =cut sub t_proj_sinu { 'PDL::Transform::Proj4::sinu'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_somerc Autogenerated transformation function for Proj4 projection code somerc. The full name for this projection is Swiss. Obl. Mercator. =cut sub t_proj_somerc { 'PDL::Transform::Proj4::somerc'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_stere Autogenerated transformation function for Proj4 projection code stere. The full name for this projection is Stereographic. Projection Parameters =for options =over 4 =item lat_ts =back =cut sub t_proj_stere { 'PDL::Transform::Proj4::stere'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_sterea Autogenerated transformation function for Proj4 projection code sterea. The full name for this projection is Oblique Stereographic Alternative. =cut sub t_proj_sterea { 'PDL::Transform::Proj4::sterea'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_tcc Autogenerated transformation function for Proj4 projection code tcc. The full name for this projection is Transverse Central Cylindrical. =cut sub t_proj_tcc { 'PDL::Transform::Proj4::tcc'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_tcea Autogenerated transformation function for Proj4 projection code tcea. The full name for this projection is Transverse Cylindrical Equal Area. =cut sub t_proj_tcea { 'PDL::Transform::Proj4::tcea'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_times Autogenerated transformation function for Proj4 projection code times. The full name for this projection is Times. =cut sub t_proj_times { 'PDL::Transform::Proj4::times'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_tinshift Autogenerated transformation function for Proj4 projection code tinshift. The full name for this projection is Triangulation based transformation. =cut sub t_proj_tinshift { 'PDL::Transform::Proj4::tinshift'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_tissot Autogenerated transformation function for Proj4 projection code tissot. The full name for this projection is Tissot. Projection Parameters =for options =over 4 =item lat_1 =item lat_2 =back =cut sub t_proj_tissot { 'PDL::Transform::Proj4::tissot'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_tmerc Autogenerated transformation function for Proj4 projection code tmerc. The full name for this projection is Transverse Mercator. Projection Parameters =for options =over 4 =item approx =back =cut sub t_proj_tmerc { 'PDL::Transform::Proj4::tmerc'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_tobmerc Autogenerated transformation function for Proj4 projection code tobmerc. The full name for this projection is Tobler-Mercator. =cut sub t_proj_tobmerc { 'PDL::Transform::Proj4::tobmerc'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_topocentric Autogenerated transformation function for Proj4 projection code topocentric. The full name for this projection is Geocentric/Topocentric conversion. =cut sub t_proj_topocentric { 'PDL::Transform::Proj4::topocentric'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_tpeqd Autogenerated transformation function for Proj4 projection code tpeqd. The full name for this projection is Two Point Equidistant. Projection Parameters =for options =over 4 =item lat_1 =item lat_2 =item lon_1 =item lon_2 =back =cut sub t_proj_tpeqd { 'PDL::Transform::Proj4::tpeqd'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_tpers Autogenerated transformation function for Proj4 projection code tpers. The full name for this projection is Tilted perspective. Projection Parameters =for options =over 4 =item azi =item h =item tilt =back =cut sub t_proj_tpers { 'PDL::Transform::Proj4::tpers'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_unitconvert Autogenerated transformation function for Proj4 projection code unitconvert. The full name for this projection is Unit conversion. =cut sub t_proj_unitconvert { 'PDL::Transform::Proj4::unitconvert'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_ups Autogenerated transformation function for Proj4 projection code ups. The full name for this projection is Universal Polar Stereographic. Projection Parameters =for options =over 4 =item south =back =cut sub t_proj_ups { 'PDL::Transform::Proj4::ups'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_urm5 Autogenerated transformation function for Proj4 projection code urm5. The full name for this projection is Urmaev V. Projection Parameters =for options =over 4 =item alpha =item n =item q =back =cut sub t_proj_urm5 { 'PDL::Transform::Proj4::urm5'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_urmfps Autogenerated transformation function for Proj4 projection code urmfps. The full name for this projection is Urmaev Flat-Polar Sinusoidal. Projection Parameters =for options =over 4 =item n =back =cut sub t_proj_urmfps { 'PDL::Transform::Proj4::urmfps'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_utm Autogenerated transformation function for Proj4 projection code utm. The full name for this projection is Universal Transverse Mercator (UTM). Projection Parameters =for options =over 4 =item approx =item south =item zone =back =cut sub t_proj_utm { 'PDL::Transform::Proj4::utm'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_vandg Autogenerated transformation function for Proj4 projection code vandg. The full name for this projection is van der Grinten (I). =cut sub t_proj_vandg { 'PDL::Transform::Proj4::vandg'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_vandg2 Autogenerated transformation function for Proj4 projection code vandg2. The full name for this projection is van der Grinten II. =cut sub t_proj_vandg2 { 'PDL::Transform::Proj4::vandg2'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_vandg3 Autogenerated transformation function for Proj4 projection code vandg3. The full name for this projection is van der Grinten III. =cut sub t_proj_vandg3 { 'PDL::Transform::Proj4::vandg3'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_vandg4 Autogenerated transformation function for Proj4 projection code vandg4. The full name for this projection is van der Grinten IV. =cut sub t_proj_vandg4 { 'PDL::Transform::Proj4::vandg4'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_vgridshift Autogenerated transformation function for Proj4 projection code vgridshift. The full name for this projection is Vertical grid shift. =cut sub t_proj_vgridshift { 'PDL::Transform::Proj4::vgridshift'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_vitk1 Autogenerated transformation function for Proj4 projection code vitk1. The full name for this projection is Vitkovsky I. Projection Parameters =for options =over 4 =item lat_1 =item lat_2 =back =cut sub t_proj_vitk1 { 'PDL::Transform::Proj4::vitk1'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_wag1 Autogenerated transformation function for Proj4 projection code wag1. The full name for this projection is Wagner I (Kavraisky VI). =cut sub t_proj_wag1 { 'PDL::Transform::Proj4::wag1'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_wag2 Autogenerated transformation function for Proj4 projection code wag2. The full name for this projection is Wagner II. =cut sub t_proj_wag2 { 'PDL::Transform::Proj4::wag2'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_wag3 Autogenerated transformation function for Proj4 projection code wag3. The full name for this projection is Wagner III. Projection Parameters =for options =over 4 =item lat_ts =back =cut sub t_proj_wag3 { 'PDL::Transform::Proj4::wag3'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_wag4 Autogenerated transformation function for Proj4 projection code wag4. The full name for this projection is Wagner IV. =cut sub t_proj_wag4 { 'PDL::Transform::Proj4::wag4'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_wag5 Autogenerated transformation function for Proj4 projection code wag5. The full name for this projection is Wagner V. =cut sub t_proj_wag5 { 'PDL::Transform::Proj4::wag5'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_wag6 Autogenerated transformation function for Proj4 projection code wag6. The full name for this projection is Wagner VI. =cut sub t_proj_wag6 { 'PDL::Transform::Proj4::wag6'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_wag7 Autogenerated transformation function for Proj4 projection code wag7. The full name for this projection is Wagner VII. =cut sub t_proj_wag7 { 'PDL::Transform::Proj4::wag7'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_webmerc Autogenerated transformation function for Proj4 projection code webmerc. The full name for this projection is Web Mercator / Pseudo Mercator. =cut sub t_proj_webmerc { 'PDL::Transform::Proj4::webmerc'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_weren Autogenerated transformation function for Proj4 projection code weren. The full name for this projection is Werenskiold I. =cut sub t_proj_weren { 'PDL::Transform::Proj4::weren'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_wink1 Autogenerated transformation function for Proj4 projection code wink1. The full name for this projection is Winkel I. Projection Parameters =for options =over 4 =item lat_ts =back =cut sub t_proj_wink1 { 'PDL::Transform::Proj4::wink1'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_wink2 Autogenerated transformation function for Proj4 projection code wink2. The full name for this projection is Winkel II. Projection Parameters =for options =over 4 =item lat_1 =back =cut sub t_proj_wink2 { 'PDL::Transform::Proj4::wink2'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_wintri Autogenerated transformation function for Proj4 projection code wintri. The full name for this projection is Winkel Tripel. Projection Parameters =for options =over 4 =item lat_1 =back =cut sub t_proj_wintri { 'PDL::Transform::Proj4::wintri'->new( @_ ); } #line 451 "Proj4.pd" =head2 t_proj_xyzgridshift Autogenerated transformation function for Proj4 projection code xyzgridshift. The full name for this projection is Geocentric grid shift. =cut sub t_proj_xyzgridshift { 'PDL::Transform::Proj4::xyzgridshift'->new( @_ ); } #line 3122 "Proj4.pm" *_proj4_dummy = \&PDL::_proj4_dummy; #line 434 "Proj4.pd" #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # adams_hemi # package # hide from PAUSE PDL::Transform::Proj4::adams_hemi; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::adams_hemi::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Adams Hemisphere in a Square"; $self->{proj_code} = "adams_hemi"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::adams_hemi::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # adams_ws1 # package # hide from PAUSE PDL::Transform::Proj4::adams_ws1; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::adams_ws1::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Adams World in a Square I"; $self->{proj_code} = "adams_ws1"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::adams_ws1::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # adams_ws2 # package # hide from PAUSE PDL::Transform::Proj4::adams_ws2; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::adams_ws2::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Adams World in a Square II"; $self->{proj_code} = "adams_ws2"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::adams_ws2::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # aea # package # hide from PAUSE PDL::Transform::Proj4::aea; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::aea::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Albers Equal Area"; $self->{proj_code} = "aea"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 lat_2 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::aea::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # aeqd # package # hide from PAUSE PDL::Transform::Proj4::aeqd; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::aeqd::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Azimuthal Equidistant"; $self->{proj_code} = "aeqd"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_0 guam ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::aeqd::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # affine # package # hide from PAUSE PDL::Transform::Proj4::affine; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::affine::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Affine transformation"; $self->{proj_code} = "affine"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::affine::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # airy # package # hide from PAUSE PDL::Transform::Proj4::airy; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::airy::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Airy"; $self->{proj_code} = "airy"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( no_cut lat_b ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::airy::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # aitoff # package # hide from PAUSE PDL::Transform::Proj4::aitoff; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::aitoff::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Aitoff"; $self->{proj_code} = "aitoff"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::aitoff::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # alsk # package # hide from PAUSE PDL::Transform::Proj4::alsk; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::alsk::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Modified Stereographic of Alaska"; $self->{proj_code} = "alsk"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::alsk::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # apian # package # hide from PAUSE PDL::Transform::Proj4::apian; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::apian::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Apian Globular I"; $self->{proj_code} = "apian"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::apian::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # august # package # hide from PAUSE PDL::Transform::Proj4::august; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::august::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "August Epicycloidal"; $self->{proj_code} = "august"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::august::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # axisswap # package # hide from PAUSE PDL::Transform::Proj4::axisswap; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::axisswap::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Axis ordering"; $self->{proj_code} = "axisswap"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::axisswap::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # bacon # package # hide from PAUSE PDL::Transform::Proj4::bacon; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::bacon::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Bacon Globular"; $self->{proj_code} = "bacon"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::bacon::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # bertin1953 # package # hide from PAUSE PDL::Transform::Proj4::bertin1953; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::bertin1953::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Bertin 1953"; $self->{proj_code} = "bertin1953"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::bertin1953::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # bipc # package # hide from PAUSE PDL::Transform::Proj4::bipc; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::bipc::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Bipolar conic of western hemisphere"; $self->{proj_code} = "bipc"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::bipc::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # boggs # package # hide from PAUSE PDL::Transform::Proj4::boggs; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::boggs::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Boggs Eumorphic"; $self->{proj_code} = "boggs"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::boggs::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # bonne # package # hide from PAUSE PDL::Transform::Proj4::bonne; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::bonne::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Bonne (Werner lat_1=90)"; $self->{proj_code} = "bonne"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::bonne::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # calcofi # package # hide from PAUSE PDL::Transform::Proj4::calcofi; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::calcofi::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Cal Coop Ocean Fish Invest Lines/Stations"; $self->{proj_code} = "calcofi"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::calcofi::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # cart # package # hide from PAUSE PDL::Transform::Proj4::cart; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::cart::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Geodetic/cartesian conversions"; $self->{proj_code} = "cart"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::cart::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # cass # package # hide from PAUSE PDL::Transform::Proj4::cass; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::cass::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Cassini"; $self->{proj_code} = "cass"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::cass::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # cc # package # hide from PAUSE PDL::Transform::Proj4::cc; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::cc::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Central Cylindrical"; $self->{proj_code} = "cc"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::cc::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # ccon # package # hide from PAUSE PDL::Transform::Proj4::ccon; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::ccon::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Central Conic"; $self->{proj_code} = "ccon"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::ccon::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # cea # package # hide from PAUSE PDL::Transform::Proj4::cea; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::cea::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Equal Area Cylindrical"; $self->{proj_code} = "cea"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_ts ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::cea::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # chamb # package # hide from PAUSE PDL::Transform::Proj4::chamb; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::chamb::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Chamberlin Trimetric"; $self->{proj_code} = "chamb"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 lon_1 lat_2 lon_2 lat_3 lon_3 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::chamb::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # col_urban # package # hide from PAUSE PDL::Transform::Proj4::col_urban; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::col_urban::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Colombia Urban"; $self->{proj_code} = "col_urban"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( h_0 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::col_urban::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # collg # package # hide from PAUSE PDL::Transform::Proj4::collg; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::collg::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Collignon"; $self->{proj_code} = "collg"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::collg::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # comill # package # hide from PAUSE PDL::Transform::Proj4::comill; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::comill::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Compact Miller"; $self->{proj_code} = "comill"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::comill::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # crast # package # hide from PAUSE PDL::Transform::Proj4::crast; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::crast::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Craster Parabolic (Putnins P4)"; $self->{proj_code} = "crast"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::crast::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # defmodel # package # hide from PAUSE PDL::Transform::Proj4::defmodel; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::defmodel::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Deformation model"; $self->{proj_code} = "defmodel"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::defmodel::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # deformation # package # hide from PAUSE PDL::Transform::Proj4::deformation; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::deformation::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Kinematic grid shift"; $self->{proj_code} = "deformation"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::deformation::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # denoy # package # hide from PAUSE PDL::Transform::Proj4::denoy; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::denoy::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Denoyer Semi-Elliptical"; $self->{proj_code} = "denoy"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::denoy::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # eck1 # package # hide from PAUSE PDL::Transform::Proj4::eck1; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::eck1::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Eckert I"; $self->{proj_code} = "eck1"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::eck1::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # eck2 # package # hide from PAUSE PDL::Transform::Proj4::eck2; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::eck2::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Eckert II"; $self->{proj_code} = "eck2"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::eck2::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # eck3 # package # hide from PAUSE PDL::Transform::Proj4::eck3; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::eck3::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Eckert III"; $self->{proj_code} = "eck3"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::eck3::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # eck4 # package # hide from PAUSE PDL::Transform::Proj4::eck4; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::eck4::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Eckert IV"; $self->{proj_code} = "eck4"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::eck4::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # eck5 # package # hide from PAUSE PDL::Transform::Proj4::eck5; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::eck5::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Eckert V"; $self->{proj_code} = "eck5"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::eck5::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # eck6 # package # hide from PAUSE PDL::Transform::Proj4::eck6; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::eck6::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Eckert VI"; $self->{proj_code} = "eck6"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::eck6::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # eqc # package # hide from PAUSE PDL::Transform::Proj4::eqc; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::eqc::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Equidistant Cylindrical (Plate Carree)"; $self->{proj_code} = "eqc"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_ts lat_00 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::eqc::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # eqdc # package # hide from PAUSE PDL::Transform::Proj4::eqdc; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::eqdc::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Equidistant Conic"; $self->{proj_code} = "eqdc"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 lat_2 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::eqdc::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # eqearth # package # hide from PAUSE PDL::Transform::Proj4::eqearth; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::eqearth::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Equal Earth"; $self->{proj_code} = "eqearth"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::eqearth::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # etmerc # package # hide from PAUSE PDL::Transform::Proj4::etmerc; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::etmerc::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Extended Transverse Mercator"; $self->{proj_code} = "etmerc"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::etmerc::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # euler # package # hide from PAUSE PDL::Transform::Proj4::euler; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::euler::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Euler"; $self->{proj_code} = "euler"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 lat_2 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::euler::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # fahey # package # hide from PAUSE PDL::Transform::Proj4::fahey; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::fahey::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Fahey"; $self->{proj_code} = "fahey"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::fahey::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # fouc # package # hide from PAUSE PDL::Transform::Proj4::fouc; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::fouc::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Foucaut"; $self->{proj_code} = "fouc"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::fouc::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # fouc_s # package # hide from PAUSE PDL::Transform::Proj4::fouc_s; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::fouc_s::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Foucaut Sinusoidal"; $self->{proj_code} = "fouc_s"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::fouc_s::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # gall # package # hide from PAUSE PDL::Transform::Proj4::gall; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::gall::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Gall (Gall Stereographic)"; $self->{proj_code} = "gall"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::gall::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # geoc # package # hide from PAUSE PDL::Transform::Proj4::geoc; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::geoc::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Geocentric Latitude"; $self->{proj_code} = "geoc"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::geoc::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # geocent # package # hide from PAUSE PDL::Transform::Proj4::geocent; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::geocent::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Geocentric"; $self->{proj_code} = "geocent"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::geocent::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # geogoffset # package # hide from PAUSE PDL::Transform::Proj4::geogoffset; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::geogoffset::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Geographic Offset"; $self->{proj_code} = "geogoffset"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::geogoffset::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # geos # package # hide from PAUSE PDL::Transform::Proj4::geos; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::geos::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Geostationary Satellite View"; $self->{proj_code} = "geos"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( h ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::geos::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # gins8 # package # hide from PAUSE PDL::Transform::Proj4::gins8; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::gins8::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Ginsburg VIII (TsNIIGAiK)"; $self->{proj_code} = "gins8"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::gins8::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # gn_sinu # package # hide from PAUSE PDL::Transform::Proj4::gn_sinu; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::gn_sinu::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "General Sinusoidal Series"; $self->{proj_code} = "gn_sinu"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( m n ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::gn_sinu::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # gnom # package # hide from PAUSE PDL::Transform::Proj4::gnom; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::gnom::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Gnomonic"; $self->{proj_code} = "gnom"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::gnom::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # goode # package # hide from PAUSE PDL::Transform::Proj4::goode; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::goode::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Goode Homolosine"; $self->{proj_code} = "goode"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::goode::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # gs48 # package # hide from PAUSE PDL::Transform::Proj4::gs48; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::gs48::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Modified Stereographic of 48 U.S."; $self->{proj_code} = "gs48"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::gs48::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # gs50 # package # hide from PAUSE PDL::Transform::Proj4::gs50; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::gs50::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Modified Stereographic of 50 U.S."; $self->{proj_code} = "gs50"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::gs50::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # gstmerc # package # hide from PAUSE PDL::Transform::Proj4::gstmerc; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::gstmerc::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Gauss-Schreiber Transverse Mercator (aka Gauss-Laborde Reunion)"; $self->{proj_code} = "gstmerc"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_0 lon_0 k_0 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::gstmerc::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # guyou # package # hide from PAUSE PDL::Transform::Proj4::guyou; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::guyou::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Guyou"; $self->{proj_code} = "guyou"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::guyou::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # hammer # package # hide from PAUSE PDL::Transform::Proj4::hammer; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::hammer::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Hammer & Eckert-Greifendorff"; $self->{proj_code} = "hammer"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( W M ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::hammer::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # hatano # package # hide from PAUSE PDL::Transform::Proj4::hatano; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::hatano::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Hatano Asymmetrical Equal Area"; $self->{proj_code} = "hatano"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::hatano::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # healpix # package # hide from PAUSE PDL::Transform::Proj4::healpix; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::healpix::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "HEALPix"; $self->{proj_code} = "healpix"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( rot_xy ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::healpix::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # helmert # package # hide from PAUSE PDL::Transform::Proj4::helmert; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::helmert::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "3(6)-, 4(8)- and 7(14)-parameter Helmert shift"; $self->{proj_code} = "helmert"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::helmert::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # hgridshift # package # hide from PAUSE PDL::Transform::Proj4::hgridshift; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::hgridshift::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Horizontal grid shift"; $self->{proj_code} = "hgridshift"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::hgridshift::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # horner # package # hide from PAUSE PDL::Transform::Proj4::horner; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::horner::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Horner polynomial evaluation"; $self->{proj_code} = "horner"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::horner::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # igh # package # hide from PAUSE PDL::Transform::Proj4::igh; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::igh::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Interrupted Goode Homolosine"; $self->{proj_code} = "igh"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::igh::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # igh_o # package # hide from PAUSE PDL::Transform::Proj4::igh_o; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::igh_o::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Interrupted Goode Homolosine Oceanic View"; $self->{proj_code} = "igh_o"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::igh_o::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # imw_p # package # hide from PAUSE PDL::Transform::Proj4::imw_p; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::imw_p::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "International Map of the World Polyconic"; $self->{proj_code} = "imw_p"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 lat_2 lon_1 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::imw_p::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # isea # package # hide from PAUSE PDL::Transform::Proj4::isea; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::isea::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Icosahedral Snyder Equal Area"; $self->{proj_code} = "isea"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::isea::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # kav5 # package # hide from PAUSE PDL::Transform::Proj4::kav5; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::kav5::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Kavraisky V"; $self->{proj_code} = "kav5"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::kav5::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # kav7 # package # hide from PAUSE PDL::Transform::Proj4::kav7; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::kav7::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Kavraisky VII"; $self->{proj_code} = "kav7"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::kav7::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # krovak # package # hide from PAUSE PDL::Transform::Proj4::krovak; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::krovak::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Krovak"; $self->{proj_code} = "krovak"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::krovak::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # labrd # package # hide from PAUSE PDL::Transform::Proj4::labrd; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::labrd::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Laborde"; $self->{proj_code} = "labrd"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::labrd::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # laea # package # hide from PAUSE PDL::Transform::Proj4::laea; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::laea::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Lambert Azimuthal Equal Area"; $self->{proj_code} = "laea"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::laea::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # lagrng # package # hide from PAUSE PDL::Transform::Proj4::lagrng; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::lagrng::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Lagrange"; $self->{proj_code} = "lagrng"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( W ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::lagrng::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # larr # package # hide from PAUSE PDL::Transform::Proj4::larr; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::larr::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Larrivee"; $self->{proj_code} = "larr"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::larr::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # lask # package # hide from PAUSE PDL::Transform::Proj4::lask; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::lask::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Laskowski"; $self->{proj_code} = "lask"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::lask::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # latlon # package # hide from PAUSE PDL::Transform::Proj4::latlon; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::latlon::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Lat/long (Geodetic alias)"; $self->{proj_code} = "latlon"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::latlon::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # latlong # package # hide from PAUSE PDL::Transform::Proj4::latlong; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::latlong::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Lat/long (Geodetic alias)"; $self->{proj_code} = "latlong"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::latlong::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # lcc # package # hide from PAUSE PDL::Transform::Proj4::lcc; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::lcc::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Lambert Conformal Conic"; $self->{proj_code} = "lcc"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 lat_2 lat_0 k_0 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::lcc::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # lcca # package # hide from PAUSE PDL::Transform::Proj4::lcca; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::lcca::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Lambert Conformal Conic Alternative"; $self->{proj_code} = "lcca"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_0 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::lcca::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # leac # package # hide from PAUSE PDL::Transform::Proj4::leac; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::leac::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Lambert Equal Area Conic"; $self->{proj_code} = "leac"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 south ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::leac::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # lee_os # package # hide from PAUSE PDL::Transform::Proj4::lee_os; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::lee_os::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Lee Oblated Stereographic"; $self->{proj_code} = "lee_os"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::lee_os::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # longlat # package # hide from PAUSE PDL::Transform::Proj4::longlat; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::longlat::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Lat/long (Geodetic alias)"; $self->{proj_code} = "longlat"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::longlat::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # lonlat # package # hide from PAUSE PDL::Transform::Proj4::lonlat; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::lonlat::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Lat/long (Geodetic)"; $self->{proj_code} = "lonlat"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::lonlat::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # loxim # package # hide from PAUSE PDL::Transform::Proj4::loxim; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::loxim::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Loximuthal"; $self->{proj_code} = "loxim"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::loxim::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # lsat # package # hide from PAUSE PDL::Transform::Proj4::lsat; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::lsat::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Space oblique for LANDSAT"; $self->{proj_code} = "lsat"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lsat path ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::lsat::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # mbt_fps # package # hide from PAUSE PDL::Transform::Proj4::mbt_fps; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::mbt_fps::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "McBryde-Thomas Flat-Pole Sine (No. 2)"; $self->{proj_code} = "mbt_fps"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::mbt_fps::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # mbt_s # package # hide from PAUSE PDL::Transform::Proj4::mbt_s; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::mbt_s::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "McBryde-Thomas Flat-Polar Sine (No. 1)"; $self->{proj_code} = "mbt_s"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::mbt_s::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # mbtfpp # package # hide from PAUSE PDL::Transform::Proj4::mbtfpp; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::mbtfpp::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "McBride-Thomas Flat-Polar Parabolic"; $self->{proj_code} = "mbtfpp"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::mbtfpp::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # mbtfpq # package # hide from PAUSE PDL::Transform::Proj4::mbtfpq; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::mbtfpq::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "McBryde-Thomas Flat-Polar Quartic"; $self->{proj_code} = "mbtfpq"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::mbtfpq::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # mbtfps # package # hide from PAUSE PDL::Transform::Proj4::mbtfps; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::mbtfps::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "McBryde-Thomas Flat-Polar Sinusoidal"; $self->{proj_code} = "mbtfps"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::mbtfps::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # merc # package # hide from PAUSE PDL::Transform::Proj4::merc; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::merc::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Mercator"; $self->{proj_code} = "merc"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_ts ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::merc::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # mil_os # package # hide from PAUSE PDL::Transform::Proj4::mil_os; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::mil_os::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Miller Oblated Stereographic"; $self->{proj_code} = "mil_os"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::mil_os::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # mill # package # hide from PAUSE PDL::Transform::Proj4::mill; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::mill::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Miller Cylindrical"; $self->{proj_code} = "mill"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::mill::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # misrsom # package # hide from PAUSE PDL::Transform::Proj4::misrsom; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::misrsom::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Space oblique for MISR"; $self->{proj_code} = "misrsom"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( path ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::misrsom::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # moll # package # hide from PAUSE PDL::Transform::Proj4::moll; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::moll::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Mollweide"; $self->{proj_code} = "moll"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::moll::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # molobadekas # package # hide from PAUSE PDL::Transform::Proj4::molobadekas; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::molobadekas::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Molodensky-Badekas transformation"; $self->{proj_code} = "molobadekas"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::molobadekas::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # molodensky # package # hide from PAUSE PDL::Transform::Proj4::molodensky; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::molodensky::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Molodensky transform"; $self->{proj_code} = "molodensky"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::molodensky::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # murd1 # package # hide from PAUSE PDL::Transform::Proj4::murd1; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::murd1::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Murdoch I"; $self->{proj_code} = "murd1"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 lat_2 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::murd1::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # murd2 # package # hide from PAUSE PDL::Transform::Proj4::murd2; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::murd2::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Murdoch II"; $self->{proj_code} = "murd2"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 lat_2 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::murd2::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # murd3 # package # hide from PAUSE PDL::Transform::Proj4::murd3; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::murd3::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Murdoch III"; $self->{proj_code} = "murd3"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 lat_2 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::murd3::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # natearth # package # hide from PAUSE PDL::Transform::Proj4::natearth; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::natearth::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Natural Earth"; $self->{proj_code} = "natearth"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::natearth::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # natearth2 # package # hide from PAUSE PDL::Transform::Proj4::natearth2; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::natearth2::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Natural Earth 2"; $self->{proj_code} = "natearth2"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::natearth2::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # nell # package # hide from PAUSE PDL::Transform::Proj4::nell; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::nell::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Nell"; $self->{proj_code} = "nell"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::nell::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # nell_h # package # hide from PAUSE PDL::Transform::Proj4::nell_h; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::nell_h::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Nell-Hammer"; $self->{proj_code} = "nell_h"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::nell_h::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # nicol # package # hide from PAUSE PDL::Transform::Proj4::nicol; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::nicol::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Nicolosi Globular"; $self->{proj_code} = "nicol"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::nicol::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # noop # package # hide from PAUSE PDL::Transform::Proj4::noop; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::noop::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "No operation"; $self->{proj_code} = "noop"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::noop::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # nsper # package # hide from PAUSE PDL::Transform::Proj4::nsper; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::nsper::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Near-sided perspective"; $self->{proj_code} = "nsper"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( h ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::nsper::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # nzmg # package # hide from PAUSE PDL::Transform::Proj4::nzmg; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::nzmg::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "New Zealand Map Grid"; $self->{proj_code} = "nzmg"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::nzmg::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # ob_tran # package # hide from PAUSE PDL::Transform::Proj4::ob_tran; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::ob_tran::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "General Oblique Transformation"; $self->{proj_code} = "ob_tran"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( 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 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::ob_tran::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # ocea # package # hide from PAUSE PDL::Transform::Proj4::ocea; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::ocea::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Oblique Cylindrical Equal Area"; $self->{proj_code} = "ocea"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 lat_2 lon_1 lon_2 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::ocea::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # oea # package # hide from PAUSE PDL::Transform::Proj4::oea; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::oea::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Oblated Equal Area"; $self->{proj_code} = "oea"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( n m theta ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::oea::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # omerc # package # hide from PAUSE PDL::Transform::Proj4::omerc; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::omerc::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Oblique Mercator"; $self->{proj_code} = "omerc"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( alpha gamma no_off lonc lon_1 lat_1 lon_2 lat_2 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::omerc::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # ortel # package # hide from PAUSE PDL::Transform::Proj4::ortel; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::ortel::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Ortelius Oval"; $self->{proj_code} = "ortel"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::ortel::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # ortho # package # hide from PAUSE PDL::Transform::Proj4::ortho; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::ortho::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Orthographic"; $self->{proj_code} = "ortho"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::ortho::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # patterson # package # hide from PAUSE PDL::Transform::Proj4::patterson; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::patterson::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Patterson Cylindrical"; $self->{proj_code} = "patterson"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::patterson::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # pconic # package # hide from PAUSE PDL::Transform::Proj4::pconic; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::pconic::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Perspective Conic"; $self->{proj_code} = "pconic"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 lat_2 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::pconic::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # peirce_q # package # hide from PAUSE PDL::Transform::Proj4::peirce_q; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::peirce_q::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Peirce Quincuncial"; $self->{proj_code} = "peirce_q"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::peirce_q::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # pipeline # package # hide from PAUSE PDL::Transform::Proj4::pipeline; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::pipeline::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Transformation pipeline manager"; $self->{proj_code} = "pipeline"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::pipeline::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # poly # package # hide from PAUSE PDL::Transform::Proj4::poly; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::poly::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Polyconic (American)"; $self->{proj_code} = "poly"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::poly::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # pop # package # hide from PAUSE PDL::Transform::Proj4::pop; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::pop::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Retrieve coordinate value from pipeline stack"; $self->{proj_code} = "pop"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::pop::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # push # package # hide from PAUSE PDL::Transform::Proj4::push; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::push::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Save coordinate value on pipeline stack"; $self->{proj_code} = "push"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::push::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # putp1 # package # hide from PAUSE PDL::Transform::Proj4::putp1; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::putp1::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Putnins P1"; $self->{proj_code} = "putp1"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::putp1::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # putp2 # package # hide from PAUSE PDL::Transform::Proj4::putp2; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::putp2::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Putnins P2"; $self->{proj_code} = "putp2"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::putp2::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # putp3 # package # hide from PAUSE PDL::Transform::Proj4::putp3; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::putp3::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Putnins P3"; $self->{proj_code} = "putp3"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::putp3::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # putp3p # package # hide from PAUSE PDL::Transform::Proj4::putp3p; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::putp3p::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Putnins P3'"; $self->{proj_code} = "putp3p"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::putp3p::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # putp4p # package # hide from PAUSE PDL::Transform::Proj4::putp4p; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::putp4p::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Putnins P4'"; $self->{proj_code} = "putp4p"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::putp4p::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # putp5 # package # hide from PAUSE PDL::Transform::Proj4::putp5; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::putp5::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Putnins P5"; $self->{proj_code} = "putp5"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::putp5::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # putp5p # package # hide from PAUSE PDL::Transform::Proj4::putp5p; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::putp5p::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Putnins P5'"; $self->{proj_code} = "putp5p"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::putp5p::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # putp6 # package # hide from PAUSE PDL::Transform::Proj4::putp6; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::putp6::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Putnins P6"; $self->{proj_code} = "putp6"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::putp6::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # putp6p # package # hide from PAUSE PDL::Transform::Proj4::putp6p; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::putp6p::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Putnins P6'"; $self->{proj_code} = "putp6p"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::putp6p::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # qsc # package # hide from PAUSE PDL::Transform::Proj4::qsc; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::qsc::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Quadrilateralized Spherical Cube"; $self->{proj_code} = "qsc"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::qsc::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # qua_aut # package # hide from PAUSE PDL::Transform::Proj4::qua_aut; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::qua_aut::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Quartic Authalic"; $self->{proj_code} = "qua_aut"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::qua_aut::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # rhealpix # package # hide from PAUSE PDL::Transform::Proj4::rhealpix; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::rhealpix::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "rHEALPix"; $self->{proj_code} = "rhealpix"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( north_square south_square ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::rhealpix::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # robin # package # hide from PAUSE PDL::Transform::Proj4::robin; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::robin::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Robinson"; $self->{proj_code} = "robin"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::robin::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # rouss # package # hide from PAUSE PDL::Transform::Proj4::rouss; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::rouss::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Roussilhe Stereographic"; $self->{proj_code} = "rouss"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::rouss::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # rpoly # package # hide from PAUSE PDL::Transform::Proj4::rpoly; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::rpoly::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Rectangular Polyconic"; $self->{proj_code} = "rpoly"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_ts ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::rpoly::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # s2 # package # hide from PAUSE PDL::Transform::Proj4::s2; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::s2::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "S2"; $self->{proj_code} = "s2"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::s2::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # sch # package # hide from PAUSE PDL::Transform::Proj4::sch; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::sch::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Spherical Cross-track Height"; $self->{proj_code} = "sch"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( plat_0 plon_0 phdg_0 h_0 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::sch::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # set # package # hide from PAUSE PDL::Transform::Proj4::set; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::set::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Set coordinate value"; $self->{proj_code} = "set"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::set::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # sinu # package # hide from PAUSE PDL::Transform::Proj4::sinu; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::sinu::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Sinusoidal (Sanson-Flamsteed)"; $self->{proj_code} = "sinu"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::sinu::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # somerc # package # hide from PAUSE PDL::Transform::Proj4::somerc; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::somerc::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Swiss. Obl. Mercator"; $self->{proj_code} = "somerc"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::somerc::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # stere # package # hide from PAUSE PDL::Transform::Proj4::stere; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::stere::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Stereographic"; $self->{proj_code} = "stere"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_ts ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::stere::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # sterea # package # hide from PAUSE PDL::Transform::Proj4::sterea; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::sterea::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Oblique Stereographic Alternative"; $self->{proj_code} = "sterea"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::sterea::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # tcc # package # hide from PAUSE PDL::Transform::Proj4::tcc; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::tcc::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Transverse Central Cylindrical"; $self->{proj_code} = "tcc"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::tcc::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # tcea # package # hide from PAUSE PDL::Transform::Proj4::tcea; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::tcea::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Transverse Cylindrical Equal Area"; $self->{proj_code} = "tcea"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::tcea::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # times # package # hide from PAUSE PDL::Transform::Proj4::times; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::times::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Times"; $self->{proj_code} = "times"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::times::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # tinshift # package # hide from PAUSE PDL::Transform::Proj4::tinshift; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::tinshift::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Triangulation based transformation"; $self->{proj_code} = "tinshift"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::tinshift::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # tissot # package # hide from PAUSE PDL::Transform::Proj4::tissot; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::tissot::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Tissot"; $self->{proj_code} = "tissot"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 lat_2 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::tissot::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # tmerc # package # hide from PAUSE PDL::Transform::Proj4::tmerc; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::tmerc::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Transverse Mercator"; $self->{proj_code} = "tmerc"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( approx ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::tmerc::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # tobmerc # package # hide from PAUSE PDL::Transform::Proj4::tobmerc; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::tobmerc::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Tobler-Mercator"; $self->{proj_code} = "tobmerc"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::tobmerc::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # topocentric # package # hide from PAUSE PDL::Transform::Proj4::topocentric; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::topocentric::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Geocentric/Topocentric conversion"; $self->{proj_code} = "topocentric"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::topocentric::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # tpeqd # package # hide from PAUSE PDL::Transform::Proj4::tpeqd; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::tpeqd::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Two Point Equidistant"; $self->{proj_code} = "tpeqd"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 lon_1 lat_2 lon_2 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::tpeqd::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # tpers # package # hide from PAUSE PDL::Transform::Proj4::tpers; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::tpers::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Tilted perspective"; $self->{proj_code} = "tpers"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( tilt azi h ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::tpers::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # unitconvert # package # hide from PAUSE PDL::Transform::Proj4::unitconvert; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::unitconvert::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Unit conversion"; $self->{proj_code} = "unitconvert"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::unitconvert::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # ups # package # hide from PAUSE PDL::Transform::Proj4::ups; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::ups::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Universal Polar Stereographic"; $self->{proj_code} = "ups"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( south ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::ups::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # urm5 # package # hide from PAUSE PDL::Transform::Proj4::urm5; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::urm5::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Urmaev V"; $self->{proj_code} = "urm5"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( n q alpha ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::urm5::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # urmfps # package # hide from PAUSE PDL::Transform::Proj4::urmfps; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::urmfps::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Urmaev Flat-Polar Sinusoidal"; $self->{proj_code} = "urmfps"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( n ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::urmfps::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # utm # package # hide from PAUSE PDL::Transform::Proj4::utm; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::utm::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Universal Transverse Mercator (UTM)"; $self->{proj_code} = "utm"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( zone south approx ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::utm::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # vandg # package # hide from PAUSE PDL::Transform::Proj4::vandg; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::vandg::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "van der Grinten (I)"; $self->{proj_code} = "vandg"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::vandg::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # vandg2 # package # hide from PAUSE PDL::Transform::Proj4::vandg2; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::vandg2::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "van der Grinten II"; $self->{proj_code} = "vandg2"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::vandg2::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # vandg3 # package # hide from PAUSE PDL::Transform::Proj4::vandg3; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::vandg3::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "van der Grinten III"; $self->{proj_code} = "vandg3"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::vandg3::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # vandg4 # package # hide from PAUSE PDL::Transform::Proj4::vandg4; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::vandg4::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "van der Grinten IV"; $self->{proj_code} = "vandg4"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::vandg4::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # vgridshift # package # hide from PAUSE PDL::Transform::Proj4::vgridshift; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::vgridshift::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Vertical grid shift"; $self->{proj_code} = "vgridshift"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::vgridshift::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # vitk1 # package # hide from PAUSE PDL::Transform::Proj4::vitk1; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::vitk1::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Vitkovsky I"; $self->{proj_code} = "vitk1"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 lat_2 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::vitk1::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # wag1 # package # hide from PAUSE PDL::Transform::Proj4::wag1; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::wag1::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Wagner I (Kavraisky VI)"; $self->{proj_code} = "wag1"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::wag1::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # wag2 # package # hide from PAUSE PDL::Transform::Proj4::wag2; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::wag2::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Wagner II"; $self->{proj_code} = "wag2"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::wag2::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # wag3 # package # hide from PAUSE PDL::Transform::Proj4::wag3; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::wag3::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Wagner III"; $self->{proj_code} = "wag3"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_ts ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::wag3::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # wag4 # package # hide from PAUSE PDL::Transform::Proj4::wag4; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::wag4::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Wagner IV"; $self->{proj_code} = "wag4"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::wag4::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # wag5 # package # hide from PAUSE PDL::Transform::Proj4::wag5; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::wag5::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Wagner V"; $self->{proj_code} = "wag5"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::wag5::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # wag6 # package # hide from PAUSE PDL::Transform::Proj4::wag6; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::wag6::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Wagner VI"; $self->{proj_code} = "wag6"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::wag6::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # wag7 # package # hide from PAUSE PDL::Transform::Proj4::wag7; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::wag7::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Wagner VII"; $self->{proj_code} = "wag7"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::wag7::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # webmerc # package # hide from PAUSE PDL::Transform::Proj4::webmerc; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::webmerc::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Web Mercator / Pseudo Mercator"; $self->{proj_code} = "webmerc"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::webmerc::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # weren # package # hide from PAUSE PDL::Transform::Proj4::weren; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::weren::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Werenskiold I"; $self->{proj_code} = "weren"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::weren::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # wink1 # package # hide from PAUSE PDL::Transform::Proj4::wink1; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::wink1::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Winkel I"; $self->{proj_code} = "wink1"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_ts ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::wink1::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # wink2 # package # hide from PAUSE PDL::Transform::Proj4::wink2; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::wink2::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Winkel II"; $self->{proj_code} = "wink2"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::wink2::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # wintri # package # hide from PAUSE PDL::Transform::Proj4::wintri; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::wintri::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Winkel Tripel"; $self->{proj_code} = "wintri"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( lat_1 ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::wintri::new()... 1; #line 379 "Proj4.pd" # Autogenerated code for the Proj4 projection code: # xyzgridshift # package # hide from PAUSE PDL::Transform::Proj4::xyzgridshift; use strict; use warnings; our @ISA = ( 'PDL::Transform::Proj4' ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $sub = "PDL::Transform::Proj4::xyzgridshift::new()"; #print STDERR "$sub: ARGS: [" . join(", ", @_ ) . "]\n"; 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} = "Geocentric grid shift"; $self->{proj_code} = "xyzgridshift"; # Make sure proj is set in the options: $self->{params}->{proj} = $self->{proj_code}; # Grab our projection specific options: # $self->{projection_params} = [ qw( ) ]; foreach my $param ( @{ $self->{projection_params} } ) { $self->{params}->{$param} = PDL::Transform::_opt( $o, [ $param ] ); } $self->update_proj_string(); #my $dd = Data::Dumper->new( [$self->{params}], ["$sub: params"] ); #$dd->Indent(1); #print STDERR $dd->Dump(); #print STDERR "$sub: Final proj_params: \'" . $self->{params}->{proj_params} . "\'\n"; return $self; } # End of PDL::Transform::xyzgridshift::new()... 1; #line 486 "Proj4.pd" =head1 AUTHOR & MAINTAINER Judd Taylor, Orbital Systems, Ltd. judd dot t at orbitalsystems dot com =cut #line 10973 "Proj4.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSLSF/0000755000175000017500000000000014556074560014704 5ustar osboxesosboxesPDL-2.085/GENERATED/PDL/GSLSF/EXPINT.pm0000644000175000017500000001063514556074556016263 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 4 "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 40 "EXPINT.pm" =head1 FUNCTIONS =cut =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 *gsl_sf_expint_E1 = \&PDL::gsl_sf_expint_E1; =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 *gsl_sf_expint_E2 = \&PDL::gsl_sf_expint_E2; =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 *gsl_sf_expint_Ei = \&PDL::gsl_sf_expint_Ei; =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 *gsl_sf_Shi = \&PDL::gsl_sf_Shi; =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 *gsl_sf_Chi = \&PDL::gsl_sf_Chi; =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 *gsl_sf_expint_3 = \&PDL::gsl_sf_expint_3; =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 *gsl_sf_Si = \&PDL::gsl_sf_Si; =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 *gsl_sf_Ci = \&PDL::gsl_sf_Ci; =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 *gsl_sf_atanint = \&PDL::gsl_sf_atanint; #line 138 "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 309 "EXPINT.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSLSF/EXP.pm0000644000175000017500000000440214556074556015703 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 4 "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 40 "EXP.pm" =head1 FUNCTIONS =cut =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 *gsl_sf_exp = \&PDL::gsl_sf_exp; =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 *gsl_sf_exprel_n = \&PDL::gsl_sf_exprel_n; =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 *gsl_sf_exp_err = \&PDL::gsl_sf_exp_err; #line 65 "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 147 "EXP.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSLSF/HYPERG.pm0000644000175000017500000001154514556074557016254 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 4 "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 40 "HYPERG.pm" =head1 FUNCTIONS =cut =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 *gsl_sf_hyperg_0F1 = \&PDL::gsl_sf_hyperg_0F1; =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 *gsl_sf_hyperg_1F1 = \&PDL::gsl_sf_hyperg_1F1; =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 *gsl_sf_hyperg_U = \&PDL::gsl_sf_hyperg_U; =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 *gsl_sf_hyperg_2F1 = \&PDL::gsl_sf_hyperg_2F1; =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 *gsl_sf_hyperg_2F1_conj = \&PDL::gsl_sf_hyperg_2F1_conj; =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 *gsl_sf_hyperg_2F1_renorm = \&PDL::gsl_sf_hyperg_2F1_renorm; =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 *gsl_sf_hyperg_2F1_conj_renorm = \&PDL::gsl_sf_hyperg_2F1_conj_renorm; =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 *gsl_sf_hyperg_2F0 = \&PDL::gsl_sf_hyperg_2F0; #line 130 "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 282 "HYPERG.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSLSF/POLY.pm0000644000175000017500000000321714556074557016036 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 4 "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 43 "POLY.pm" =head1 FUNCTIONS =cut =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 *gsl_poly_eval = \&PDL::gsl_poly_eval; #line 41 "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 96 "POLY.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSLSF/GAMMA.pm0000644000175000017500000002101714556074556016072 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 4 "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 40 "GAMMA.pm" =head1 FUNCTIONS =cut =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 *gsl_sf_lngamma = \&PDL::gsl_sf_lngamma; =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 *gsl_sf_gamma = \&PDL::gsl_sf_gamma; =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 *gsl_sf_gammastar = \&PDL::gsl_sf_gammastar; =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 *gsl_sf_gammainv = \&PDL::gsl_sf_gammainv; =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 *gsl_sf_lngamma_complex = \&PDL::gsl_sf_lngamma_complex; =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 *gsl_sf_taylorcoeff = \&PDL::gsl_sf_taylorcoeff; =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 *gsl_sf_fact = \&PDL::gsl_sf_fact; =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 *gsl_sf_doublefact = \&PDL::gsl_sf_doublefact; =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 *gsl_sf_lnfact = \&PDL::gsl_sf_lnfact; =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 *gsl_sf_lndoublefact = \&PDL::gsl_sf_lndoublefact; =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 *gsl_sf_lnchoose = \&PDL::gsl_sf_lnchoose; =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 *gsl_sf_choose = \&PDL::gsl_sf_choose; =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 *gsl_sf_lnpoch = \&PDL::gsl_sf_lnpoch; =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 *gsl_sf_poch = \&PDL::gsl_sf_poch; =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 *gsl_sf_pochrel = \&PDL::gsl_sf_pochrel; =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 *gsl_sf_gamma_inc_Q = \&PDL::gsl_sf_gamma_inc_Q; =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 *gsl_sf_gamma_inc_P = \&PDL::gsl_sf_gamma_inc_P; =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 *gsl_sf_lnbeta = \&PDL::gsl_sf_lnbeta; =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 *gsl_sf_beta = \&PDL::gsl_sf_beta; #line 270 "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 579 "GAMMA.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSLSF/DILOG.pm0000644000175000017500000000401614556074555016105 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 4 "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 40 "DILOG.pm" =head1 FUNCTIONS =cut =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 *gsl_sf_dilog = \&PDL::gsl_sf_dilog; =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 *gsl_sf_complex_dilog = \&PDL::gsl_sf_complex_dilog; #line 54 "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 120 "DILOG.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSLSF/ERF.pm0000644000175000017500000000564114556074556015671 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 4 "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 40 "ERF.pm" =head1 FUNCTIONS =cut =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 *gsl_sf_erfc = \&PDL::gsl_sf_erfc; =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 *gsl_sf_log_erfc = \&PDL::gsl_sf_log_erfc; =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 *gsl_sf_erf = \&PDL::gsl_sf_erf; =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 *gsl_sf_erf_Z = \&PDL::gsl_sf_erf_Z; =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 *gsl_sf_erf_Q = \&PDL::gsl_sf_erf_Q; #line 87 "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 201 "ERF.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSLSF/ELLJAC.pm0000644000175000017500000000304314556074556016201 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 4 "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 40 "ELLJAC.pm" =head1 FUNCTIONS =cut =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 *gsl_sf_elljac = \&PDL::gsl_sf_elljac; #line 35 "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 93 "ELLJAC.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSLSF/COULOMB.pm0000644000175000017500000000647014556074555016355 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 4 "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 42 "COULOMB.pm" =head1 FUNCTIONS =cut =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 *gsl_sf_hydrogenicR = \&PDL::gsl_sf_hydrogenicR; =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 *gsl_sf_coulomb_wave_FGp_array = \&PDL::gsl_sf_coulomb_wave_FGp_array; =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 *gsl_sf_coulomb_wave_sphF_array = \&PDL::gsl_sf_coulomb_wave_sphF_array; =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 *gsl_sf_coulomb_CL_e = \&PDL::gsl_sf_coulomb_CL_e; #line 90 "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 176 "COULOMB.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSLSF/COUPLING.pm0000644000175000017500000000460414556074555016472 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 4 "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 40 "COUPLING.pm" =head1 FUNCTIONS =cut =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 *gsl_sf_coupling_3j = \&PDL::gsl_sf_coupling_3j; =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 *gsl_sf_coupling_6j = \&PDL::gsl_sf_coupling_6j; =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 *gsl_sf_coupling_9j = \&PDL::gsl_sf_coupling_9j; #line 64 "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 147 "COUPLING.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSLSF/ELLINT.pm0000644000175000017500000001331614556074555016241 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 5 "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 40 "ELLINT.pm" =head1 FUNCTIONS =cut =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 *gsl_sf_ellint_Kcomp = \&PDL::gsl_sf_ellint_Kcomp; =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 *gsl_sf_ellint_Ecomp = \&PDL::gsl_sf_ellint_Ecomp; =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 *gsl_sf_ellint_F = \&PDL::gsl_sf_ellint_F; =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 *gsl_sf_ellint_E = \&PDL::gsl_sf_ellint_E; =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 *gsl_sf_ellint_P = \&PDL::gsl_sf_ellint_P; =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 *gsl_sf_ellint_D = \&PDL::gsl_sf_ellint_D; =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 *gsl_sf_ellint_RC = \&PDL::gsl_sf_ellint_RC; =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 *gsl_sf_ellint_RD = \&PDL::gsl_sf_ellint_RD; =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 *gsl_sf_ellint_RF = \&PDL::gsl_sf_ellint_RF; =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 *gsl_sf_ellint_RJ = \&PDL::gsl_sf_ellint_RJ; #line 171 "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 339 "ELLINT.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSLSF/LAGUERRE.pm0000644000175000017500000000302714556074557016460 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 4 "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 40 "LAGUERRE.pm" =head1 FUNCTIONS =cut =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 *gsl_sf_laguerre_n = \&PDL::gsl_sf_laguerre_n; #line 39 "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 93 "LAGUERRE.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSLSF/POW_INT.pm0000644000175000017500000000273314556074557016434 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 4 "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 40 "POW_INT.pm" =head1 FUNCTIONS =cut =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 *gsl_sf_pow_int = \&PDL::gsl_sf_pow_int; #line 42 "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 93 "POW_INT.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSLSF/ELEMENTARY.pm0000644000175000017500000000366014556074555016720 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 4 "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 40 "ELEMENTARY.pm" =head1 FUNCTIONS =cut =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 *gsl_sf_multiply = \&PDL::gsl_sf_multiply; =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 *gsl_sf_multiply_err = \&PDL::gsl_sf_multiply_err; #line 51 "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 120 "ELEMENTARY.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSLSF/CLAUSEN.pm0000644000175000017500000000300714556074555016340 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 4 "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 40 "CLAUSEN.pm" =head1 FUNCTIONS =cut =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 *gsl_sf_clausen = \&PDL::gsl_sf_clausen; #line 39 "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 93 "CLAUSEN.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSLSF/LOG.pm0000644000175000017500000000364314556074557015677 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 4 "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 40 "LOG.pm" =head1 FUNCTIONS =cut =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 *gsl_sf_log = \&PDL::gsl_sf_log; =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 *gsl_sf_complex_log = \&PDL::gsl_sf_complex_log; #line 57 "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 120 "LOG.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSLSF/TRANSPORT.pm0000644000175000017500000000515314556074560016642 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 4 "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 43 "TRANSPORT.pm" =head1 FUNCTIONS =cut =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 *gsl_sf_transport_2 = \&PDL::gsl_sf_transport_2; =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 *gsl_sf_transport_3 = \&PDL::gsl_sf_transport_3; =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 *gsl_sf_transport_4 = \&PDL::gsl_sf_transport_4; =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 *gsl_sf_transport_5 = \&PDL::gsl_sf_transport_5; #line 80 "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 177 "TRANSPORT.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSLSF/AIRY.pm0000644000175000017500000001063414556074554016015 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 4 "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 40 "AIRY.pm" =head1 FUNCTIONS =cut =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 *gsl_sf_airy_Ai = \&PDL::gsl_sf_airy_Ai; =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 *gsl_sf_airy_Bi = \&PDL::gsl_sf_airy_Bi; =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 *gsl_sf_airy_Ai_scaled = \&PDL::gsl_sf_airy_Ai_scaled; =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 *gsl_sf_airy_Bi_scaled = \&PDL::gsl_sf_airy_Bi_scaled; =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 *gsl_sf_airy_Ai_deriv = \&PDL::gsl_sf_airy_Ai_deriv; =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 *gsl_sf_airy_Bi_deriv = \&PDL::gsl_sf_airy_Bi_deriv; =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 *gsl_sf_airy_Ai_deriv_scaled = \&PDL::gsl_sf_airy_Ai_deriv_scaled; =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 *gsl_sf_airy_Bi_deriv_scaled = \&PDL::gsl_sf_airy_Bi_deriv_scaled; #line 63 "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 282 "AIRY.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSLSF/DAWSON.pm0000644000175000017500000000300314556074555016235 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 4 "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 42 "DAWSON.pm" =head1 FUNCTIONS =cut =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 *gsl_sf_dawson = \&PDL::gsl_sf_dawson; #line 42 "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 95 "DAWSON.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSLSF/TRIG.pm0000644000175000017500000001503114556074560016007 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 4 "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 40 "TRIG.pm" =head1 FUNCTIONS =cut =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 *gsl_sf_sin = \&PDL::gsl_sf_sin; =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 *gsl_sf_cos = \&PDL::gsl_sf_cos; =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 *gsl_sf_hypot = \&PDL::gsl_sf_hypot; =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 *gsl_sf_complex_sin = \&PDL::gsl_sf_complex_sin; =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 *gsl_sf_complex_cos = \&PDL::gsl_sf_complex_cos; =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 *gsl_sf_complex_logsin = \&PDL::gsl_sf_complex_logsin; =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 *gsl_sf_lnsinh = \&PDL::gsl_sf_lnsinh; =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 *gsl_sf_lncosh = \&PDL::gsl_sf_lncosh; =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 *gsl_sf_polar_to_rect = \&PDL::gsl_sf_polar_to_rect; =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 *gsl_sf_rect_to_polar = \&PDL::gsl_sf_rect_to_polar; =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 *gsl_sf_angle_restrict_symm = \&PDL::gsl_sf_angle_restrict_symm; =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 *gsl_sf_angle_restrict_pos = \&PDL::gsl_sf_angle_restrict_pos; =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 *gsl_sf_sin_err = \&PDL::gsl_sf_sin_err; =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 *gsl_sf_cos_err = \&PDL::gsl_sf_cos_err; #line 203 "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 444 "TRIG.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSLSF/FERMI_DIRAC.pm0000644000175000017500000000665314556074556017025 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 4 "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 49 "FERMI_DIRAC.pm" =head1 FUNCTIONS =cut =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 *gsl_sf_fermi_dirac_int = \&PDL::gsl_sf_fermi_dirac_int; =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 *gsl_sf_fermi_dirac_mhalf = \&PDL::gsl_sf_fermi_dirac_mhalf; =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 *gsl_sf_fermi_dirac_half = \&PDL::gsl_sf_fermi_dirac_half; =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 *gsl_sf_fermi_dirac_3half = \&PDL::gsl_sf_fermi_dirac_3half; =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 *gsl_sf_fermi_dirac_inc_0 = \&PDL::gsl_sf_fermi_dirac_inc_0; #line 100 "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 210 "FERMI_DIRAC.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSLSF/PSI.pm0000644000175000017500000000433614556074557015711 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 4 "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 44 "PSI.pm" =head1 FUNCTIONS =cut =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 *gsl_sf_psi = \&PDL::gsl_sf_psi; =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 *gsl_sf_psi_1piy = \&PDL::gsl_sf_psi_1piy; =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 *gsl_sf_psi_n = \&PDL::gsl_sf_psi_n; #line 69 "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 151 "PSI.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSLSF/GEGENBAUER.pm0000644000175000017500000000374114556074556016660 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 4 "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 40 "GEGENBAUER.pm" =head1 FUNCTIONS =cut =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 *gsl_sf_gegenpoly_n = \&PDL::gsl_sf_gegenpoly_n; =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 *gsl_sf_gegenpoly_array = \&PDL::gsl_sf_gegenpoly_array; #line 49 "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 120 "GEGENBAUER.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSLSF/DEBYE.pm0000644000175000017500000000514114556074555016077 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 4 "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 40 "DEBYE.pm" =head1 FUNCTIONS =cut =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 *gsl_sf_debye_1 = \&PDL::gsl_sf_debye_1; =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 *gsl_sf_debye_2 = \&PDL::gsl_sf_debye_2; =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 *gsl_sf_debye_3 = \&PDL::gsl_sf_debye_3; =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 *gsl_sf_debye_4 = \&PDL::gsl_sf_debye_4; #line 74 "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 174 "DEBYE.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSLSF/SYNCHROTRON.pm0000644000175000017500000000400014556074557017072 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 4 "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 40 "SYNCHROTRON.pm" =head1 FUNCTIONS =cut =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 *gsl_sf_synchrotron_1 = \&PDL::gsl_sf_synchrotron_1; =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 *gsl_sf_synchrotron_2 = \&PDL::gsl_sf_synchrotron_2; #line 50 "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 120 "SYNCHROTRON.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSLSF/LEGENDRE.pm0000644000175000017500000002064514556074557016444 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 5 "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 40 "LEGENDRE.pm" =head1 FUNCTIONS =cut =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 *gsl_sf_legendre_Pl = \&PDL::gsl_sf_legendre_Pl; =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 *gsl_sf_legendre_Pl_array = \&PDL::gsl_sf_legendre_Pl_array; =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 *gsl_sf_legendre_Ql = \&PDL::gsl_sf_legendre_Ql; =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 *gsl_sf_legendre_Plm = \&PDL::gsl_sf_legendre_Plm; =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 '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). =item 'P' (or any other) for unnormalized associated Legendre polynomials P_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 *gsl_sf_legendre_array = \&PDL::gsl_sf_legendre_array; =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 *gsl_sf_legendre_array_index = \&PDL::gsl_sf_legendre_array_index; =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 *gsl_sf_legendre_sphPlm = \&PDL::gsl_sf_legendre_sphPlm; =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 *gsl_sf_conicalP_half = \&PDL::gsl_sf_conicalP_half; =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 *gsl_sf_conicalP_mhalf = \&PDL::gsl_sf_conicalP_mhalf; =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 *gsl_sf_conicalP_0 = \&PDL::gsl_sf_conicalP_0; =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 *gsl_sf_conicalP_1 = \&PDL::gsl_sf_conicalP_1; =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 *gsl_sf_conicalP_sph_reg = \&PDL::gsl_sf_conicalP_sph_reg; =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 *gsl_sf_conicalP_cyl_reg_e = \&PDL::gsl_sf_conicalP_cyl_reg_e; =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 *gsl_sf_legendre_H3d = \&PDL::gsl_sf_legendre_H3d; =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 *gsl_sf_legendre_H3d_array = \&PDL::gsl_sf_legendre_H3d_array; #line 302 "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 501 "LEGENDRE.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSLSF/ZETA.pm0000644000175000017500000000433214556074560016007 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 4 "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 40 "ZETA.pm" =head1 FUNCTIONS =cut =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 *gsl_sf_zeta = \&PDL::gsl_sf_zeta; =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 *gsl_sf_hzeta = \&PDL::gsl_sf_hzeta; =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 *gsl_sf_eta = \&PDL::gsl_sf_eta; #line 63 "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 147 "ZETA.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSLSF/BESSEL.pm0000644000175000017500000003111514556074555016224 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 4 "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 40 "BESSEL.pm" =head1 FUNCTIONS =cut =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 *gsl_sf_bessel_Jn = \&PDL::gsl_sf_bessel_Jn; =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 *gsl_sf_bessel_Jn_array = \&PDL::gsl_sf_bessel_Jn_array; =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 *gsl_sf_bessel_Yn = \&PDL::gsl_sf_bessel_Yn; =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 *gsl_sf_bessel_Yn_array = \&PDL::gsl_sf_bessel_Yn_array; =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 *gsl_sf_bessel_In = \&PDL::gsl_sf_bessel_In; =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 *gsl_sf_bessel_I_array = \&PDL::gsl_sf_bessel_I_array; =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 *gsl_sf_bessel_In_scaled = \&PDL::gsl_sf_bessel_In_scaled; =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 *gsl_sf_bessel_In_scaled_array = \&PDL::gsl_sf_bessel_In_scaled_array; =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 *gsl_sf_bessel_Kn = \&PDL::gsl_sf_bessel_Kn; =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 *gsl_sf_bessel_K_array = \&PDL::gsl_sf_bessel_K_array; =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 *gsl_sf_bessel_Kn_scaled = \&PDL::gsl_sf_bessel_Kn_scaled; =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 *gsl_sf_bessel_Kn_scaled_array = \&PDL::gsl_sf_bessel_Kn_scaled_array; =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 *gsl_sf_bessel_jl = \&PDL::gsl_sf_bessel_jl; =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 *gsl_sf_bessel_jl_array = \&PDL::gsl_sf_bessel_jl_array; =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 *gsl_sf_bessel_yl = \&PDL::gsl_sf_bessel_yl; =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 *gsl_sf_bessel_yl_array = \&PDL::gsl_sf_bessel_yl_array; =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 *gsl_sf_bessel_il_scaled = \&PDL::gsl_sf_bessel_il_scaled; =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 *gsl_sf_bessel_il_scaled_array = \&PDL::gsl_sf_bessel_il_scaled_array; =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 *gsl_sf_bessel_kl_scaled = \&PDL::gsl_sf_bessel_kl_scaled; =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 *gsl_sf_bessel_kl_scaled_array = \&PDL::gsl_sf_bessel_kl_scaled_array; =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 *gsl_sf_bessel_Jnu = \&PDL::gsl_sf_bessel_Jnu; =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 *gsl_sf_bessel_Ynu = \&PDL::gsl_sf_bessel_Ynu; =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 *gsl_sf_bessel_Inu_scaled = \&PDL::gsl_sf_bessel_Inu_scaled; =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 *gsl_sf_bessel_Inu = \&PDL::gsl_sf_bessel_Inu; =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 *gsl_sf_bessel_Knu_scaled = \&PDL::gsl_sf_bessel_Knu_scaled; =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 *gsl_sf_bessel_Knu = \&PDL::gsl_sf_bessel_Knu; =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 *gsl_sf_bessel_lnKnu = \&PDL::gsl_sf_bessel_lnKnu; #line 349 "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 795 "BESSEL.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/Slices.pm0000644000175000017500000014231214556074547015616 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::Slices; our @EXPORT_OK = qw(index index1d index2d indexND indexNDb rangeb rld rle rlevec rldvec rleseq rldseq rleND rldND _clump_int xchg mv using diagonal lags splitdim rotate broadcastI unbroadcast 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 5 "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 =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 broadcast slightly differently. =over 3 =item * C uses direct broadcasting for 1-D indexing across the 0 dim of C<$source>. It can broadcast over source broadcast dims or index broadcast 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 broadcasting 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 broadcasting 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 broadcasting: 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 *index = \&PDL::index; =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 broadcast slightly differently. =over 3 =item * C uses direct broadcasting for 1-D indexing across the 0 dim of C<$source>. It can broadcast over source broadcast dims or index broadcast 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 broadcasting 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 broadcasting 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 broadcasting: 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 *index1d = \&PDL::index1d; =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 broadcast slightly differently. =over 3 =item * C uses direct broadcasting for 1-D indexing across the 0 dim of C<$source>. It can broadcast over source broadcast dims or index broadcast 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 broadcasting 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 broadcasting 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 broadcasting: 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 *index2d = \&PDL::index2d; #line 241 "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 293 "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 440 "Slices.pm" =head2 rangeb =for sig Signature: (P(); C(); pdl *ind_pdl; SV *size_sv; 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 broadcasts over both C<$index> and C<$source>. Because implicit broadcasting can happen in a couple of ways, a little thought is needed. The returned dimension list is stacked up like this: (index broadcast dims), (index dims (size)), (source broadcast 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, broadcasted 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 broadcast dims, because adding more dims to C<$source> just tacks extra dims on the end of the output. Each source broadcast 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) # Broadcast 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 = PDL::RandVar->new->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); $x($_ - 1) .= $_ for 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 broadcast 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. =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 *rangeb = \&PDL::rangeb; =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 1045 "slices.pd" sub PDL::rld { my ($x,$y) = @_; my ($c); if ($#_ == 2) { $c = $_[2]; } else { # XXX Need to improve emulation of broadcasting 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 767 "Slices.pm" *rld = \&PDL::rld; =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 broadcast 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 1096 "slices.pd" 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 839 "Slices.pm" *rle = \&PDL::rle; =head2 rlevec =for sig Signature: (c(M,N); indx [o]a(N); [o]b(M,N)) =for ref Run-length encode a set of vectors. Higher-order rle(), for use with qsortvec(). Given set of vectors $c, generate a vector $a with the number of occurrences of each element (where an "element" is a vector of length $M occurring in $c), and a set of vectors $b containing the unique values. As for rle(), only the elements up to the first instance of 0 in $a should be considered. Can be used together with clump() to run-length encode "values" of arbitrary dimensions. Can be used together with rotate(), cat(), append(), and qsortvec() to count N-grams over a 1d PDL. See also: L, L, L Contributed by Bryan Jurish Emoocow@cpan.orgE. =for bad rlevec 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 *rlevec = \&PDL::rlevec; =head2 rldvec =for sig Signature: (indx a(N); b(M,N); [o]c(M,N)) =for ref Run-length decode a set of vectors, akin to a higher-order rld(). Given a vector $a() of the number of occurrences of each row, and a set $c() of row-vectors each of length $M, run-length decode to $c(). Can be used together with clump() to run-length decode "values" of arbitrary dimensions. See also: L. Contributed by Bryan Jurish Emoocow@cpan.orgE. =for bad rldvec 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 1221 "slices.pd" sub PDL::rldvec { my ($a,$b,$c) = @_; if (!defined($c)) { # XXX Need to improve emulation of threading in auto-generating c my ($rowlen) = $b->dim(0); my ($size) = $a->sumover->max; my (undef, @dims) = $a->dims; $c = $b->zeroes($b->type,$rowlen,$size,@dims); } &PDL::_rldvec_int($a,$b,$c); return $c; } #line 931 "Slices.pm" *rldvec = \&PDL::rldvec; =head2 rleseq =for sig Signature: (c(N); indx [o]a(N); [o]b(N)) =for ref Run-length encode a vector of subsequences. Given a vector of $c() of concatenated variable-length, variable-offset subsequences, generate a vector $a containing the length of each subsequence and a vector $b containing the subsequence offsets. As for rle(), only the elements up to the first instance of 0 in $a should be considered. See also L. Contributed by Bryan Jurish Emoocow@cpan.orgE. =for bad rleseq 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 *rleseq = \&PDL::rleseq; =head2 rldseq =for sig Signature: (indx a(N); b(N); [o]c(M)) =for ref Run-length decode a subsequence vector. Given a vector $a() of sequence lengths and a vector $b() of corresponding offsets, decode concatenation of subsequences to $c(), as for: $c = null; $c = $c->append($b($_)+sequence($a->type,$a($_))) foreach (0..($N-1)); See also: L. Contributed by Bryan Jurish Emoocow@cpan.orgE. =for bad rldseq 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 1299 "slices.pd" sub PDL::rldseq { my ($a,$b,$c) = @_; if (!defined($c)) { my $size = $a->sumover->max; my (undef, @dims) = $a->dims; $c = $b->zeroes($b->type,$size,@dims); } &PDL::_rldseq_int($a,$b,$c); return $c; } #line 1018 "Slices.pm" *rldseq = \&PDL::rldseq; #line 1338 "slices.pd" =head2 rleND =for sig Signature: (data(@vdims,N); int [o]counts(N); [o]elts(@vdims,N)) =for ref Run-length encode a set of (sorted) n-dimensional values. Generalization of rle() and vv_rlevec(): given set of values $data, generate a vector $counts with the number of occurrences of each element (where an "element" is a matrix of dimensions @vdims occurring as a sequential run over the final dimension in $data), and a set of vectors $elts containing the elements which begin a run. Really just a wrapper for clump() and rlevec(). See also: L, L. Contributed by Bryan Jurish Emoocow@cpan.orgE. =cut *PDL::rleND = \&rleND; sub rleND { my $data = shift; my @vdimsN = $data->dims; ##-- construct output pdls my $counts = $#_ >= 0 ? $_[0] : zeroes(long, $vdimsN[$#vdimsN]); my $elts = $#_ >= 1 ? $_[1] : zeroes($data->type, @vdimsN); ##-- guts: call rlevec() rlevec($data->clump($#vdimsN), $counts, $elts->clump($#vdimsN)); return ($counts,$elts); } =head2 rldND =for sig Signature: (int counts(N); elts(@vdims,N); [o]data(@vdims,N);) =for ref Run-length decode a set of (sorted) n-dimensional values. Generalization of rld() and rldvec(): given a vector $counts() of the number of occurrences of each @vdims-dimensioned element, and a set $elts() of @vdims-dimensioned elements, run-length decode to $data(). Really just a wrapper for clump() and rldvec(). See also: L, L. Contributed by Bryan Jurish Emoocow@cpan.orgE. =cut *PDL::rldND = \&rldND; sub rldND { my ($counts,$elts) = (shift,shift); my @vdimsN = $elts->dims; ##-- construct output pdl my ($data); if ($#_ >= 0) { $data = $_[0]; } else { my $size = $counts->sumover->max; ##-- get maximum size for Nth-dimension for small encodings my @countdims = $counts->dims; shift(@countdims); $data = zeroes($elts->type, @vdimsN, @countdims); } ##-- guts: call rldvec() rldvec($counts, $elts->clump($#vdimsN), $data->clump($#vdimsN)); return $data; } #line 1105 "Slices.pm" *_clump_int = \&PDL::_clump_int; =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 *xchg = \&PDL::xchg; #line 1497 "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 broadcast() [I think] # a quicker way to do the reorder return $pdl->broadcast(@newDimOrder)->unbroadcast(0); } #line 1273 "Slices.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 *mv = \&PDL::mv; #line 1674 "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 1345 "Slices.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 broadcastids 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 1768 "slices.pd" sub PDL::diagonal { shift->_diagonal_int(my $o=PDL->null, \@_); $o } #line 1410 "Slices.pm" *diagonal = \&PDL::diagonal; =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 *lags = \&PDL::lags; =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). As of 2.076, throws exception if non-divisible C given, and can give negative C which then counts backwards. =for example After $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 *splitdim = \&PDL::splitdim; =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 *rotate = \&PDL::rotate; =head2 broadcastI =for sig Signature: (P(); C(); PDL_Indx id; PDL_Indx whichdims[]) =for ref internal Put some dimensions to a broadcastid. =for example $y = $x->broadcastI(0,1,5); # broadcast over dims 1,5 in id 1 =for bad broadcastI 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 *broadcastI = \&PDL::broadcastI; =head2 unbroadcast =for sig Signature: (P(); C(); PDL_Indx atind) =for ref All broadcasted dimensions are made real again. See [TBD Doc] for details and examples. =for bad unbroadcast 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 *unbroadcast = \&PDL::unbroadcast; #line 2109 "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 = PDL->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 1753 "Slices.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 the 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 2428 "slices.pd" 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). $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 1963 "Slices.pm" *slice = \&PDL::slice; #line 2595 "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 1998 "Slices.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/Minuit.pm0000644000175000017500000004706614556074561015647 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 14 "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. =cut #line 48 "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" =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 *mninit = \&PDL::Minuit::mninit; =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 *mn_abre = \&PDL::Minuit::mn_abre; =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 *mn_cierra = \&PDL::Minuit::mn_cierra; #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 232 "Minuit.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 *mnparm = \&PDL::Minuit::mnparm; #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 288 "Minuit.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 *mnexcm = \&PDL::Minuit::mnexcm; #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 342 "Minuit.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 *mnpout = \&PDL::Minuit::mnpout; #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 385 "Minuit.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 *mnstat = \&PDL::Minuit::mnstat; #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 434 "Minuit.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 *mnemat = \&PDL::Minuit::mnemat; #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 484 "Minuit.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 *mnerrs = \&PDL::Minuit::mnerrs; #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 539 "Minuit.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 *mncont = \&PDL::Minuit::mncont; #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 832 "Minuit.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSL/0000755000175000017500000000000014556074554014456 5ustar osboxesosboxesPDL-2.085/GENERATED/PDL/GSL/RNG.pm0000644000175000017500000013525114556074554015451 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 9 "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 1309 "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 1323 "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 1324 "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 1325 "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 1326 "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 1356 "RNG.pm" *gsl_get_uniform_meat = \&PDL::GSL::RNG::gsl_get_uniform_meat; *gsl_get_uniform_pos_meat = \&PDL::GSL::RNG::gsl_get_uniform_pos_meat; *gsl_get_meat = \&PDL::GSL::RNG::gsl_get_meat; *gsl_get_int_meat = \&PDL::GSL::RNG::gsl_get_int_meat; *ran_gaussian_meat = \&PDL::GSL::RNG::ran_gaussian_meat; #line 1407 "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 1400 "RNG.pm" *ran_gaussian_var_meat = \&PDL::GSL::RNG::ran_gaussian_var_meat; #line 1431 "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 1415 "RNG.pm" *ran_ugaussian_tail_meat = \&PDL::GSL::RNG::ran_ugaussian_tail_meat; #line 1407 "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 1439 "RNG.pm" *ran_ugaussian_tail_var_meat = \&PDL::GSL::RNG::ran_ugaussian_tail_var_meat; #line 1431 "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 1454 "RNG.pm" *ran_exponential_meat = \&PDL::GSL::RNG::ran_exponential_meat; #line 1407 "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 1478 "RNG.pm" *ran_exponential_var_meat = \&PDL::GSL::RNG::ran_exponential_var_meat; #line 1431 "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 1493 "RNG.pm" *ran_laplace_meat = \&PDL::GSL::RNG::ran_laplace_meat; #line 1407 "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 1517 "RNG.pm" *ran_laplace_var_meat = \&PDL::GSL::RNG::ran_laplace_var_meat; #line 1431 "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 1532 "RNG.pm" *ran_exppow_meat = \&PDL::GSL::RNG::ran_exppow_meat; #line 1407 "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 1556 "RNG.pm" *ran_exppow_var_meat = \&PDL::GSL::RNG::ran_exppow_var_meat; #line 1431 "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 1571 "RNG.pm" *ran_cauchy_meat = \&PDL::GSL::RNG::ran_cauchy_meat; #line 1407 "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 1595 "RNG.pm" *ran_cauchy_var_meat = \&PDL::GSL::RNG::ran_cauchy_var_meat; #line 1431 "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 1610 "RNG.pm" *ran_rayleigh_meat = \&PDL::GSL::RNG::ran_rayleigh_meat; #line 1407 "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 1634 "RNG.pm" *ran_rayleigh_var_meat = \&PDL::GSL::RNG::ran_rayleigh_var_meat; #line 1431 "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 1649 "RNG.pm" *ran_rayleigh_tail_meat = \&PDL::GSL::RNG::ran_rayleigh_tail_meat; #line 1407 "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 1673 "RNG.pm" *ran_rayleigh_tail_var_meat = \&PDL::GSL::RNG::ran_rayleigh_tail_var_meat; #line 1431 "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 1688 "RNG.pm" *ran_levy_meat = \&PDL::GSL::RNG::ran_levy_meat; #line 1407 "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 1712 "RNG.pm" *ran_levy_var_meat = \&PDL::GSL::RNG::ran_levy_var_meat; #line 1431 "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 1727 "RNG.pm" *ran_gamma_meat = \&PDL::GSL::RNG::ran_gamma_meat; #line 1407 "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 1751 "RNG.pm" *ran_gamma_var_meat = \&PDL::GSL::RNG::ran_gamma_var_meat; #line 1431 "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 1766 "RNG.pm" *ran_flat_meat = \&PDL::GSL::RNG::ran_flat_meat; #line 1407 "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 1790 "RNG.pm" *ran_flat_var_meat = \&PDL::GSL::RNG::ran_flat_var_meat; #line 1431 "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 1805 "RNG.pm" *ran_lognormal_meat = \&PDL::GSL::RNG::ran_lognormal_meat; #line 1407 "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 1829 "RNG.pm" *ran_lognormal_var_meat = \&PDL::GSL::RNG::ran_lognormal_var_meat; #line 1431 "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 1844 "RNG.pm" *ran_chisq_meat = \&PDL::GSL::RNG::ran_chisq_meat; #line 1407 "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 1868 "RNG.pm" *ran_chisq_var_meat = \&PDL::GSL::RNG::ran_chisq_var_meat; #line 1431 "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 1883 "RNG.pm" *ran_fdist_meat = \&PDL::GSL::RNG::ran_fdist_meat; #line 1407 "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 1907 "RNG.pm" *ran_fdist_var_meat = \&PDL::GSL::RNG::ran_fdist_var_meat; #line 1431 "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 1922 "RNG.pm" *ran_tdist_meat = \&PDL::GSL::RNG::ran_tdist_meat; #line 1407 "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 1946 "RNG.pm" *ran_tdist_var_meat = \&PDL::GSL::RNG::ran_tdist_var_meat; #line 1431 "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 1961 "RNG.pm" *ran_beta_meat = \&PDL::GSL::RNG::ran_beta_meat; #line 1407 "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 1985 "RNG.pm" *ran_beta_var_meat = \&PDL::GSL::RNG::ran_beta_var_meat; #line 1431 "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 2000 "RNG.pm" *ran_logistic_meat = \&PDL::GSL::RNG::ran_logistic_meat; #line 1407 "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 2024 "RNG.pm" *ran_logistic_var_meat = \&PDL::GSL::RNG::ran_logistic_var_meat; #line 1431 "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 2039 "RNG.pm" *ran_pareto_meat = \&PDL::GSL::RNG::ran_pareto_meat; #line 1407 "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 2063 "RNG.pm" *ran_pareto_var_meat = \&PDL::GSL::RNG::ran_pareto_var_meat; #line 1431 "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 2078 "RNG.pm" *ran_weibull_meat = \&PDL::GSL::RNG::ran_weibull_meat; #line 1407 "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 2102 "RNG.pm" *ran_weibull_var_meat = \&PDL::GSL::RNG::ran_weibull_var_meat; #line 1431 "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 2117 "RNG.pm" *ran_gumbel1_meat = \&PDL::GSL::RNG::ran_gumbel1_meat; #line 1407 "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 2141 "RNG.pm" *ran_gumbel1_var_meat = \&PDL::GSL::RNG::ran_gumbel1_var_meat; #line 1431 "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 2156 "RNG.pm" *ran_gumbel2_meat = \&PDL::GSL::RNG::ran_gumbel2_meat; #line 1407 "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 2180 "RNG.pm" *ran_gumbel2_var_meat = \&PDL::GSL::RNG::ran_gumbel2_var_meat; #line 1431 "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 2195 "RNG.pm" *ran_poisson_meat = \&PDL::GSL::RNG::ran_poisson_meat; #line 1407 "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 2219 "RNG.pm" *ran_poisson_var_meat = \&PDL::GSL::RNG::ran_poisson_var_meat; #line 1431 "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 2234 "RNG.pm" *ran_bernoulli_meat = \&PDL::GSL::RNG::ran_bernoulli_meat; #line 1407 "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 2258 "RNG.pm" *ran_bernoulli_var_meat = \&PDL::GSL::RNG::ran_bernoulli_var_meat; #line 1431 "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 2273 "RNG.pm" *ran_binomial_meat = \&PDL::GSL::RNG::ran_binomial_meat; #line 1407 "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 2297 "RNG.pm" *ran_binomial_var_meat = \&PDL::GSL::RNG::ran_binomial_var_meat; #line 1431 "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 2312 "RNG.pm" *ran_negative_binomial_meat = \&PDL::GSL::RNG::ran_negative_binomial_meat; #line 1407 "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 2336 "RNG.pm" *ran_negative_binomial_var_meat = \&PDL::GSL::RNG::ran_negative_binomial_var_meat; #line 1431 "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 2351 "RNG.pm" *ran_pascal_meat = \&PDL::GSL::RNG::ran_pascal_meat; #line 1407 "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 2375 "RNG.pm" *ran_pascal_var_meat = \&PDL::GSL::RNG::ran_pascal_var_meat; #line 1431 "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 2390 "RNG.pm" *ran_geometric_meat = \&PDL::GSL::RNG::ran_geometric_meat; #line 1407 "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 2414 "RNG.pm" *ran_geometric_var_meat = \&PDL::GSL::RNG::ran_geometric_var_meat; #line 1431 "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 2429 "RNG.pm" *ran_hypergeometric_meat = \&PDL::GSL::RNG::ran_hypergeometric_meat; #line 1407 "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 2453 "RNG.pm" *ran_hypergeometric_var_meat = \&PDL::GSL::RNG::ran_hypergeometric_var_meat; #line 1431 "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 2468 "RNG.pm" *ran_logarithmic_meat = \&PDL::GSL::RNG::ran_logarithmic_meat; #line 1407 "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 2492 "RNG.pm" *ran_logarithmic_var_meat = \&PDL::GSL::RNG::ran_logarithmic_var_meat; #line 1431 "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 2507 "RNG.pm" *ran_additive_gaussian_meat = \&PDL::GSL::RNG::ran_additive_gaussian_meat; #line 1521 "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 2525 "RNG.pm" *ran_additive_poisson_meat = \&PDL::GSL::RNG::ran_additive_poisson_meat; #line 1537 "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 2543 "RNG.pm" *ran_feed_poisson_meat = \&PDL::GSL::RNG::ran_feed_poisson_meat; #line 1553 "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 2561 "RNG.pm" *ran_bivariate_gaussian_meat = \&PDL::GSL::RNG::ran_bivariate_gaussian_meat; #line 1574 "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 2579 "RNG.pm" *ran_dir_2d_meat = \&PDL::GSL::RNG::ran_dir_2d_meat; *ran_dir_3d_meat = \&PDL::GSL::RNG::ran_dir_3d_meat; *ran_dir_nd_meat = \&PDL::GSL::RNG::ran_dir_nd_meat; #line 1618 "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 2610 "RNG.pm" *ran_discrete_meat = \&PDL::GSL::RNG::ran_discrete_meat; #line 1638 "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 1655 "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 1669 "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 2661 "RNG.pm" *ran_ver_meat = \&PDL::GSL::RNG::ran_ver_meat; *ran_caos_meat = \&PDL::GSL::RNG::ran_caos_meat; #line 1703 "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 1713 "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 2694 "RNG.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSL/INTEG.pm0000644000175000017500000006555114556074553015675 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 4 "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 133 "INTEG.pm" =head1 FUNCTIONS =cut #line 553 "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 157 "INTEG.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 *qng_meat = \&PDL::qng_meat; #line 585 "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 201 "INTEG.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 *qag_meat = \&PDL::qag_meat; #line 621 "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 244 "INTEG.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 *qags_meat = \&PDL::qags_meat; #line 656 "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 287 "INTEG.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 *qagp_meat = \&PDL::qagp_meat; #line 690 "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 330 "INTEG.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 *qagi_meat = \&PDL::qagi_meat; #line 724 "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 373 "INTEG.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 *qagiu_meat = \&PDL::qagiu_meat; #line 759 "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 416 "INTEG.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 *qagil_meat = \&PDL::qagil_meat; #line 794 "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 459 "INTEG.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 *qawc_meat = \&PDL::qawc_meat; #line 828 "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 502 "INTEG.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 *qaws_meat = \&PDL::qaws_meat; #line 868 "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 553 "INTEG.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 *qawo_meat = \&PDL::qawo_meat; #line 919 "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 602 "INTEG.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 *qawf_meat = \&PDL::qawf_meat; #line 112 "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 1051 "INTEG.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSL/MROOT.pm0000644000175000017500000000512514556074553015716 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 68 "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 68 "MROOT.pm" =head1 FUNCTIONS =cut =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 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; } *gslmroot_fsolver = \&PDL::GSL::MROOT::gslmroot_fsolver; #line 114 "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 140 "MROOT.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSL/DIFF.pm0000644000175000017500000001123714556074553015527 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 4 "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 61 "DIFF.pm" =head1 FUNCTIONS =cut #line 119 "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 95 "DIFF.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 *diff_central = \&PDL::diff_central; =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 *diff_backward = \&PDL::diff_backward; =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 *diff_forward = \&PDL::diff_forward; #line 41 "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 245 "DIFF.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSL/INTERP.pm0000644000175000017500000001537114556074553016023 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 6 "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 64 "INTERP.pm" =head1 FUNCTIONS =cut =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 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); } *init = \&PDL::GSL::INTERP::init; =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 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; } *eval = \&PDL::GSL::INTERP::eval; =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 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; } *deriv = \&PDL::GSL::INTERP::deriv; =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 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; } *deriv2 = \&PDL::GSL::INTERP::deriv2; =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 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; } *integ = \&PDL::GSL::INTERP::integ; #line 45 "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 398 "INTERP.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSL/LINALG.pm0000644000175000017500000000622414556074553015765 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 4 "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 broadcast 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 60 "LINALG.pm" =head1 FUNCTIONS =cut =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 *LU_decomp = \&PDL::LU_decomp; =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 *LU_solve = \&PDL::LU_solve; =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 *LU_det = \&PDL::LU_det; =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 *solve_tridiag = \&PDL::solve_tridiag; #line 40 "gsl_linalg.pd" =head1 SEE ALSO L The GSL documentation for linear algebra is online at L =cut #line 192 "LINALG.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/GSL/CDF.pm0000644000175000017500000011417614556074553015421 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 4 "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 74 "CDF.pm" =head1 FUNCTIONS =cut #line 144 "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 91 "CDF.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 *gsl_cdf_beta_P = \&PDL::gsl_cdf_beta_P; =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 *gsl_cdf_beta_Pinv = \&PDL::gsl_cdf_beta_Pinv; =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 *gsl_cdf_beta_Q = \&PDL::gsl_cdf_beta_Q; =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 *gsl_cdf_beta_Qinv = \&PDL::gsl_cdf_beta_Qinv; #line 144 "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 199 "CDF.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 *gsl_cdf_binomial_P = \&PDL::gsl_cdf_binomial_P; =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 *gsl_cdf_binomial_Q = \&PDL::gsl_cdf_binomial_Q; #line 144 "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 257 "CDF.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 *gsl_cdf_cauchy_P = \&PDL::gsl_cdf_cauchy_P; =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 *gsl_cdf_cauchy_Pinv = \&PDL::gsl_cdf_cauchy_Pinv; =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 *gsl_cdf_cauchy_Q = \&PDL::gsl_cdf_cauchy_Q; =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 *gsl_cdf_cauchy_Qinv = \&PDL::gsl_cdf_cauchy_Qinv; #line 144 "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 365 "CDF.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 *gsl_cdf_chisq_P = \&PDL::gsl_cdf_chisq_P; =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 *gsl_cdf_chisq_Pinv = \&PDL::gsl_cdf_chisq_Pinv; =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 *gsl_cdf_chisq_Q = \&PDL::gsl_cdf_chisq_Q; =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 *gsl_cdf_chisq_Qinv = \&PDL::gsl_cdf_chisq_Qinv; #line 144 "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 473 "CDF.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 *gsl_cdf_exponential_P = \&PDL::gsl_cdf_exponential_P; =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 *gsl_cdf_exponential_Pinv = \&PDL::gsl_cdf_exponential_Pinv; =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 *gsl_cdf_exponential_Q = \&PDL::gsl_cdf_exponential_Q; =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 *gsl_cdf_exponential_Qinv = \&PDL::gsl_cdf_exponential_Qinv; #line 144 "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 581 "CDF.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 *gsl_cdf_exppow_P = \&PDL::gsl_cdf_exppow_P; =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 *gsl_cdf_exppow_Q = \&PDL::gsl_cdf_exppow_Q; #line 144 "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 639 "CDF.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 *gsl_cdf_fdist_P = \&PDL::gsl_cdf_fdist_P; =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 *gsl_cdf_fdist_Pinv = \&PDL::gsl_cdf_fdist_Pinv; =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 *gsl_cdf_fdist_Q = \&PDL::gsl_cdf_fdist_Q; =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 *gsl_cdf_fdist_Qinv = \&PDL::gsl_cdf_fdist_Qinv; #line 144 "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 747 "CDF.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 *gsl_cdf_flat_P = \&PDL::gsl_cdf_flat_P; =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 *gsl_cdf_flat_Pinv = \&PDL::gsl_cdf_flat_Pinv; =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 *gsl_cdf_flat_Q = \&PDL::gsl_cdf_flat_Q; =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 *gsl_cdf_flat_Qinv = \&PDL::gsl_cdf_flat_Qinv; #line 144 "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 855 "CDF.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 *gsl_cdf_gamma_P = \&PDL::gsl_cdf_gamma_P; =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 *gsl_cdf_gamma_Pinv = \&PDL::gsl_cdf_gamma_Pinv; =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 *gsl_cdf_gamma_Q = \&PDL::gsl_cdf_gamma_Q; =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 *gsl_cdf_gamma_Qinv = \&PDL::gsl_cdf_gamma_Qinv; #line 144 "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 963 "CDF.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 *gsl_cdf_gaussian_P = \&PDL::gsl_cdf_gaussian_P; =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 *gsl_cdf_gaussian_Pinv = \&PDL::gsl_cdf_gaussian_Pinv; =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 *gsl_cdf_gaussian_Q = \&PDL::gsl_cdf_gaussian_Q; =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 *gsl_cdf_gaussian_Qinv = \&PDL::gsl_cdf_gaussian_Qinv; #line 144 "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 1071 "CDF.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 *gsl_cdf_geometric_P = \&PDL::gsl_cdf_geometric_P; =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 *gsl_cdf_geometric_Q = \&PDL::gsl_cdf_geometric_Q; #line 144 "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 1129 "CDF.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 *gsl_cdf_gumbel1_P = \&PDL::gsl_cdf_gumbel1_P; =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 *gsl_cdf_gumbel1_Pinv = \&PDL::gsl_cdf_gumbel1_Pinv; =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 *gsl_cdf_gumbel1_Q = \&PDL::gsl_cdf_gumbel1_Q; =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 *gsl_cdf_gumbel1_Qinv = \&PDL::gsl_cdf_gumbel1_Qinv; #line 144 "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 1237 "CDF.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 *gsl_cdf_gumbel2_P = \&PDL::gsl_cdf_gumbel2_P; =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 *gsl_cdf_gumbel2_Pinv = \&PDL::gsl_cdf_gumbel2_Pinv; =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 *gsl_cdf_gumbel2_Q = \&PDL::gsl_cdf_gumbel2_Q; =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 *gsl_cdf_gumbel2_Qinv = \&PDL::gsl_cdf_gumbel2_Qinv; #line 144 "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 1345 "CDF.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 *gsl_cdf_hypergeometric_P = \&PDL::gsl_cdf_hypergeometric_P; =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 *gsl_cdf_hypergeometric_Q = \&PDL::gsl_cdf_hypergeometric_Q; #line 144 "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 1403 "CDF.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 *gsl_cdf_laplace_P = \&PDL::gsl_cdf_laplace_P; =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 *gsl_cdf_laplace_Pinv = \&PDL::gsl_cdf_laplace_Pinv; =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 *gsl_cdf_laplace_Q = \&PDL::gsl_cdf_laplace_Q; =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 *gsl_cdf_laplace_Qinv = \&PDL::gsl_cdf_laplace_Qinv; #line 144 "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 1511 "CDF.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 *gsl_cdf_logistic_P = \&PDL::gsl_cdf_logistic_P; =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 *gsl_cdf_logistic_Pinv = \&PDL::gsl_cdf_logistic_Pinv; =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 *gsl_cdf_logistic_Q = \&PDL::gsl_cdf_logistic_Q; =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 *gsl_cdf_logistic_Qinv = \&PDL::gsl_cdf_logistic_Qinv; #line 144 "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 1619 "CDF.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 *gsl_cdf_lognormal_P = \&PDL::gsl_cdf_lognormal_P; =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 *gsl_cdf_lognormal_Pinv = \&PDL::gsl_cdf_lognormal_Pinv; =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 *gsl_cdf_lognormal_Q = \&PDL::gsl_cdf_lognormal_Q; =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 *gsl_cdf_lognormal_Qinv = \&PDL::gsl_cdf_lognormal_Qinv; =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 *gsl_cdf_negative_binomial_P = \&PDL::gsl_cdf_negative_binomial_P; =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 *gsl_cdf_negative_binomial_Q = \&PDL::gsl_cdf_negative_binomial_Q; #line 144 "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 1777 "CDF.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 *gsl_cdf_pareto_P = \&PDL::gsl_cdf_pareto_P; =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 *gsl_cdf_pareto_Pinv = \&PDL::gsl_cdf_pareto_Pinv; =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 *gsl_cdf_pareto_Q = \&PDL::gsl_cdf_pareto_Q; =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 *gsl_cdf_pareto_Qinv = \&PDL::gsl_cdf_pareto_Qinv; #line 144 "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 1885 "CDF.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 *gsl_cdf_pascal_P = \&PDL::gsl_cdf_pascal_P; =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 *gsl_cdf_pascal_Q = \&PDL::gsl_cdf_pascal_Q; #line 144 "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 1943 "CDF.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 *gsl_cdf_poisson_P = \&PDL::gsl_cdf_poisson_P; =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 *gsl_cdf_poisson_Q = \&PDL::gsl_cdf_poisson_Q; #line 144 "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 2001 "CDF.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 *gsl_cdf_rayleigh_P = \&PDL::gsl_cdf_rayleigh_P; =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 *gsl_cdf_rayleigh_Pinv = \&PDL::gsl_cdf_rayleigh_Pinv; =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 *gsl_cdf_rayleigh_Q = \&PDL::gsl_cdf_rayleigh_Q; =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 *gsl_cdf_rayleigh_Qinv = \&PDL::gsl_cdf_rayleigh_Qinv; #line 144 "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 2109 "CDF.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 *gsl_cdf_tdist_P = \&PDL::gsl_cdf_tdist_P; =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 *gsl_cdf_tdist_Pinv = \&PDL::gsl_cdf_tdist_Pinv; =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 *gsl_cdf_tdist_Q = \&PDL::gsl_cdf_tdist_Q; =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 *gsl_cdf_tdist_Qinv = \&PDL::gsl_cdf_tdist_Qinv; #line 144 "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 2217 "CDF.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 *gsl_cdf_ugaussian_P = \&PDL::gsl_cdf_ugaussian_P; =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 *gsl_cdf_ugaussian_Pinv = \&PDL::gsl_cdf_ugaussian_Pinv; =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 *gsl_cdf_ugaussian_Q = \&PDL::gsl_cdf_ugaussian_Q; =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 *gsl_cdf_ugaussian_Qinv = \&PDL::gsl_cdf_ugaussian_Qinv; #line 144 "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 2325 "CDF.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 *gsl_cdf_weibull_P = \&PDL::gsl_cdf_weibull_P; =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 *gsl_cdf_weibull_Pinv = \&PDL::gsl_cdf_weibull_Pinv; =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 *gsl_cdf_weibull_Q = \&PDL::gsl_cdf_weibull_Q; =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 *gsl_cdf_weibull_Qinv = \&PDL::gsl_cdf_weibull_Qinv; #line 176 "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 2439 "CDF.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/ImageRGB.pm0000644000175000017500000001525014556074561015745 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 9 "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 broadcast/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 broadcasting 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 broadcasting *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 broadcasted 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 broadcasting takes care of this # should already support broadcasting *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 broadcasted 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 broadcasting support ?? (explicit broadcasting?) *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 260 "ImageRGB.pm" *cquant_c = \&PDL::cquant_c; # Exit with OK status 1; PDL-2.085/GENERATED/PDL/Compression.pm0000644000175000017500000001326314556074552016673 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 5 "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 broadcast over other dimensions, producing a broadcasted 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 53 "Compression.pm" =head1 FUNCTIONS =cut #line 74 "compression.pd" =head1 METHODS =cut #line 68 "Compression.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 broadcasted 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 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; } *rice_compress = \&PDL::rice_compress; =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 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; } *rice_expand = \&PDL::rice_expand; #line 35 "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 244 "Compression.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/IO/0000755000175000017500000000000014556074552014336 5ustar osboxesosboxesPDL-2.085/GENERATED/PDL/IO/GD.pm0000644000175000017500000015242314556074551015174 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 22 "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 71 "GD.pm" =head1 FUNCTIONS =cut =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 *write_png = \&PDL::write_png; =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 *write_png_ex = \&PDL::write_png_ex; =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 *write_true_png = \&PDL::write_true_png; =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 *write_true_png_ex = \&PDL::write_true_png_ex; #line 315 "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 389 "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 274 "GD.pm" *_read_true_png = \&PDL::_read_true_png; *_read_png = \&PDL::_read_png; *_gd_image_to_pdl_true = \&PDL::_gd_image_to_pdl_true; *_gd_image_to_pdl = \&PDL::_gd_image_to_pdl; *_pdl_to_gd_image_true = \&PDL::_pdl_to_gd_image_true; *_pdl_to_gd_image_lut = \&PDL::_pdl_to_gd_image_lut; #line 717 "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 322 "GD.pm" *_read_png_lut = \&PDL::_read_png_lut; *_gdImageColorAllocates = \&PDL::_gdImageColorAllocates; *_gdImageColorAllocateAlphas = \&PDL::_gdImageColorAllocateAlphas; *_gdImageSetPixels = \&PDL::_gdImageSetPixels; *_gdImageLines = \&PDL::_gdImageLines; *_gdImageDashedLines = \&PDL::_gdImageDashedLines; *_gdImageRectangles = \&PDL::_gdImageRectangles; *_gdImageFilledRectangles = \&PDL::_gdImageFilledRectangles; *_gdImageFilledArcs = \&PDL::_gdImageFilledArcs; *_gdImageArcs = \&PDL::_gdImageArcs; *_gdImageFilledEllipses = \&PDL::_gdImageFilledEllipses; #line 804 "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 broadcasting 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 1747 "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 1747 "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 1747 "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 1747 "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 1747 "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 1747 "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 1747 "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 1859 "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 1859 "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 1859 "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 1859 "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 1859 "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 1859 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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.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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 1959 "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 2060 "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 2060 "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 2060 "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 2060 "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 2060 "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 2060 "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 2060 "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 2060 "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 2060 "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 2060 "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 2072 "GD.pd" =head1 CLASS FUNCTIONS =cut #line 2142 "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 2142 "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 2142 "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 2142 "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 2142 "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 2142 "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 2142 "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 1468 "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 1521 "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 1553 "GD.pd" =head1 AUTHOR Judd Taylor, Orbital Systems, Ltd. judd dot t at orbitalsystems dot com =cut #line 2913 "GD.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/IO/Pnm.pm0000644000175000017500000002373514556074552015440 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 6 "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 62 "Pnm.pm" =head1 FUNCTIONS =cut =head2 pnminraw =for sig Signature: (type(); byte+ [o] im(m,n); byte [t] buf(llen); 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 *pnminraw = \&PDL::pnminraw; =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 *pnminascii = \&PDL::pnminascii; =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 broadcasting 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 *pnmout = \&PDL::pnmout; #line 44 "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 391 "Pnm.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/IO/Browser.pm0000644000175000017500000000267314556074551016326 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 1 "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 44 "Browser.pm" =head1 FUNCTIONS =cut =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 *browse = \&PDL::browse; #line 56 "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 104 "Browser.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/IO/HDF/0000755000175000017500000000000014556074551014736 5ustar osboxesosboxesPDL-2.085/GENERATED/PDL/IO/HDF/VS.pm0000644000175000017500000003312714556074551015632 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 4 "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 308 "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 ); $vgroup->{$vg_name}->{ref} = $vg_ref; $vgroup->{$vg_name}->{class} = PDL::IO::HDF::VS::_Vgetclass( $vg_id ); 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 = PDL::IO::HDF::VS::_VSgetname( $id ); my $class = PDL::IO::HDF::VS::_VSgetclass( $id ); 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 $n_records = 0; my $interlace = 0; my $fields = ""; my $vdata_size = 0; my $vdata_name = ""; PDL::IO::HDF::VS::_VSinquire( $vdata_id, $n_records, $interlace, $fields, $vdata_size, $vdata_name ); $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 504 "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 519 "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 528 "VS.pd" } # End of Vgetparents()... sub Vgetmains { my ($self) = @_; my @rlist; foreach( sort keys %{$self->{VGROUP}} ) #line 535 "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 617 "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 629 "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 = ""; 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 ); } my $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 752 "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 511 "VS.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/IO/HDF/SD.pm0000644000175000017500000010664514556074551015616 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 3 "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 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 669 "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 711 "SD.pd" } else { return sort keys %{ $self->{GLOBATTR} }; #line 715 "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 885 "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 921 "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 971 "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 1411 "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 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 1363 "SD.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/IO/Misc.pm0000644000175000017500000011617014556074551015574 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 7 "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 44 "Misc.pm" =head1 FUNCTIONS =cut #line 47 "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 64 "Misc.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 *bswap2 = \&PDL::bswap2; =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 *bswap4 = \&PDL::bswap4; =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 *bswap8 = \&PDL::bswap8; #line 124 "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 = PDL::Options->new( { 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 = PDL::Options->new( { 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 1180 "misc.pd" sub PDL::isbigendian { return 0; }; *isbigendian = \&PDL::isbigendian; #line 1202 "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 1300 "Misc.pm" *_rasc = \&PDL::_rasc; #line 27 "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 1323 "Misc.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/IO/Storable.pm0000644000175000017500000002243714556074552016457 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 1 "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 65 "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 335 "Storable.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/Primitive.pm0000644000175000017500000025566614556074546016364 0ustar osboxesosboxes# # GENERATED WITH PDL::PP! Don't modify! # package PDL::Primitive; our @EXPORT_OK = qw(inner outer 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 cmpvec eqvec enumvec enumvecg vsearchvec unionvec intersectvec setdiffvec union_sorted intersect_sorted setdiff_sorted 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 where_both 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 63 "Primitive.pm" =head1 FUNCTIONS =cut =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 *inner = \&PDL::inner; =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 broadcasting 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 *outer = \&PDL::outer; #line 105 "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. Broadcasting 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 broadcast 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 227 "Primitive.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 broadcasting 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 203 "primitive.pd" sub PDL::matmult { my ($x,$y,$c) = @_; $y = PDL->topdl($y); $c = PDL->null unless do { local $@; 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) ); barf sprintf 'Dim mismatch in matmult of [%1$dx%2$d] x [%3$dx%4$d]: %1$d != %4$d',$x->dim(0),$x->dim(1),$y->dim(0),$y->dim(1) if $y->dim(1) != $x->dim(0); PDL::_matmult_int($x,$y,$c); $c; } #line 275 "Primitive.pm" *matmult = \&PDL::matmult; =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 *innerwt = \&PDL::innerwt; =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 broadcast 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 *inner2 = \&PDL::inner2; =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 *inner2d = \&PDL::inner2d; =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 broadcasting using L would scale as C. The reason for having this routine is that you do not need to have the same broadcast-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 *inner2t = \&PDL::inner2t; =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 *crossp = \&PDL::crossp; =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 *norm = \&PDL::norm; =head2 indadd =for sig Signature: (input(n); indx ind(n); [io] sum(m)) =for ref Broadcasting index add: add C to the C element of C, i.e: sum(ind) += input =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] Broadcasting 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 on bad indices, and bad inputs set target outputs bad. =cut *indadd = \&PDL::indadd; =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 broadcasted 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 623 "primitive.pd" sub PDL::conv1d { my $opt = pop @_ if ref($_[-1]) eq 'HASH'; die 'Usage: conv1d( a(m), kern(p), [o]b(m), {Options} )' if @_<2 || @_>3; my($x,$kern) = @_; my $c = @_ == 3 ? $_[2] : PDL->null; PDL::_conv1d_int($x,$kern,$c, !(defined $opt && exists $$opt{Boundary}) ? 0 : lc $$opt{Boundary} eq "reflect"); return $c; } #line 609 "Primitive.pm" *conv1d = \&PDL::conv1d; =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 broadcasting 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 *in = \&PDL::in; #line 696 "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 { my ($arr) = @_; return $arr if($arr->nelem == 0); # The null list is unique (CED) return $arr->flat if($arr->nelem == 1); # singleton list is unique my $aflat = $arr->flat; my $srt = $aflat->where($aflat==$aflat)->qsort; # no NaNs or BADs for qsort my $nans = $aflat->where($aflat!=$aflat); my $uniq = ($srt->nelem > 1) ? $srt->where($srt != $srt->rotate(-1)) : $srt; # make sure we return something if there is only one value ( $uniq->nelem > 0 ? $uniq : $srt->nelem == 0 ? $srt : PDL::pdl( ref($srt), [$srt->index(0)] ) )->append($nans); } #line 755 "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 821 "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 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 847 "Primitive.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 916 "primitive.pd" sub PDL::hclip { my ($x,$y) = @_; my $c; if ($x->is_inplace) { $x->set_inplace(0); $c = $x; } elsif (@_ > 2) {$c=$_[2]} else {$c=PDL->nullcreate($x)} PDL::_hclip_int($x,$y,$c); return $c; } #line 880 "Primitive.pm" *hclip = \&PDL::hclip; =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 916 "primitive.pd" sub PDL::lclip { my ($x,$y) = @_; my $c; if ($x->is_inplace) { $x->set_inplace(0); $c = $x; } elsif (@_ > 2) {$c=$_[2]} else {$c=PDL->nullcreate($x)} PDL::_lclip_int($x,$y,$c); return $c; } #line 920 "Primitive.pm" *lclip = \&PDL::lclip; #line 931 "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 948 "Primitive.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 965 "primitive.pd" *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 (@_ > 3) { $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 1005 "Primitive.pm" *clip = \&PDL::clip; =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 *wtstat = \&PDL::wtstat; =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 1099 "primitive.pd" sub PDL::statsover { barf('Usage: ($mean,[$prms, $median, $min, $max, $adev, $rms]) = statsover($data,[$weights])') if @_>2; my ($data, $weights) = @_; $weights //= $data->ones(); 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); wantarray ? ($mean, $prms, $median, $min, $max, $adev, $rms) : $mean; } #line 1136 "Primitive.pm" *statsover = \&PDL::statsover; #line 1182 "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 @_>2; my ($data,$weights) = @_; # Ensure that $weights is properly broadcasted 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 1188 "Primitive.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 broadcastloop 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 *histogram = \&PDL::histogram; =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 broadcastloop 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 *whistogram = \&PDL::whistogram; =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 *histogram2d = \&PDL::histogram2d; =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 *whistogram2d = \&PDL::whistogram2d; =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 1468 "primitive.pd" 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 1429 "Primitive.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 broadcasting 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 1494 "primitive.pd" sub PDL::append { my ($i1, $i2, $o) = map PDL->topdl($_), @_; my $nempty = grep $_->isempty, $i1, $i2; if ($nempty == 2) { my @dims = $i1->dims; $dims[0] += $i2->dim(0); return PDL->zeroes($i1->type, @dims); } if ($nempty == 1) { if (!defined $o) { return $i2->isnull ? PDL->zeroes(0) : $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->convert($i1->type), $o); $o; } #line 1492 "Primitive.pm" *append = \&PDL::append; #line 1547 "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 broadcasting 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; ($dim, $x) = ($x, $dim) if defined $x && !ref $x; confess 'dimension must be Perl scalar' if ref $dim; 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 1574 "Primitive.pm" *axisvalues = \&PDL::axisvalues; =head2 cmpvec =for sig Signature: (a(n); b(n); sbyte [o]c()) =for ref Compare two vectors lexicographically. Returns -1 if a is less, 1 if greater, 0 if equal. =for bad The output is bad if any input values up to the point of inequality are bad - any after are ignored. =cut *cmpvec = \&PDL::cmpvec; =head2 eqvec =for sig Signature: (a(n); b(n); sbyte [o]c()) =for ref Compare two vectors, returning 1 if equal, 0 if not equal. =for bad The output is bad if any input values are bad. =cut *eqvec = \&PDL::eqvec; =head2 enumvec =for sig Signature: (v(M,N); indx [o]k(N)) =for ref Enumerate a list of vectors with locally unique keys. Given a sorted list of vectors $v, generate a vector $k containing locally unique keys for the elements of $v (where an "element" is a vector of length $M occurring in $v). Note that the keys returned in $k are only unique over a run of a single vector in $v, so that each unique vector in $v has at least one 0 (zero) index in $k associated with it. If you need global keys, see enumvecg(). Contributed by Bryan Jurish Emoocow@cpan.orgE. =for bad enumvec 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 *enumvec = \&PDL::enumvec; =head2 enumvecg =for sig Signature: (v(M,N); indx [o]k(N)) =for ref Enumerate a list of vectors with globally unique keys. Given a sorted list of vectors $v, generate a vector $k containing globally unique keys for the elements of $v (where an "element" is a vector of length $M occurring in $v). Basically does the same thing as: $k = $v->vsearchvec($v->uniqvec); ... but somewhat more efficiently. Contributed by Bryan Jurish Emoocow@cpan.orgE. =for bad enumvecg 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 *enumvecg = \&PDL::enumvecg; =head2 vsearchvec =for sig Signature: (find(M); which(M,N); indx [o]found()) =for ref Routine for searching N-dimensional values - akin to vsearch() for vectors. =for usage $found = vsearchvec($find, $which); $nearest = $which->dice_axis(1,$found); Returns for each row-vector in C<$find> the index along dimension N of the least row vector of C<$which> greater or equal to it. C<$which> should be sorted in increasing order. If the value of C<$find> is larger than any member of C<$which>, the index to the last element of C<$which> is returned. See also: L. Contributed by Bryan Jurish Emoocow@cpan.orgE. =for bad vsearchvec 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 *vsearchvec = \&PDL::vsearchvec; =head2 unionvec =for sig Signature: (a(M,NA); b(M,NB); [o]c(M,NC); indx [o]nc()) =for ref Union of two vector-valued PDLs. Input PDLs $a() and $b() B be sorted in lexicographic order. On return, $nc() holds the actual number of vector-values in the union. In scalar context, slices $c() to the actual number of elements in the union and returns the sliced PDL. Contributed by Bryan Jurish Emoocow@cpan.orgE. =for bad unionvec 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 1821 "primitive.pd" sub PDL::unionvec { my ($a,$b,$c,$nc) = @_; $c = PDL->null if (!defined($nc)); $nc = PDL->null if (!defined($nc)); PDL::_unionvec_int($a,$b,$c,$nc); return ($c,$nc) if (wantarray); return $c->slice(",0:".($nc->max-1)); } #line 1792 "Primitive.pm" *unionvec = \&PDL::unionvec; =head2 intersectvec =for sig Signature: (a(M,NA); b(M,NB); [o]c(M,NC); indx [o]nc()) =for ref Intersection of two vector-valued PDLs. Input PDLs $a() and $b() B be sorted in lexicographic order. On return, $nc() holds the actual number of vector-values in the intersection. In scalar context, slices $c() to the actual number of elements in the intersection and returns the sliced PDL. Contributed by Bryan Jurish Emoocow@cpan.orgE. =for bad intersectvec 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 1883 "primitive.pd" sub PDL::intersectvec { my ($a,$b,$c,$nc) = @_; $c = PDL->null if (!defined($c)); $nc = PDL->null if (!defined($nc)); PDL::_intersectvec_int($a,$b,$c,$nc); return ($c,$nc) if (wantarray); my $nc_max = $nc->max; return ($nc_max > 0 ? $c->slice(",0:".($nc_max-1)) : $c->reshape($c->dim(0), 0, ($c->dims)[2..($c->ndims-1)])); } #line 1841 "Primitive.pm" *intersectvec = \&PDL::intersectvec; =head2 setdiffvec =for sig Signature: (a(M,NA); b(M,NB); [o]c(M,NC); indx [o]nc()) =for ref Set-difference ($a() \ $b()) of two vector-valued PDLs. Input PDLs $a() and $b() B be sorted in lexicographic order. On return, $nc() holds the actual number of vector-values in the computed vector set. In scalar context, slices $c() to the actual number of elements in the output vector set and returns the sliced PDL. Contributed by Bryan Jurish Emoocow@cpan.orgE. =for bad setdiffvec 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 "primitive.pd" sub PDL::setdiffvec { my ($a,$b,$c,$nc) = @_; $c = PDL->null if (!defined($c)); $nc = PDL->null if (!defined($nc)); PDL::_setdiffvec_int($a,$b,$c,$nc); return ($c,$nc) if (wantarray); my $nc_max = $nc->max; return ($nc_max > 0 ? $c->slice(",0:".($nc_max-1)) : $c->reshape($c->dim(0), 0, ($c->dims)[2..($c->ndims-1)])); } #line 1891 "Primitive.pm" *setdiffvec = \&PDL::setdiffvec; =head2 union_sorted =for sig Signature: (a(NA); b(NB); [o]c(NC); indx [o]nc()) =for ref Union of two flat sorted unique-valued PDLs. Input PDLs $a() and $b() B be sorted in lexicographic order and contain no duplicates. On return, $nc() holds the actual number of values in the union. In scalar context, reshapes $c() to the actual number of elements in the union and returns it. Contributed by Bryan Jurish Emoocow@cpan.orgE. =for bad union_sorted 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 2010 "primitive.pd" sub PDL::union_sorted { my ($a,$b,$c,$nc) = @_; $c = PDL->null if (!defined($c)); $nc = PDL->null if (!defined($nc)); PDL::_union_sorted_int($a,$b,$c,$nc); return ($c,$nc) if (wantarray); return $c->slice("0:".($nc->max-1)); } #line 1936 "Primitive.pm" *union_sorted = \&PDL::union_sorted; =head2 intersect_sorted =for sig Signature: (a(NA); b(NB); [o]c(NC); indx [o]nc()) =for ref Intersection of two flat sorted unique-valued PDLs. Input PDLs $a() and $b() B be sorted in lexicographic order and contain no duplicates. On return, $nc() holds the actual number of values in the intersection. In scalar context, reshapes $c() to the actual number of elements in the intersection and returns it. Contributed by Bryan Jurish Emoocow@cpan.orgE. =for bad intersect_sorted 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 2070 "primitive.pd" sub PDL::intersect_sorted { my ($a,$b,$c,$nc) = @_; $c = PDL->null if (!defined($c)); $nc = PDL->null if (!defined($nc)); PDL::_intersect_sorted_int($a,$b,$c,$nc); return ($c,$nc) if (wantarray); my $nc_max = $nc->max; return ($nc_max > 0 ? $c->slice("0:".($nc_max-1)) : $c->reshape(0, ($c->dims)[1..($c->ndims-1)])); } #line 1984 "Primitive.pm" *intersect_sorted = \&PDL::intersect_sorted; =head2 setdiff_sorted =for sig Signature: (a(NA); b(NB); [o]c(NC); indx [o]nc()) =for ref Set-difference ($a() \ $b()) of two flat sorted unique-valued PDLs. Input PDLs $a() and $b() B be sorted in lexicographic order and contain no duplicate values. On return, $nc() holds the actual number of values in the computed vector set. In scalar context, reshapes $c() to the actual number of elements in the difference set and returns it. Contributed by Bryan Jurish Emoocow@cpan.orgE. =for bad setdiff_sorted 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 "primitive.pd" sub PDL::setdiff_sorted { my ($a,$b,$c,$nc) = @_; $c = PDL->null if (!defined($c)); $nc = PDL->null if (!defined($nc)); PDL::_setdiff_sorted_int($a,$b,$c,$nc); return ($c,$nc) if (wantarray); my $nc_max = $nc->max; return ($nc_max > 0 ? $c->slice("0:".($nc_max-1)) : $c->reshape(0, ($c->dims)[1..($c->ndims-1)])); } #line 2033 "Primitive.pm" *setdiff_sorted = \&PDL::setdiff_sorted; =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 2227 "primitive.pd" *srand = \&PDL::srand; sub PDL::srand { PDL::_srand_int($_[0] // PDL::Core::seed()) } #line 2073 "Primitive.pm" *srand = \&PDL::srand; =head2 random =for sig Signature: ([o] 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 2266 "primitive.pd" sub random { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->random : PDL->random(@_) } sub PDL::random { my $class = shift; unshift @_, double() if !ref($class) and !@_; my $x = scalar(@_)? $class->new_from_specification(@_) : $class->new_or_inplace; PDL::_random_int($x); return $x; } #line 2127 "Primitive.pm" =head2 randsym =for sig Signature: ([o] 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 2312 "primitive.pd" sub randsym { ref($_[0]) && ref($_[0]) ne 'PDL::Type' ? $_[0]->randsym : PDL->randsym(@_) } sub PDL::randsym { my $class = shift; unshift @_, double() if !ref($class) and !@_; my $x = scalar(@_)? $class->new_from_specification(@_) : $class->new_or_inplace; PDL::_randsym_int($x); return $x; } #line 2324 "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 2364 "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 2351 "Primitive.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. if C<$x> is empty, then all values in C<$idx> will be set to the bad value. 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 bad values in vals() result in bad values in idx() =cut *vsearch_sample = \&PDL::vsearch_sample; =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. if C<$x> is empty, then all values in C<$idx> will be set to the bad value. 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 bad values in vals() result in bad values in idx() =cut *vsearch_insert_leftmost = \&PDL::vsearch_insert_leftmost; =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. if C<$x> is empty, then all values in C<$idx> will be set to the bad value. 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 bad values in vals() result in bad values in idx() =cut *vsearch_insert_rightmost = \&PDL::vsearch_insert_rightmost; =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. if C<$x> is empty, then all values in C<$idx> will be set to the bad value. 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 bad values in vals() result in bad values in idx() =cut *vsearch_match = \&PDL::vsearch_match; =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. if C<$x> is empty, then all values in C<$idx> will be set to the bad value. 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 bad values in vals() result in bad values in idx() =cut *vsearch_bin_inclusive = \&PDL::vsearch_bin_inclusive; =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. if C<$x> is empty, then all values in C<$idx> will be set to the bad value. 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 bad values in vals() result in bad values in idx() =cut *vsearch_bin_exclusive = \&PDL::vsearch_bin_exclusive; =head2 interpolate =for sig Signature: (real xi(); real 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. Note that C can use complex values for C<$y> and C<$yi> but C<$x> and C<$xi> must be real. =for bad needs major (?) work to handles bad values =cut #line 2997 "primitive.pd" sub PDL::interpolate { my ($xi, $x, $y, $yi, $err) = @_; croak "x must be real" if (ref($x) && ! $x->type->real); croak "xi must be real" if (ref($xi) && ! $xi->type->real); $yi //= PDL->null; $err //= PDL->null; PDL::_interpolate_int($xi, $x, $y, $yi, $err); ($yi, $err); } #line 2821 "Primitive.pm" *interpolate = \&PDL::interpolate; #line 3077 "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 = @_ == 1 ? $_[0] : 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 @_ == 0; } # sub: interpol() *PDL::interpol = \&interpol; #line 3115 "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 broadcast; cth = cube broadcast; sth = source broadcast) 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) { local $@; 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 3364 "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 @_ != 2; my ($x, $ind)=@_; my @dimension=$x->dims; $ind = indx($ind); my(@index); my $count=0; foreach (@dimension) { $index[$count++]=$ind % $_; $ind /= $_; } return @index; } #line 3154 "Primitive.pm" =head2 which =for sig Signature: (mask(n); indx [o] inds(n); indx [o]lastout()) =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 nonzero and zero values in the mask. L returns separately slices of both nonzero and zero 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 3495 "primitive.pd" sub which { my ($this,$out) = @_; $this = $this->flat; $out //= $this->nullcreate; PDL::_which_int($this,$out,my $lastout = $this->nullcreate); my $lastoutmax = $lastout->max->sclr; $lastoutmax ? $out->slice('0:'.($lastoutmax-1))->sever : empty(indx); } *PDL::which = \&which; #line 3224 "Primitive.pm" *which = \&PDL::which; =head2 which_both =for sig Signature: (mask(n); indx [o] inds(n); indx [o]notinds(n); indx [o]lastout(); indx [o]lastoutn()) =for ref Returns indices of nonzero and zero 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> p $x = sequence(10) [0 1 2 3 4 5 6 7 8 9] pdl> ($big, $small) = which_both($x >= 5); p "$big\n$small" [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 3512 "primitive.pd" sub which_both { my ($this,$outi,$outni) = @_; $this = $this->flat; $outi //= $this->nullcreate; $outni //= $this->nullcreate; PDL::_which_both_int($this,$outi,$outni,my $lastout = $this->nullcreate,my $lastoutn = $this->nullcreate); my $lastoutmax = $lastout->max->sclr; $outi = $lastoutmax ? $outi->slice('0:'.($lastoutmax-1))->sever : empty(indx); return $outi if !wantarray; my $lastoutnmax = $lastoutn->max->sclr; ($outi, $lastoutnmax ? $outni->slice('0:'.($lastoutnmax-1))->sever : empty(indx)); } *PDL::which_both = \&which_both; #line 3282 "Primitive.pm" *which_both = \&PDL::which_both; #line 3545 "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 broadcast 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* broadcast over a smaller mask, for example. =cut sub PDL::where { barf "Usage: where( \$pdl1, ..., \$pdlN, \$mask )\n" if @_ == 1; if(@_ == 2) { 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 3613 "primitive.pd" =head2 where_both =for ref Returns slices (non-zero in mask, zero) of an ndarray according to a mask =for usage ($match_vals, $non_match_vals) = where_both($pdl, $mask); This works like L, but (flattened) data-flowing slices rather than index-sets are returned. =for example pdl> p $x = sequence(10) + 2 [2 3 4 5 6 7 8 9 10 11] pdl> ($big, $small) = where_both($x, $x > 5); p "$big\n$small" [6 7 8 9 10 11] [2 3 4 5] pdl> p $big += 2, $small -= 1 [8 9 10 11 12 13] [1 2 3 4] pdl> p $x [1 2 3 4 8 9 10 11 12 13] =cut sub PDL::where_both { barf "Usage: where_both(\$pdl, \$mask)\n" if @_ != 2; my ($arr, $mask) = @_; # $mask has 0==false, 1==true my $arr_flat = $arr->clump(-1); map $arr_flat->index1d($_), PDL::which_both($mask); } *where_both = \&PDL::where_both; #line 3651 "primitive.pd" =head2 whereND =for ref C with support for ND masks and broadcasting 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 broadcasting 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 broadcasting 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 @_ == 1; my $mask = pop @_; # $mask has 0==false, 1==true my @to_return; my $n = PDL::sum($mask); my $maskndims = $mask->ndims; foreach my $arr (@_) { # count the number of dims in $mask and $arr # $mask = a b c d e f..... my @idims = dims($arr); splice @idims, 0, $maskndims; # pop off the number of dims in $mask if (!$n or $arr->isempty) { push @to_return, PDL->zeroes($arr->type, $n, @idims); next; } my $sub_i = $mask * ones($arr); my $where_sub_i = PDL::where($arr, $sub_i); 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 3736 "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, broadcasting-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 3845 "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. return $x if $x->isempty; return $y if $y->isempty; # Make ordered list of set union. my $union = append($x, $y)->qsort; return $union->where($union == rotate($union, -1))->uniq; } else { print "The operation $op is not known!"; return -1; } } #line 4028 "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 4064 "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 3808 "Primitive.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/Ufunc.pm0000644000175000017500000010720214556074550015445 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 9 "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 56 "Ufunc.pm" =head1 FUNCTIONS =cut =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 *prodover = \&PDL::prodover; =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 *cprodover = \&PDL::cprodover; =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 *dprodover = \&PDL::dprodover; =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 *cumuprodover = \&PDL::cumuprodover; =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 *dcumuprodover = \&PDL::dcumuprodover; =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 *sumover = \&PDL::sumover; =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 *csumover = \&PDL::csumover; =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 *dsumover = \&PDL::dsumover; =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 *cumusumover = \&PDL::cumusumover; =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 *dcumusumover = \&PDL::dcumusumover; =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 *andover = \&PDL::andover; =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 *bandover = \&PDL::bandover; =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 *borover = \&PDL::borover; =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 *orover = \&PDL::orover; =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 *zcover = \&PDL::zcover; =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 *intover = \&PDL::intover; =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 *average = \&PDL::average; #line 304 "ufunc.pd" =head2 avgover =for ref Synonym for average. =cut *PDL::avgover = *avgover = \&PDL::average; #line 815 "Ufunc.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 *caverage = \&PDL::caverage; #line 304 "ufunc.pd" =head2 cavgover =for ref Synonym for caverage. =cut *PDL::cavgover = *cavgover = \&PDL::caverage; #line 871 "Ufunc.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 *daverage = \&PDL::daverage; #line 304 "ufunc.pd" =head2 davgover =for ref Synonym for daverage. =cut *PDL::davgover = *davgover = \&PDL::daverage; #line 927 "Ufunc.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 no elements of the input are non-bad, otherwise the bad flag is cleared for the output ndarray. Note that C are considered to be valid values and will "win" over non-C; see L and L for ways of masking NaNs. =cut *minimum = \&PDL::minimum; #line 304 "ufunc.pd" =head2 minover =for ref Synonym for minimum. =cut *PDL::minover = *minover = \&PDL::minimum; #line 984 "Ufunc.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 no elements of the input are non-bad, otherwise the bad flag is cleared for the output ndarray. Note that C are considered to be valid values and will "win" over non-C; see L and L for ways of masking NaNs. =cut *minimum_ind = \&PDL::minimum_ind; #line 304 "ufunc.pd" =head2 minover_ind =for ref Synonym for minimum_ind. =cut *PDL::minover_ind = *minover_ind = \&PDL::minimum_ind; #line 1027 "Ufunc.pm" =head2 minimum_n_ind =for sig Signature: (a(n); indx [o]c(m); PDL_Indx m_size => m) =for ref Returns the index of C minimum elements. As of 2.077, you can specify how many by either passing in an ndarray of the given size (DEPRECATED - will be converted to indx if needed and the input arg will be set to that), or just the size, or a null and the size. =for usage minimum_n_ind($pdl, $out = zeroes(5)); # DEPRECATED $out = minimum_n_ind($pdl, 5); minimum_n_ind($pdl, $out = null, 5); =for bad Output bad flag is cleared for the output ndarray if sufficient non-bad elements found, else remaining slots in C<$c()> are set bad. Note that C are considered to be valid values and will "win" over non-C; see L and L for ways of masking NaNs. =cut #line 409 "ufunc.pd" sub PDL::minimum_n_ind { my ($a, $c, $m_size) = @_; $m_size //= ref($c) ? $c->dim(0) : $c; # back-compat with pre-2.077 my $set_out = 1; $set_out = 0, $c = null if !ref $c; $c = $c->indx if !$c->isnull; PDL::_minimum_n_ind_int($a, $c, $m_size); $set_out ? $_[1] = $c : $c; } #line 1073 "Ufunc.pm" *minimum_n_ind = \&PDL::minimum_n_ind; #line 304 "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 1092 "Ufunc.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 no elements of the input are non-bad, otherwise the bad flag is cleared for the output ndarray. Note that C are considered to be valid values and will "win" over non-C; see L and L for ways of masking NaNs. =cut *maximum = \&PDL::maximum; #line 304 "ufunc.pd" =head2 maxover =for ref Synonym for maximum. =cut *PDL::maxover = *maxover = \&PDL::maximum; #line 1149 "Ufunc.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 no elements of the input are non-bad, otherwise the bad flag is cleared for the output ndarray. Note that C are considered to be valid values and will "win" over non-C; see L and L for ways of masking NaNs. =cut *maximum_ind = \&PDL::maximum_ind; #line 304 "ufunc.pd" =head2 maxover_ind =for ref Synonym for maximum_ind. =cut *PDL::maxover_ind = *maxover_ind = \&PDL::maximum_ind; #line 1192 "Ufunc.pm" =head2 maximum_n_ind =for sig Signature: (a(n); indx [o]c(m); PDL_Indx m_size => m) =for ref Returns the index of C maximum elements. As of 2.077, you can specify how many by either passing in an ndarray of the given size (DEPRECATED - will be converted to indx if needed and the input arg will be set to that), or just the size, or a null and the size. =for usage maximum_n_ind($pdl, $out = zeroes(5)); # DEPRECATED $out = maximum_n_ind($pdl, 5); maximum_n_ind($pdl, $out = null, 5); =for bad Output bad flag is cleared for the output ndarray if sufficient non-bad elements found, else remaining slots in C<$c()> are set bad. Note that C are considered to be valid values and will "win" over non-C; see L and L for ways of masking NaNs. =cut #line 409 "ufunc.pd" sub PDL::maximum_n_ind { my ($a, $c, $m_size) = @_; $m_size //= ref($c) ? $c->dim(0) : $c; # back-compat with pre-2.077 my $set_out = 1; $set_out = 0, $c = null if !ref $c; $c = $c->indx if !$c->isnull; PDL::_maximum_n_ind_int($a, $c, $m_size); $set_out ? $_[1] = $c : $c; } #line 1238 "Ufunc.pm" *maximum_n_ind = \&PDL::maximum_n_ind; #line 304 "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 1257 "Ufunc.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 *minmaximum = \&PDL::minmaximum; #line 304 "ufunc.pd" =head2 minmaxover =for ref Synonym for minmaximum. =cut *PDL::minmaxover = *minmaxover = \&PDL::minmaximum; #line 543 "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 543 "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 543 "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 543 "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 543 "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 543 "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 543 "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 543 "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 543 "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 543 "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 543 "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 543 "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 543 "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 543 "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 543 "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 543 "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 573 "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 broadcast 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, 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 1800 "Ufunc.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 *medover = \&PDL::medover; =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 *oddmedover = \&PDL::oddmedover; =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 *modeover = \&PDL::modeover; =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 *pctover = \&PDL::pctover; =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 *oddpctover = \&PDL::oddpctover; #line 934 "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 934 "ufunc.pd" =head2 oddpct =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 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 2082 "Ufunc.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 *qsort = \&PDL::qsort; =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 *qsorti = \&PDL::qsorti; =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 broadcasted 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 *qsortvec = \&PDL::qsortvec; =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 broadcasted 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 *qsortveci = \&PDL::qsortveci; #line 1182 "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 2259 "Ufunc.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/Ops.pm0000644000175000017500000010364114556074545015135 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 18 "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 54 "Ops.pm" =head1 FUNCTIONS =cut #line 130 "ops.pd" #line 180 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'+'} = $overload_sub = sub(;@) { goto &PDL::plus unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '+')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } } #line 193 "ops.pd" BEGIN { # in1, in2, out, swap if true $OVERLOADS{'+='} = sub { PDL::plus($_[0]->inplace, $_[1]); $_[0] }; } #line 83 "Ops.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. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut *plus = \&PDL::plus; #line 130 "ops.pd" #line 180 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'*'} = $overload_sub = sub(;@) { goto &PDL::mult unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '*')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } } #line 193 "ops.pd" BEGIN { # in1, in2, out, swap if true $OVERLOADS{'*='} = sub { PDL::mult($_[0]->inplace, $_[1]); $_[0] }; } #line 142 "Ops.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. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut *mult = \&PDL::mult; #line 130 "ops.pd" #line 180 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'-'} = $overload_sub = sub(;@) { goto &PDL::minus unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '-')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } } #line 193 "ops.pd" BEGIN { # in1, in2, out, swap if true $OVERLOADS{'-='} = sub { PDL::minus($_[0]->inplace, $_[1]); $_[0] }; } #line 201 "Ops.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. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut *minus = \&PDL::minus; #line 130 "ops.pd" #line 180 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'/'} = $overload_sub = sub(;@) { goto &PDL::divide unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '/')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } } #line 193 "ops.pd" BEGIN { # in1, in2, out, swap if true $OVERLOADS{'/='} = sub { PDL::divide($_[0]->inplace, $_[1]); $_[0] }; } #line 260 "Ops.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. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut *divide = \&PDL::divide; #line 130 "ops.pd" #line 180 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'>'} = $overload_sub = sub(;@) { goto &PDL::gt unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '>')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } } #line 313 "Ops.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. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut *gt = \&PDL::gt; #line 130 "ops.pd" #line 180 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'<'} = $overload_sub = sub(;@) { goto &PDL::lt unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '<')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } } #line 366 "Ops.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. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut *lt = \&PDL::lt; #line 130 "ops.pd" #line 180 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'<='} = $overload_sub = sub(;@) { goto &PDL::le unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '<=')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } } #line 419 "Ops.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. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut *le = \&PDL::le; #line 130 "ops.pd" #line 180 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'>='} = $overload_sub = sub(;@) { goto &PDL::ge unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '>=')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } } #line 472 "Ops.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. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut *ge = \&PDL::ge; #line 130 "ops.pd" #line 180 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'=='} = $overload_sub = sub(;@) { goto &PDL::eq unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '==')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } } #line 525 "Ops.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. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut *eq = \&PDL::eq; #line 130 "ops.pd" #line 180 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'!='} = $overload_sub = sub(;@) { goto &PDL::ne unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '!=')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } } #line 578 "Ops.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. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut *ne = \&PDL::ne; #line 130 "ops.pd" #line 180 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'<<'} = $overload_sub = sub(;@) { goto &PDL::shiftleft unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '<<')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } } #line 193 "ops.pd" BEGIN { # in1, in2, out, swap if true $OVERLOADS{'<<='} = sub { PDL::shiftleft($_[0]->inplace, $_[1]); $_[0] }; } #line 637 "Ops.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. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut *shiftleft = \&PDL::shiftleft; #line 130 "ops.pd" #line 180 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'>>'} = $overload_sub = sub(;@) { goto &PDL::shiftright unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '>>')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } } #line 193 "ops.pd" BEGIN { # in1, in2, out, swap if true $OVERLOADS{'>>='} = sub { PDL::shiftright($_[0]->inplace, $_[1]); $_[0] }; } #line 696 "Ops.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. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut *shiftright = \&PDL::shiftright; #line 130 "ops.pd" #line 180 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'|'} = $overload_sub = sub(;@) { goto &PDL::or2 unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '|')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } } #line 193 "ops.pd" BEGIN { # in1, in2, out, swap if true $OVERLOADS{'|='} = sub { PDL::or2($_[0]->inplace, $_[1]); $_[0] }; } #line 755 "Ops.pm" =head2 or2 =for sig Signature: (a(); b(); [o]c(); int $swap; SV *$ign; int $ign2) =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. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut *or2 = \&PDL::or2; #line 130 "ops.pd" #line 180 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'&'} = $overload_sub = sub(;@) { goto &PDL::and2 unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '&')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } } #line 193 "ops.pd" BEGIN { # in1, in2, out, swap if true $OVERLOADS{'&='} = sub { PDL::and2($_[0]->inplace, $_[1]); $_[0] }; } #line 814 "Ops.pm" =head2 and2 =for sig Signature: (a(); b(); [o]c(); int $swap; SV *$ign; int $ign2) =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. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut *and2 = \&PDL::and2; #line 130 "ops.pd" #line 180 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'^'} = $overload_sub = sub(;@) { goto &PDL::xor unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '^')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } } #line 193 "ops.pd" BEGIN { # in1, in2, out, swap if true $OVERLOADS{'^='} = sub { PDL::xor($_[0]->inplace, $_[1]); $_[0] }; } #line 873 "Ops.pm" =head2 xor =for sig Signature: (a(); b(); [o]c(); int $swap; SV *$ign; int $ign2) =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. It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays. =cut *xor = \&PDL::xor; #line 307 "ops.pd" #line 176 "ops.pd" BEGIN { $OVERLOADS{'~'} = sub { PDL::bitnot($_[0]) } } #line 917 "Ops.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 *bitnot = \&PDL::bitnot; #line 239 "ops.pd" #line 180 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'**'} = $overload_sub = sub(;@) { goto &PDL::power unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '**')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } } #line 193 "ops.pd" BEGIN { # in1, in2, out, swap if true $OVERLOADS{'**='} = sub { PDL::power($_[0]->inplace, $_[1]); $_[0] }; } #line 972 "Ops.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); # explicit call with default swap of 0 $c = $x->power($y, 1); # explicit call with trailing 1 to swap args $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. As of 2.065, when calling this function explicitly you can omit the third argument (see first example), or supply it (see second one). =for bad power 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 *power = \&PDL::power; #line 239 "ops.pd" #line 180 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'atan2'} = $overload_sub = sub(;@) { goto &PDL::atan2 unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], 'atan2')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } } #line 1025 "Ops.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); # explicit call with default swap of 0 $c = $x->atan2($y, 1); # explicit call with trailing 1 to swap args $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. As of 2.065, when calling this function explicitly you can omit the third argument (see first example), or supply it (see second one). =for bad atan2 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 *atan2 = \&PDL::atan2; #line 239 "ops.pd" #line 180 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'%'} = $overload_sub = sub(;@) { goto &PDL::modulo unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '%')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } } #line 193 "ops.pd" BEGIN { # in1, in2, out, swap if true $OVERLOADS{'%='} = sub { PDL::modulo($_[0]->inplace, $_[1]); $_[0] }; } #line 1084 "Ops.pm" =head2 modulo =for sig Signature: (a(); b(); [o]c(); int $swap) =for ref elementwise C operation =for example $c = $x->modulo($y); # explicit call with default swap of 0 $c = $x->modulo($y, 1); # explicit call with trailing 1 to swap args $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. As of 2.065, when calling this function explicitly you can omit the third argument (see first example), or supply it (see second one). =for bad modulo 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 *modulo = \&PDL::modulo; #line 239 "ops.pd" #line 180 "ops.pd" { my ($foo, $overload_sub); BEGIN { $OVERLOADS{'<=>'} = $overload_sub = sub(;@) { goto &PDL::spaceship unless ref $_[1] && (ref $_[1] ne 'PDL') && defined($foo = overload::Method($_[1], '<=>')) && $foo != $overload_sub; # recursion guard goto &$foo; }; } } #line 1137 "Ops.pm" =head2 spaceship =for sig Signature: (a(); b(); [o]c(); int $swap) =for ref elementwise "<=>" operation =for example $c = $x->spaceship($y); # explicit call with default swap of 0 $c = $x->spaceship($y, 1); # explicit call with trailing 1 to swap args $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. As of 2.065, when calling this function explicitly you can omit the third argument (see first example), or supply it (see second one). =for bad spaceship 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 *spaceship = \&PDL::spaceship; #line 307 "ops.pd" #line 176 "ops.pd" BEGIN { $OVERLOADS{'sqrt'} = sub { PDL::sqrt($_[0]) } } #line 1181 "Ops.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 *sqrt = \&PDL::sqrt; #line 307 "ops.pd" #line 176 "ops.pd" BEGIN { $OVERLOADS{'sin'} = sub { PDL::sin($_[0]) } } #line 1221 "Ops.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 *sin = \&PDL::sin; #line 307 "ops.pd" #line 176 "ops.pd" BEGIN { $OVERLOADS{'cos'} = sub { PDL::cos($_[0]) } } #line 1261 "Ops.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 *cos = \&PDL::cos; #line 307 "ops.pd" #line 176 "ops.pd" BEGIN { $OVERLOADS{'!'} = sub { PDL::not($_[0]) } } #line 1301 "Ops.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 *not = \&PDL::not; #line 307 "ops.pd" #line 176 "ops.pd" BEGIN { $OVERLOADS{'exp'} = sub { PDL::exp($_[0]) } } #line 1341 "Ops.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 *exp = \&PDL::exp; #line 307 "ops.pd" #line 176 "ops.pd" BEGIN { $OVERLOADS{'log'} = sub { PDL::log($_[0]) } } #line 1381 "Ops.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 *log = \&PDL::log; =head2 re =for sig Signature: (complexv(); real [o]b()) =for ref Returns the real part of a complex number. Flows data back & forth. =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 *re = \&PDL::re; =head2 im =for sig Signature: (complexv(); real [o]b()) =for ref Returns the imaginary part of a complex number. Flows data back & forth. =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 *im = \&PDL::im; =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 =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 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; }; *log10 = \&PDL::log10; =head2 assgn =for sig Signature: (a(); [o]b()) =for ref Plain numerical assignment. This is used to implement the ".=" operator =for bad assgn 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 *assgn = \&PDL::assgn; =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 *carg = \&PDL::carg; =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 *conj = \&PDL::conj; =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 *czip = \&PDL::czip; =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); # as method $c = ipow $x, $y; $x->inplace->ipow($y); # modify $x inplace It can be made to work inplace with the C<$x-Einplace> syntax. 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 *ipow = \&PDL::ipow; #line 567 "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 176 "ops.pd" BEGIN { $OVERLOADS{'abs'} = sub { PDL::abs($_[0]) } } #line 581 "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 1726 "Ops.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 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; } *r2C = \&PDL::r2C; =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 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; } *i2C = \&PDL::i2C; #line 624 "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 overload %OVERLOADS, "eq" => PDL::Ops::warn_non_numeric_op_wrapper(\&PDL::eq, 'eq'), ".=" => sub { my @args = !$_[2] ? @_[1,0] : @_[0,1]; PDL::Ops::assgn(@args); return $args[1]; }, '++' => sub { $_[0] += 1 }, '--' => sub { $_[0] -= 1 }, ; } #line 49 "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 1838 "Ops.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/MatrixOps.pm0000644000175000017500000011357114556074543016323 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, broadcastable): $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 broadcasting 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 broadcast over multiple row vectors. When broadcasting 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 134 "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 = !(my $was_pdl = UNIVERSAL::isa($n,'PDL')) ? zeroes($n,$n) : $n->getndims == 0 ? zeroes($n->type, $n->at(0),$n->at(0)) : undef; if (!defined $out) { my @dims = $n->dims; $out = zeroes($n->type, @dims[0, 0, 2..$#dims]); } (my $tmp = $out->diagonal(0,1))++; # work around perl -d "feature" $was_pdl ? bless $out, ref($n) : $out; } #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 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 288 "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, $opt) = @_; $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 : PDL->zeroes(sbyte,1); } #line 347 "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 (broadcastable). 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 broadcastable, 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 broadcasting 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 427 "MatrixOps.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 broadcastable, 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 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 broadcastable (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 } *eigens_sym = \&PDL::eigens_sym; =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 broadcastable, 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 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 } } *eigens = \&PDL::eigens; =head2 svd =for sig Signature: (a(n,m); [t]w(wsize); [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 broadcastable. 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 broadcasting 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 *svd = \&PDL::svd; #line 801 "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 broadcasting. 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 broadcasted, 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)')->zeroes; $tmprow = $tmprow->double if $tmprow->type < double; 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; } } # LAPACK cgetrf does not try fix singularity so nor do we, even though NR does my $notbig = $big->where(abs($big) < $TINY); return if !$notbig->isempty; # 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 wantarray ? ($out,$permute,$parity) : $out; } #line 980 "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 wantarray ? ($out,$perm,$par) : $out; } #line 1102 "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 broadcast # 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 broadcasts 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 broadcasting dimensions are compatible. # There are two possible sources of broadcast 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 broadcast dims not equal! \n"; } # (2) If X == Y then default broadcasting is ok if ( ($bnumthr==$permnumthr) and ($bdims==$permdims)->all) { print STDERR "lu_backsub: have explicit broadcast dims, goto BROADCAST_OK\n" if $PDL::debug; goto BROADCAST_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 broadcasting occurs over all # leading non-trivial (not length 1) dims of # B unless all the broadcast dims are explicitly # matched to the LU dims. BROADCAST_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 broadcasting 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 broadcasting } 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 broadcast dims $out->slice("$row:$n1") )->sumover; ($tmp = $out->index($r1)) /= $ludiag->index($r1)->dummy(0); # TODO: check broadcast dims } if ($y->is_inplace) { $y->setdims([$out->dims]) if !PDL::all($y->shape == $out->shape); # assgn needs same shape $y .= $out; } $out; } #line 1219 "MatrixOps.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 *simq = \&PDL::simq; =head2 squaretotri =for sig Signature: (a(n,n); [o]b(m)) =for ref Convert a lower-triangular square matrix to triangular vector storage. Ignores upper half of input. =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 *squaretotri = \&PDL::squaretotri; #line 1390 "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 1307 "MatrixOps.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/Slatec.pm0000644000175000017500000007471114556074562015613 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 5 "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 99 "Slatec.pm" =head1 FUNCTIONS =cut #line 91 "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 broadcasting 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 broadcast 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 broadcasts 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 423 "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 451 "Slatec.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 *svdc = \&PDL::svdc; =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 *poco = \&PDL::poco; =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 *geco = \&PDL::geco; =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 *gefa = \&PDL::gefa; =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 *podi = \&PDL::podi; =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 *gedi = \&PDL::gedi; =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 *gesl = \&PDL::gesl; =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 *rs = \&PDL::rs; =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 *ezffti = \&PDL::ezffti; =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 *ezfftf = \&PDL::ezfftf; =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 *ezfftb = \&PDL::ezfftb; =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 *pcoef = \&PDL::pcoef; =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 *pvalue = \&PDL::pvalue; =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 *chim = \&PDL::chim; =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 *chic = \&PDL::chic; =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 *chsp = \&PDL::chsp; =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 *chfd = \&PDL::chfd; =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 *chfe = \&PDL::chfe; =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 *chia = \&PDL::chia; =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 *chid = \&PDL::chid; =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 *chcm = \&PDL::chcm; =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 *chbs = \&PDL::chbs; =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 *polfit = \&PDL::polfit; #line 1580 "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 1598 "Slatec.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/Math.pm0000644000175000017500000002532114556074543015261 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 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 13 "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 59 "Math.pm" =head1 FUNCTIONS =cut =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 *acos = \&PDL::acos; =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 *asin = \&PDL::asin; =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 *atan = \&PDL::atan; =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 *cosh = \&PDL::cosh; =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 *sinh = \&PDL::sinh; =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 *tan = \&PDL::tan; =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 *tanh = \&PDL::tanh; =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 *ceil = \&PDL::ceil; =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 *floor = \&PDL::floor; =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 *rint = \&PDL::rint; =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 *pow = \&PDL::pow; =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 *acosh = \&PDL::acosh; =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 *asinh = \&PDL::asinh; =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 *atanh = \&PDL::atanh; =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 *erf = \&PDL::erf; =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 *erfc = \&PDL::erfc; =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 *bessj0 = \&PDL::bessj0; =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 *bessj1 = \&PDL::bessj1; =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 *bessy0 = \&PDL::bessy0; =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 *bessy1 = \&PDL::bessy1; =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 *bessjn = \&PDL::bessjn; =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 *bessyn = \&PDL::bessyn; =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 *lgamma = \&PDL::lgamma; =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 *isfinite = \&PDL::isfinite; =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 *erfi = \&PDL::erfi; =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 *ndtri = \&PDL::ndtri; =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 *polyroots = \&PDL::polyroots; #line 364 "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 840 "Math.pm" # Exit with OK status 1; PDL-2.085/GENERATED/PDL/Transform.pm0000644000175000017500000031116214556074562016345 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 2 "transform.pd" =head1 NAME PDL::Transform - Coordinate transforms, image warping, and N-D functions =head1 SYNOPSIS use PDL::Transform; my $t = PDL::Transform::->new() $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 broadcasted 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 = PDL::Transform::Radial->new; # 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 broadcast 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 264 "Transform.pm" =head1 FUNCTIONS =cut #line 314 "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 366 "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 367 "Transform.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

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 broadcast over the higher dimensions in C<$x> and repeated the same operation 9 times to all the rows on C<$x>. This is PDL broadcasting 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 broadcasting 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 broadcasted 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 broadcast 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 broadcast 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 Broadcasting PDL implementation And here's the broadcasted 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 broadcasted PDL version is much faster: Classical => 32.79 seconds. Broadcasting => 0.41 seconds. =head2 Explanation How does the broadcasted version work? There are many PDL functions designed to help you carry out PDL broadcasting. 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 Broadcasting 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 broadcasting 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.085/Basic/Pod/PP.pod0000644000175000017500000031106014422307654014673 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. As of 2.080, they will be passed the list of arguments they were called with, rather than a single string, split like the C pre-processor on commas except if in C<""> or C<()>, with leading and trailing whitespace removed. =for example pp_add_macros(SUCC => sub { "($_[0] + 1)" }); # ... Code => '$a() = $SUCC($b());', =head2 pp_add_typemaps =for ref Available from 2.082. Add an XS typemap for use as C or from manually-added XS. Takes one named argument, either C (an L object), C, or C. =for example pp_add_typemaps(string=><<'EOT'); TYPEMAP: < '[o] NV_ADD1 v1', =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_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 broadcasting (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 broadcasting 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 broadcast 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 broadcasting). 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 broadcasting 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 broadcasting 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 broadcasting 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 broadcasting 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 broadcasting. If you use implicit broadcasting 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 broadcast 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 broadcast 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 broadcasting 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 broadcasting 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 broadcasting 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 broadcast loop (if you don't know what a broadcast 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_broadcastloop_stuff { BadCode } } else { fancy_broadcastloop_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 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, for use in L and L. =over 4 =item $ISPDLSTATEBAD(pdl) =item $ISPDLSTATEGOOD(pdl) =item $SETPDLSTATEBAD(pdl) =item $SETPDLSTATEGOOD(pdl) =back And for use in C sections: =over 4 =item $PDLSTATEISBAD(pdl) =item $PDLSTATEISGOOD(pdl) =item $PDLSTATESETBAD(pdl) =item $PDLSTATESETGOOD(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). As of 2.082, this can be used to set the size of a dimension not used in any C. 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. The default code (which also applies to C) makes a copy of values where it knows how to do so, including C and C. You can also provide a C key, in case your C needs tidying up after it. 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 (for C and C array types for now) that relies on a C<(varname)_count> variable being declared in the XS C section (PP does this for you), to extract 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). =head4 XS-only OtherPars As of 2.083, you can prefix the names of C with C<$>, e.g. pp_def('minus', OtherPars => 'int $swap', # ... ); This will mean they are available in C and C, but not elsewhere in the generated code (e.g. C, C). =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 broadcastloop 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 broadcast 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 broadcast 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 broadcast loop and use its value then inside the tightest broadcast 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()); broadcastloop %{ 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 broadcast loop (i.e. PP generates the appropriate wrapping C code around it). However, when you explicitly use the C function, PDL::PP recognises this and doesn't wrap your code with an additional broadcast loop. This has the effect that code you write outside the broadcast loop is only executed once per transformation and just the code with in the surrounding C<%{ ... %}> pair is placed within the tightest broadcast 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: broadcastloop %{ /* do raw stuff */ %} break; case ASCII: broadcastloop %{ /* 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 broadcastloops 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 => '$SIZE(wn) = $SIZE(n) + $SIZE(m) * $SIZE(m);', Code => ' externalfunc( $P(p), $P(x), $SIZE(m), $SIZE(n), $P(work) ); ' ); As of 2.075, you can use the dimensions of passed-in ndarrays as they are available when the C is run. Before the code in the Code section is executed PP will create the proper storage for C (one area per POSIX thread, in case of broadcasting that multi-threads - the user cannot supply this). Note that you only took the first dimension of C