PDL-VectorValued-1.0.22/0000755000175000017500000000000014414235232014346 5ustar moocowbovinesPDL-VectorValued-1.0.22/MANIFEST.SKIP0000644000175000017500000000041514204432223016240 0ustar moocowbovines\#$ ^\.git \.gz$ ^Utils/.*\.(?:c|pm|xs)$ ~$ \.bs$ \.o$ \.old$ \.cvsignore$ \bCVS\b pm_to_blib$ ^blib ^pdl-core$ ^xs-cookbook$ ^graveyard\. \bMakefile$ \btestme\.perl$ \bppgen\.perl$ \.dont$ \.html$ \.tmp$ ^#Makefile#$ \bMYMETA\b ^reversion\.sh$ ^svntag\.rc$ ^\.github/ PDL-VectorValued-1.0.22/META.json0000644000175000017500000000222714414235232015772 0ustar moocowbovines{ "abstract" : "Assorted utilities for vector-valued PDLs", "author" : [ "Bryan Jurish" ], "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-VectorValued", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "PDL" : "0" } }, "runtime" : { "requires" : { "PDL" : "2.019", "Test::More" : "0" } } }, "release_status" : "stable", "resources" : { "repository" : { "type" : "git", "url" : "https://github.com/moocow-the-bovine/PDL-VectorValued.git", "web" : "https://github.com/moocow-the-bovine/PDL-VectorValued" } }, "version" : "v1.0.22", "x_serialization_backend" : "JSON::PP version 4.06" } PDL-VectorValued-1.0.22/VectorValued/0000755000175000017500000000000014414235232016751 5ustar moocowbovinesPDL-VectorValued-1.0.22/VectorValued/Version.pm0000644000175000017500000000123714414235125020740 0ustar moocowbovines## ## File: PDL::VectorValued::Version.pm ## Author: Bryan Jurish ## Description: Vector utilities for PDL: version ## + <=v1.0.3: this lives in a separate file so that both compile-time and runtime subsystems can use it ## + >=v1.0.4: use perl-reversion from Perl::Version to maintain shared $VERSION ##====================================================================== package PDL::VectorValued::Version; our $VERSION = '1.0.22'; #$PDL::VectorValued::VERSION = $VERSION; ##-- use perl-reversion from Perl::Version instead #$PDL::VectorValued::Dev::VERSION = $VERSION; ##-- use perl-reversion from Perl::Version instead 1; ##-- make perl happy PDL-VectorValued-1.0.22/VectorValued/Makefile.PL0000644000175000017500000000337714204432223020731 0ustar moocowbovinesuse ExtUtils::MakeMaker; ##-- put 'realclean_files' in a variable: avoid MakeMaker puking with: ## ERROR from evaluation of .../ccsutils/Makefile.PL: ## Modification of a read-only value attempted at /usr/share/perl/5.8/Carp/Heavy.pm line 45. our $realclean_files = '*~ *.tmp'; our $has_readme_pod = grep {-e $_ } (, , ); our $has_pdlpp = grep {-e $_ } (<*.pd>); WriteMakefile( NAME=>'PDL::VectorValued::Dev', VERSION_FROM => '../VectorValued.pm', LICENSE => 'perl', #PM => { (map {$_=>"\$(INST_LIBDIR)/CCS/$_"} <*.pm>), }, realclean=>{ FILES=>$realclean_files, }, DIR =>[ #'my_subdir', ], NO_MYMETA => 1, ); ##-- overrides sub MY::depend { package MY; my $inherited = shift->SUPER::depend(@_); if ($::has_readme_pod) { $inherited .= ( "\n\n" ."dist: README.txt\n" ."\n" ."create_distdir: README.txt\n" ."\n" ."distcheck: README.txt\n" ."\n" ."manicheck: README.txt\n" ."\n" ); } return $inherited; } sub MY::special_targets { package MY; my $inherited = shift->SUPER::special_targets(@_); #$inherited =~ s/^(\.SUFFIXES\s*:.*)$/$1 .pod .pm .man .txt .html;/ $inherited .= " .SUFFIXES: .pm .pod .rpod .man .txt .html .pm.html: \tpod2html --outfile \$@ \$< .pm.txt: \tpod2text \$< \$@ .pod.html: \tpod2html --outfile \$@ \$< .pod.txt: \tpod2text \$< \$@ .rpod.html: \tpod2html --outfile \$@ \$< .rpod.txt: \tpod2text \$< \$@ "; return $inherited; } sub MY::top_targets { package MY; my $inherited = shift->SUPER::top_targets(@_); return $inherited; } sub MY::postamble { if ($::has_pdlpp) { return pdlpp_postamble($package); ##-- for PDL::PP (sub-)modules } return ''; } PDL-VectorValued-1.0.22/VectorValued/Dev.pm0000644000175000017500000003441614414235125020036 0ustar moocowbovines## -*- Mode: CPerl -*- ## + CPerl pukes on '/esg'-modifiers.... bummer ## ## $Id$ ## ## File: PDL::VectorValued::Dev.pm ## Author: Bryan Jurish ## Description: Vector utilities for PDL: development ##====================================================================== package PDL::VectorValued::Dev; use PDL::Types; use strict; ##====================================================================== ## Export hacks #use PDL::PP; ##-- do NOT do this! use Exporter; our $VERSION = '1.0.22'; ##-- v1.0.4: use perl-reversion from Perl::Version instead our @ISA = qw(Exporter); our @EXPORT_OK = ( ## ##-- High-level macro expansion qw(vvpp_def vvpp_expand), ## ##-- Type utilities qw(vv_indx_sig vv_indx_typedef), ## ##-- Macro expansion subs qw(vvpp_pdlvar_basename), qw(vvpp_expand_cmpvec vvpp_cmpvec_code), qw(vvpp_expand_cmpval vvpp_cmpval_code), ); our %EXPORT_TAGS = ( all => [@EXPORT_OK], default => [@EXPORT_OK], ); our @EXPORT = @{$EXPORT_TAGS{default}}; ##====================================================================== ## pod: header =pod =head1 NAME PDL::VectorValued::Dev - development utilities for vector-valued PDLs =head1 SYNOPSIS use PDL; use PDL::VectorValued::Dev; ##--------------------------------------------------------------------- ## ... stuff happens =cut ##====================================================================== ## Description =pod =head1 DESCRIPTION PDL::VectorValued::Dev provides some developer utilities for vector-valued PDLs. It produces code for processing with PDL::PP. =cut ##====================================================================== ## PP Utiltiies =pod =head1 PDL::PP Utilities =cut ##-------------------------------------------------------------- ## undef = vvpp_def($name,%args) =pod =head2 vvpp_def($funcName,%args) Wrapper for pp_def() which calls vvpp_expand() on 'Code' and 'BadCode' values in %args. =cut our @_REAL_TYPES = map { $_->{ppsym} } # Older PDLs: # - no native complex types, did not have real key # Newer PDLs: # - native complex types, have real key grep { ! exists $_->{real} || $_->{real} } @PDL::Types::typehash{PDL::Types::typesrtkeys()}; sub vvpp_def { my ($name,%args) = @_; foreach (qw(Code BadCode)) { $args{$_} = vvpp_expand($args{$_}) if (defined($args{$_})); } $args{GenericTypes} = \@_REAL_TYPES unless exists $args{GenericTypes}; PDL::PP::pp_def($name,%args); } ##-------------------------------------------------------------- ## $pp_code = vvpp_expand($vvpp_code) =pod =head2 $pp_code = vvpp_expand($vvpp_code) Expand PDL::VectorValued macros in $vvpp_code. Currently known PDL::VectorValued macros include: MACRO_NAME EXPANSION_SUBROUTINE ---------------------------------------------------------------------- $CMPVEC(...) vvpp_expand_cmpvec(...) $CMPVAL(...) vvpp_expand_cmpval(...) $LB(...) vvpp_expand_lb(...) See the documentation of the individual expansion subroutines for details on calling conventions. You can add your own expansion macros by pushing an expansion manipulating the array @PDL::VectorValued::Dev::MACROS which is just a list of expansion subroutines which take a single argument (string for Code or BadCode) and should return the expanded string. =cut our @MACROS = ( \&vvpp_expand_cmpvec, \&vvpp_expand_cmpval, \&vvpp_expand_lb, ## ## ... more macros here ); sub vvpp_expand { my $str = shift; my ($macro_sub); foreach $macro_sub (@MACROS) { $str = $macro_sub->($str); } $str; } ##-------------------------------------------------------------- ## $pp_code = vvpp_expand_cmpvec($vvpp_code) sub vvpp_expand_cmpvec { my $str = shift; #$str =~ s{\$CMPVEC\s*\(([^\)]*)\)}{vvpp_cmpvec_code(eval($1))}esg; ##-- nope $str =~ s{\$CMPVEC\s*\((.*)\)}{vvpp_cmpvec_code(eval($1))}emg; ##-- single-line macros ONLY return $str; } ##-------------------------------------------------------------- ## $pp_code = vvpp_expand_cmpval($vvpp_code) sub vvpp_expand_cmpval { my $str = shift; $str =~ s{\$CMPVAL\s*\((.*)\)}{vvpp_cmpval_code(eval($1))}emg; ##-- single-line macros ONLY return $str; } ##-------------------------------------------------------------- ## $pp_code = vvpp_expand_lb($vvpp_code) sub vvpp_expand_lb { my $str = shift; $str =~ s{\$LB\s*\((.*)\)}{vvpp_lb_code(eval($1))}emg; ##-- single-line macros ONLY return $str; } ##====================================================================== ## PP Utilities: Types =pod =head1 Type Utilities =cut ##-------------------------------------------------------------- ## $sigtype = vv_indx_sig() =pod =head2 vv_indx_sig() Returns a signature type for representing PDL indices. For PDL E= v2.007 this should be C, otherwise it will be C. =cut sub vv_indx_sig { require PDL::Core; return defined(&PDL::indx) ? 'indx' : 'int'; } ##-------------------------------------------------------------- ## $sigtype = vv_indx_typedef() =pod =head2 vv_indx_typedef() Returns a C typedef for the C type if running under PDL E= v2.007, otherwise just a comment. You can call this from client PDL::PP modules as pp_addhdr(PDL::VectorValued::Dev::vv_indx_typedef); =cut sub vv_indx_typedef { require PDL::Core; if (defined(&PDL::indx)) { return "/*-- PDL_Indx built-in for PDL >= v2.007 --*/\n"; } return "typedef int PDL_Indx; /*-- PDL_Indx typedef for PDL <= v2.007 --*/\n"; } ##====================================================================== ## PP Utilities: Macro Expansion =pod =head1 Macro Expansion Utilities =cut ##-------------------------------------------------------------- ## vvpp_pdlvar_basename() =pod =head2 vvpp_pdlvar_basename($pdlVarString) Gets basename of a PDL::PP variable by removing leading '$' and anything at or following the first open parenthesis: $base = vvpp_pdlvar_basename('$a(n=>0)'); ##-- $base is now 'a' =cut sub vvpp_pdlvar_basename { my $varname = shift; $varname =~ s/^\s*\$\s*//; $varname =~ s/\s*\(.*//; return $varname; } ##-------------------------------------------------------------- ## vvpp_cmpvec_code() =pod =head2 vvpp_cmpvec_code($vec1,$vec2,$dimName,$retvar,%options) Returns PDL::PP code for lexicographically comparing two vectors C<$vec1> and C<$vec2> along the dimension named C<$dim>, storing the comparison result in the C variable C<$retvar>, similar to what: $retvar = ($vec1 <=> $vec2); "ought to" do. Parameters: =over 4 =item $vec1 =item $vec2 PDL::PP string forms of vector PDLs to be compared. Need not be physical. =item $dimName Name of the dimension along which vectors should be compared. =item $retvar Name of a C variable to store the comparison result. =item $options{cvar1} =item $options{cvar2} If specified, temporary values for C<$vec1> (rsp. C<$vec2>) will be stored in the C variable $options{cvar1} (rsp. C<$options{cvar2}>). If unspecified, a new locally scoped C variable C<_vvpp_cmpvec_val1> (rsp. C<_vvpp_cmpvec_val2>) will be declared and used. =back =for example The PDL::PP code for cmpvec() looks something like this: use PDL::VectorValued::Dev; pp_def('cmpvec', Pars => 'a(n); b(n); int [o]cmp()', Code => ( 'int cmpval;' .vvpp_cmpvec_code( '$a()', '$b()', 'n', 'cmpval' ) .$cmp() = cmpval' ); ); =cut sub vvpp_cmpvec_code { my ($vec1,$vec2,$dimName,$retvar,%opts) = @_; ## ##-- sanity checks my $USAGE = 'vvpp_cmpvec_code($vec1,$vec2,$dimName,$retvar,%opts)'; die ("Usage: $USAGE") if (grep {!defined($_)} @_[0,1,2,3]); ## ##-- get PDL variable basenames my $vec1Name = vvpp_pdlvar_basename($vec1); my $vec2Name = vvpp_pdlvar_basename($vec2); my $ppcode = "\n{ /*-- BEGIN vvpp_cmpvec_code --*/\n"; ## ##-- get C variables my ($cvar1,$cvar2); if (!defined($cvar1=$opts{var1})) { $cvar1 = '_vvpp_cmpvec_val1'; $ppcode .= " \$GENERIC(${vec1Name}) ${cvar1};\n"; } if (!defined($cvar2=$opts{var2})) { $cvar2 = '_vvpp_cmpvec_val2'; $ppcode .= " \$GENERIC(${vec2Name}) ${cvar2};\n"; } ## ##-- generate comparison code $ppcode .= ('' ." ${retvar}=0;\n" ." loop (${dimName}) %{\n" ." ${cvar1}=$vec1;\n" ." ${cvar2}=$vec2;\n" ." if (${cvar1} < ${cvar2}) { ${retvar}=-1; break; }\n" ." else if (${cvar1} > ${cvar2}) { ${retvar}= 1; break; }\n" ." %}\n" ."} /*-- END vvpp_cmpvec_code --*/\n" ); ## ##-- ... and return return $ppcode; } ##-------------------------------------------------------------- ## vvpp_cmpval_code() =pod =head2 vvpp_cmpval_code($val1,$val2) Returns PDL::PP expression code for lexicographically comparing two values C<$val1> and C<$val2>, storing the comparison result in the C variable C<$retvar>, similar to what: ($vec1 <=> $vec2); "ought to" do. Parameters: =over 4 =item $val1 =item $val2 PDL::PP string forms of values to be compared. Need not be physical. =back =cut sub vvpp_cmpval_code { my ($val1,$val2) = @_; ## ##-- sanity checks my $USAGE = 'vvpp_cmpval_code($val1,$val2)'; die ("Usage: $USAGE") if (grep {!defined($_)} @_[0,1]); ## ##-- generate comparison code my $ppcode = ('' ."/*-- BEGIN vvpp_cmpval_code --*/ " ." (($val1) < ($val2) ? -1 : (($val1) > ($val2) ? 1 : 0)) " ." /*-- END vvpp_cmpvec_code --*/" ); ## ##-- ... and return return $ppcode; } ##-------------------------------------------------------------- ## vvpp_lb_code() =pod =head2 vvpp_lb_code($find,$vals, $imin,$imax, $retvar, %options) Returns PDL::PP code for binary lower-bound search for the value $find() in the sorted pdl $vals($imin:$imax-1). Parameters: =over 4 =item $find Value to search for or PDL::PP string form of such a value. =item $vals PDL::PP string form of PDL to be searched. $vals should contain a placeholder C<$_> representing the dimension to be searched. =item $retvar Name of a C variable to store the result. On return, C<$retvar> holds the maximum value for C<$_> in C<$vals($imin:$imax-1)> such that C<$vals($_=$retvar) E= $find> and C<$vals($_=$j) E $find> for all C<$j> with C<$imin E= $j E $retvar>, or C<$imin> if no such value for C<$retvar> exists, C<$imin E= $retvar E $imax>. In other words, returns the least index $_ of a match for $find in $vals($imin:$imax-1) whenever a match exists, otherwise the greatest index whose value in $vals($imin:$imax-1) is strictly less than $find if that exists, and $imin if all values in $vals($imin:$imax-1) are strictly greater than $find. =item $options{lovar} =item $options{hivar} =item $options{midvar} =item $options{cmpvar} If specified, temporary indices and comparison values will be stored in the C variables $options{lovar}, $options{hivar}, $options{midvar}, and $options{cmpvar}. If unspecified, new locally scoped C variables C<_vvpp_lb_loval> etc. will be declared and used. =item $options{ubmaxvar} If specified, should be a C variable to hold the index of the last inspected value for $_ in $vals($imin:$imax-1) strictly greater than $find. =back =cut sub vvpp_lb_code { my ($find,$vals,$imin,$imax,$retvar,%opts) = @_; ## ##-- sanity checks my $USAGE = 'vvpp_lb_code($find,$vals,$imin,$imax,$retvar,%opts)'; die ("Usage: $USAGE") if (grep {!defined($_)} @_[0..4]); ## ##-- get PDL variable basenames my $ppcode = "\n{ /*-- BEGIN vvpp_lb_code --*/\n"; ## ##-- get C variables my ($lovar,$hivar,$midvar,$cmpvar); if (!defined($lovar=$opts{lovar})) { $lovar = '_vvpp_lb_loval'; $ppcode .= " long $lovar;"; } if (!defined($hivar=$opts{hivar})) { $hivar = '_vvpp_lb_hival'; $ppcode .= " long $hivar;"; } if (!defined($midvar=$opts{midvar})) { $midvar = '_vvpp_lb_midval'; $ppcode .= " long $midvar;"; } if (!defined($cmpvar=$opts{cmpvar})) { $cmpvar = '_vvpp_lb_cmpval'; $ppcode .= " int $cmpvar;"; } my $ubmaxvar = $opts{ubmaxvar}; ## ##-- generate search code (my $val_mid = $vals) =~ s/\$_/${midvar}/; (my $val_lo = $vals) =~ s/\$_/${lovar}/; (my $val_hi = $vals) =~ s/\$_/${hivar}/; $ppcode .= join("\n", " $lovar = $imin;", " $hivar = $imax;", #($ubmaxvar ? " $ubmaxvar = -1;" : qw()), " while ($hivar - $lovar > 1) {", " $midvar = ($hivar + $lovar) >> 1;", " $cmpvar = ".vvpp_cmpval_code($find, $val_mid).";", " if ($cmpvar > 0) { $lovar = $midvar; }", ($ubmaxvar ? " else if ($cmpvar < 0) { $hivar = $midvar; $ubmaxvar = $midvar; }" : qw()), " else { $hivar = $midvar; }", " }", " if ( $val_lo == $find) $retvar = $lovar;", " else if ($hivar < $imax && $val_hi == $find) $retvar = $hivar;", " else if ($lovar >= $imin && $val_lo < $find) $retvar = $lovar;", " else $retvar = $imin;", "} /*-- END vvpp_lb_code --*/\n", ); ## ##-- ... and return return $ppcode; } 1; ##-- make perl happy ##====================================================================== ## pod: Functions: low-level =pod =head2 Low-Level Functions Some additional low-level functions are provided in the PDL::Ngrams::Utils package. See L for details. =cut ##====================================================================== ## pod: Bugs =pod =head1 KNOWN BUGS =head2 Why not PDL::PP macros? All of these functions would be more intuitive if implemented directly as PDL::PP macros, and thus expanded directly by pp_def() rather than requiring vvpp_def(). At the time of this module's writing, I was unable to figure out how to use the (then undocumented) PDL::PP macro expansion mechanism. As of 2022, PDL::PP offers support for user-defined macros, and this module should be refactored to take advantage of that... but that hasn't happened yet. =cut ##====================================================================== ## pod: Footer =pod =head1 ACKNOWLEDGEMENTS perl by Larry Wall. =head1 AUTHOR Bryan Jurish Emoocow@cpan.orgE PDL by Karl Glazebrook, Tuomas J. Lukka, Christian Soeller, and others. =head1 COPYRIGHT Copyright (c) 2007-2022, Bryan Jurish. All rights reserved. This package is free software. You may redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO perl(1), PDL::PP(3perl). =cut PDL-VectorValued-1.0.22/README.txt0000644000175000017500000000241214241237370016046 0ustar moocowbovines README for PDL::VectorValued ABSTRACT PDL::VectorValued - Assorted PDL utilities treating vectors as values REQUIREMENTS * PDL Tested version(s) 2.4.2, 2.4.3, 2.4.7_001, 2.4.9_015, 2.4.10, 2.019, 2.039 DESCRIPTION PDL::VectorValued provides some generalizations of builtin PDL functions to higher order PDLs which treat vectors in the source PDLs as "data values". BUILDING Build this module as you would any perl module, by doing something akin to the following: gzip -dc distname-XX.YY.tar.gz | tar -xof - cd distname-XX.YY/ perl Makefile.PL make make test # optional make install See perlmodinstall(1) for details. ACKNOWLEDGEMENTS * Perl by Larry Wall * PDL by Karl Glazebrook, Tuomas J. Lukka, Christian Soeller, and others. * Code for rlevec() and rldvec() derived from the PDL builtin functions rle() and rld() in $PDL_SRC_ROOT/Basic/Slices/slices.pd AUTHOR Bryan Jurish COPYRIGHT Copyright (c) 2007-2022, Bryan Jurish. All rights reserved. This package is free software, and entirely without warranty. You may redistribute it and/or modify it under the same terms as Perl itself. PDL-VectorValued-1.0.22/Utils/0000755000175000017500000000000014414235232015446 5ustar moocowbovinesPDL-VectorValued-1.0.22/Utils/Utils.pm0000644000175000017500000003747314414235213017121 0ustar moocowbovines # # GENERATED WITH PDL::PP! Don't modify! # package PDL::VectorValued::Utils; @EXPORT_OK = qw( PDL::PP vv_rlevec PDL::PP vv_rldvec PDL::PP vv_enumvec PDL::PP vv_enumvecg PDL::PP vv_rleseq PDL::PP vv_rldseq PDL::PP vv_vsearchvec PDL::PP vv_cmpvec vv_qsortvec vv_qsortveci PDL::PP vv_union PDL::PP vv_intersect PDL::PP vv_setdiff PDL::PP v_union PDL::PP v_intersect PDL::PP v_setdiff PDL::PP vv_vcos ); %EXPORT_TAGS = (Func=>[@EXPORT_OK]); use PDL::Core; use PDL::Exporter; use DynaLoader; $PDL::VectorValued::Utils::VERSION = 1.0.22; @ISA = ( 'PDL::Exporter','DynaLoader' ); push @PDL::Core::PP, __PACKAGE__; bootstrap PDL::VectorValued::Utils $VERSION; use strict; =pod =head1 NAME PDL::VectorValued::Utils - Low-level utilities for vector-valued PDLs =head1 SYNOPSIS use PDL; use PDL::VectorValued::Utils; ##--------------------------------------------------------------------- ## ... stuff happens =cut =head1 FUNCTIONS =cut =pod =head1 Vector-Based Run-Length Encoding and Decoding =cut =head2 vv_rlevec =for sig Signature: (c(M,N); indx [o]a(N); [o]b(M,N)) 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 ocurring 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: PDL::Slices::rle, PDL::Ufunc::qsortvec, PDL::Primitive::uniqvec =for bad vv_rlevec does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *vv_rlevec = \&PDL::vv_rlevec; =head2 vv_rldvec =for sig Signature: (int a(N); b(M,N); [o]c(M,N)) 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: PDL::Slices::rld. =for bad vv_rldvec does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut sub PDL::vv_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 (@dims) = $a->dims; shift(@dims); $c = $b->zeroes($b->type,$rowlen,$size,@dims); } &PDL::_vv_rldvec_int($a,$b,$c); return $c; } *vv_rldvec = \&PDL::vv_rldvec; =head2 vv_enumvec =for sig Signature: (v(M,N); int [o]k(N)) 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 ocurring 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(). =for bad vv_enumvec does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *vv_enumvec = \&PDL::vv_enumvec; =head2 vv_enumvecg =for sig Signature: (v(M,N); int [o]k(N)) 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 ocurring in $v). Basically does the same thing as: $k = $v->vsearchvec($v->uniqvec); ... but somewhat more efficiently. =for bad vv_enumvecg does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *vv_enumvecg = \&PDL::vv_enumvecg; =head2 vv_rleseq =for sig Signature: (c(N); indx [o]a(N); [o]b(N)) 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 PDL::Slices::rle. =for bad vv_rleseq does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *vv_rleseq = \&PDL::vv_rleseq; =head2 vv_rldseq =for sig Signature: (int a(N); b(N); [o]c(M)) 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: PDL::Slices::rld. =for bad vv_rldseq does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut sub PDL::vv_rldseq { my ($a,$b,$c) = @_; if (!defined($c)) { my $size = $a->sumover->max; my (@dims) = $a->dims; shift(@dims); $c = $b->zeroes($b->type,$size,@dims); } &PDL::_vv_rldseq_int($a,$b,$c); return $c; } *vv_rldseq = \&PDL::vv_rldseq; =head2 vv_vsearchvec =for sig Signature: (find(M); which(M,N); int [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: PDL::Primitive::vsearch(). =for bad vv_vsearchvec does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *vv_vsearchvec = \&PDL::vv_vsearchvec; =pod =head1 Vector-Valued Sorting and Comparison The following functions are provided for lexicographic sorting of vectors, rsp. axis indices. As of PDL::VectorValued v1.0.12, vv_qsortvec() and vv_qsortveci() are just deprecated aliases for the builtin PDL functions of the same names. Older versions of this module used a dedicated implementation as a workaround for a bug in PDL-2.4.3, which has long since been fixed. =cut =head2 vv_cmpvec =for sig Signature: (a(N); b(N); int [o]cmp()) =for ref Lexicographically compare a pair of vectors. =for bad vv_cmpvec does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut *vv_cmpvec = \&PDL::vv_cmpvec; =head2 vv_qsortvec =for sig Signature: (a(n,m); [o]b(n,m)) =for ref Deprecated alias for L, which see for details. =head2 vv_qsortveci =for sig Signature: (a(n,m); indx [o]ix(m)) =for ref Deprecated alias for L, which see for details. =cut BEGIN { *vv_qsortvec = *PDL::vv_qsortvec = *PDL::qsortvec; *vv_qsortveci = *PDL::vv_qsortveci = *PDL::qsortveci; } =pod =head1 Vector-Valued Set Operations The following functions are provided for set operations on sorted vector-valued PDLs. =cut =head2 vv_union =for sig Signature: (a(M,NA); b(M,NB); [o]c(M,NC); int [o]nc()) 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. =for bad vv_union does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut sub PDL::vv_union { my ($a,$b,$c,$nc) = @_; $c = PDL->null if (!defined($nc)); $nc = PDL->null if (!defined($nc)); &PDL::_vv_union_int($a,$b,$c,$nc); return ($c,$nc) if (wantarray); return $c->slice(",0:".($nc->max-1)); } *vv_union = \&PDL::vv_union; =head2 vv_intersect =for sig Signature: (a(M,NA); b(M,NB); [o]c(M,NC); int [o]nc()) 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. =for bad vv_intersect does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut sub PDL::vv_intersect { my ($a,$b,$c,$nc) = @_; $c = PDL->null if (!defined($c)); $nc = PDL->null if (!defined($nc)); &PDL::_vv_intersect_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)])); } *vv_intersect = \&PDL::vv_intersect; =head2 vv_setdiff =for sig Signature: (a(M,NA); b(M,NB); [o]c(M,NC); int [o]nc()) 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. =for bad vv_setdiff does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut sub PDL::vv_setdiff { my ($a,$b,$c,$nc) = @_; $c = PDL->null if (!defined($c)); $nc = PDL->null if (!defined($nc)); &PDL::_vv_setdiff_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)])); } *vv_setdiff = \&PDL::vv_setdiff; =pod =head1 Sorted Vector Set Operations The following functions are provided for set operations on flat sorted PDLs with unique values. They may be more efficient to compute than the corresponding implementations via PDL::Primitive::setops(). =cut =head2 v_union =for sig Signature: (a(NA); b(NB); [o]c(NC); int [o]nc()) 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. =for bad v_union does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut sub PDL::v_union { my ($a,$b,$c,$nc) = @_; $c = PDL->null if (!defined($c)); $nc = PDL->null if (!defined($nc)); &PDL::_v_union_int($a,$b,$c,$nc); return ($c,$nc) if (wantarray); return $c->slice("0:".($nc->max-1)); } *v_union = \&PDL::v_union; =head2 v_intersect =for sig Signature: (a(NA); b(NB); [o]c(NC); int [o]nc()) 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. =for bad v_intersect does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut sub PDL::v_intersect { my ($a,$b,$c,$nc) = @_; $c = PDL->null if (!defined($c)); $nc = PDL->null if (!defined($nc)); &PDL::_v_intersect_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)])); } *v_intersect = \&PDL::v_intersect; =head2 v_setdiff =for sig Signature: (a(NA); b(NB); [o]c(NC); int [o]nc()) 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. =for bad v_setdiff does not process bad values. It will set the bad-value flag of all output piddles if the flag is set for any of the input piddles. =cut sub PDL::v_setdiff { my ($a,$b,$c,$nc) = @_; $c = PDL->null if (!defined($c)); $nc = PDL->null if (!defined($nc)); &PDL::_v_setdiff_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)])); } *v_setdiff = \&PDL::v_setdiff; =pod =head1 Miscellaneous Vector-Valued Operations =cut =head2 vv_vcos =for sig Signature: (a(M,N);b(M);float+ [o]vcos(N)) Computes the vector cosine similarity of a dense vector $b() with respect to each row $a(*,i) of a dense PDL $a(). This is basically the same thing as: ($a * $b)->sumover / ($a->pow(2)->sumover->sqrt * $b->pow(2)->sumover->sqrt) ... but should be must faster to compute, and avoids allocating potentially large temporaries for the vector magnitudes. Output values in $vcos() are cosine similarities in the range [-1,1], except for zero-magnitude vectors which will result in NaN values in $vcos(). You can use PDL threading to batch-compute distances for multiple $b() vectors simultaneously: $bx = random($M, $NB); ##-- get $NB random vectors of size $N $vcos = vv_vcos($a,$bx); ##-- $vcos(i,j) ~ sim($a(,i),$b(,j)) =for bad vv_vcos() will set the bad status flag on the output piddle $vcos() if it is set on either of the input piddles $a() or $b(), but BAD values will otherwise be ignored for computing the cosine similarity. =cut *vv_vcos = \&PDL::vv_vcos; ##--------------------------------------------------------------------- =pod =head1 ACKNOWLEDGEMENTS =over 4 =item * Perl by Larry Wall =item * PDL by Karl Glazebrook, Tuomas J. Lukka, Christian Soeller, and others. =item * Code for rlevec() and rldvec() derived from the PDL builtin functions rle() and rld() in $PDL_SRC_ROOT/Basic/Slices/slices.pd =back =cut ##---------------------------------------------------------------------- =pod =head1 KNOWN BUGS Probably many. =cut ##--------------------------------------------------------------------- =pod =head1 AUTHOR Bryan Jurish Emoocow@cpan.orgE =head1 COPYRIGHT =over 4 =item * Code for qsortvec() copyright (C) Tuomas J. Lukka 1997. 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. =item * All other parts copyright (c) 2007-2022, Bryan Jurish. All rights reserved. This package is free software, and entirely without warranty. You may redistribute it and/or modify it under the same terms as Perl itself. =back =head1 SEE ALSO perl(1), PDL(3perl) =cut ; # Exit with OK status 1; PDL-VectorValued-1.0.22/Utils/utils.pd0000644000175000017500000006563714414235125017155 0ustar moocowbovines##-*- Mode: CPerl -*- ##====================================================================== ## Header Administrivia ##====================================================================== #require "../VectorValued/Version.pm"; ##-- use perl-reversion from Perl::Version instead my $VERSION = '1.0.22'; pp_setversion($VERSION); require "../VectorValued/Dev.pm"; PDL::VectorValued::Dev->import(); ##------------------------------------------------------ ## PDL_Indx type my $INDX = vv_indx_sig(); pp_addhdr( vv_indx_typedef() ); ##------------------------------------------------------ ## pm additions pp_addpm({At=>'Top'},<<'EOPM'); use strict; =pod =head1 NAME PDL::VectorValued::Utils - Low-level utilities for vector-valued PDLs =head1 SYNOPSIS use PDL; use PDL::VectorValued::Utils; ##--------------------------------------------------------------------- ## ... stuff happens =cut EOPM ## /pm additions ##------------------------------------------------------ ##------------------------------------------------------ ## Exports: None #pp_export_nothing(); ##------------------------------------------------------ ## Includes / defines pp_addhdr(<<'EOH'); EOH ##====================================================================== ## C Utilities ##====================================================================== # (none) ##====================================================================== ## PDL::PP Wrappers ##====================================================================== ##====================================================================== ## Vector-Based Run-Length Encoding and Decoding ##====================================================================== pp_addpm(<<'EOPM'); =pod =head1 Vector-Based Run-Length Encoding and Decoding =cut EOPM ##------------------------------------------------------ ## rlevec() pp_def('vv_rlevec', Pars => "c(M,N); $INDX \[o]a(N); [o]b(M,N)", Code =><<'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', 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 ocurring 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: PDL::Slices::rle, PDL::Ufunc::qsortvec, PDL::Primitive::uniqvec EOD ); ##------------------------------------------------------ ## rldvec() pp_def('vv_rldvec', Pars => 'int a(N); b(M,N); [o]c(M,N)', PMCode=><<'EOC', sub PDL::vv_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 (@dims) = $a->dims; shift(@dims); $c = $b->zeroes($b->type,$rowlen,$size,@dims); } &PDL::_vv_rldvec_int($a,$b,$c); return $c; } EOC Code =><<'EOC', int i,nrows,bn,cn=0, sn=$SIZE(N); for (bn=0; bnbn); for (i=0; icn) = $b(N=>bn); %} cn++; } } EOC Doc =><<'EOD' 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: PDL::Slices::rld. EOD ); ##------------------------------------------------------ ## enumvec() pp_def('vv_enumvec', Pars => 'v(M,N); int [o]k(N)', Code =><<'EOC', int 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', 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 ocurring 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(). EOD ); ##------------------------------------------------------ ## enumvecg() pp_def('vv_enumvecg', Pars => 'v(M,N); int [o]k(N)', Code =><<'EOC', int 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', 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 ocurring in $v). Basically does the same thing as: $k = $v->vsearchvec($v->uniqvec); ... but somewhat more efficiently. EOD ); ##------------------------------------------------------ ## rleseq() pp_def('vv_rleseq', Pars => "c(N); $INDX \[o]a(N); [o]b(N)", Code=><<'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', 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 PDL::Slices::rle. EOD ); ##------------------------------------------------------ ## rldseq() pp_def('vv_rldseq', Pars => 'int a(N); b(N); [o]c(M)', PMCode=><<'EOC', sub PDL::vv_rldseq { my ($a,$b,$c) = @_; if (!defined($c)) { my $size = $a->sumover->max; my (@dims) = $a->dims; shift(@dims); $c = $b->zeroes($b->type,$size,@dims); } &PDL::_vv_rldseq_int($a,$b,$c); return $c; } EOC Code =><<'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' 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: PDL::Slices::rld. EOD ); ##====================================================================== ## Vector Search ##====================================================================== ##------------------------------------------------------ ## vsearchvec() : binary search on a (sorted) vector list vvpp_def ('vv_vsearchvec', Pars => 'find(M); which(M,N); int [o]found();', Code => (q( int carp=0; threadloop %{ long sizeM=$SIZE(M), sizeN=$SIZE(N), n1=sizeN-1; long nlo=-1, nhi=n1, nn; $GENERIC() findval, whichval, whichval1; int cmpval, is_asc_sorted; // //-- get sort direction $CMPVEC('$which(N=>n1)','$which(N=>0)','M','cmpval',var1=>'whichval1',var2=>'whichval'); is_asc_sorted = (cmpval > 0); // //-- binary search while (nhi-nlo > 1) { nn = (nhi+nlo) >> 1; $CMPVEC('$find()','$which(N=>nn)','M','cmpval', var1=>'findval',var2=>'whichval'); 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', var1=>'findval',var2=>'whichval'); 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: PDL::Primitive::vsearch(). EOD ); ##====================================================================== ## Vector Sorting and Comparison ##====================================================================== pp_addpm(<<'EOPM'); =pod =head1 Vector-Valued Sorting and Comparison The following functions are provided for lexicographic sorting of vectors, rsp. axis indices. As of PDL::VectorValued v1.0.12, vv_qsortvec() and vv_qsortveci() are just deprecated aliases for the builtin PDL functions of the same names. Older versions of this module used a dedicated implementation as a workaround for a bug in PDL-2.4.3, which has long since been fixed. =cut EOPM ##------------------------------------------------------ ## cmpvec() : make vector comparison available in perl vvpp_def ('vv_cmpvec', Pars => 'a(N); b(N); int [o]cmp()', Code => q($CMPVEC('$a()','$b()','N','$cmp()')), Doc=><<'EOD' Lexicographically compare a pair of vectors. EOD ); ##------------------------------------------------------ ## vv_qsortvec(), vv_qsortveci() : compatibility wrappers for PDL::Ufunc::qsortvec(), PDL::Ufunc::qsortveci() pp_addpm(<<'EOPM'); =head2 vv_qsortvec =for sig Signature: (a(n,m); [o]b(n,m)) =for ref Deprecated alias for L, which see for details. =head2 vv_qsortveci =for sig Signature: (a(n,m); indx [o]ix(m)) =for ref Deprecated alias for L, which see for details. =cut BEGIN { *vv_qsortvec = *PDL::vv_qsortvec = *PDL::qsortvec; *vv_qsortveci = *PDL::vv_qsortveci = *PDL::qsortveci; } EOPM pp_add_exported('vv_qsortvec'); pp_add_exported('vv_qsortveci'); ##====================================================================== ## Vector-Valued Set Operations ##====================================================================== pp_addpm(<<'EOPM'); =pod =head1 Vector-Valued Set Operations The following functions are provided for set operations on sorted vector-valued PDLs. =cut EOPM ##------------------------------------------------------ ## vv_union() : set union vvpp_def ('vv_union', Pars => 'a(M,NA); b(M,NB); [o]c(M,NC); int [o]nc()', #RedoDimsCode => '$SIZE(NC) = $SIZE(NA) + $SIZE(NB);', # PDL >= v2.075 RedoDimsCode => (q( pdl * dpdla = $PDL(a); pdl * dpdlb = $PDL(b); PDL_Indx na = dpdla->ndims > 1 ? dpdla->dims[1] : 1; PDL_Indx nb = dpdlb->ndims > 1 ? dpdlb->dims[1] : 1; $SIZE(NC) = na + nb; )), PMCode=> (q( sub PDL::vv_union { my ($a,$b,$c,$nc) = @_; $c = PDL->null if (!defined($nc)); $nc = PDL->null if (!defined($nc)); &PDL::_vv_union_int($a,$b,$c,$nc); return ($c,$nc) if (wantarray); return $c->slice(",0:".($nc->max-1)); } )), Code => (q( PDL_Indx nai=0, nbi=0, nci=0, sizeNA=$SIZE(NA), sizeNB=$SIZE(NB), sizeNC=$SIZE(NC); $GENERIC() aval, bval; int cmpval; for ( ; nci < sizeNC; nci++) { if (nai < sizeNA && nbi < sizeNB) { $CMPVEC('$a(NA=>nai)','$b(NB=>nbi)','M','cmpval',var1=>'aval',var2=>'bval'); } 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' 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. EOD ); ##------------------------------------------------------ ## vv_intersect() : set intersection vvpp_def ('vv_intersect', Pars => 'a(M,NA); b(M,NB); [o]c(M,NC); int [o]nc()', #RedoDimsCode => '$SIZE(NC) = $SIZE(NA) < $SIZE(NB) ? $SIZE(NA) : $SIZE(NB);', # PDL >= v2.075 RedoDimsCode => (q( pdl * dpdla = $PDL(a); pdl * dpdlb = $PDL(b); PDL_Indx na = dpdla->ndims > 1 ? dpdla->dims[1] : 1; PDL_Indx nb = dpdlb->ndims > 1 ? dpdlb->dims[1] : 1; $SIZE(NC) = na < nb ? na : nb; )), PMCode=> (q( sub PDL::vv_intersect { my ($a,$b,$c,$nc) = @_; $c = PDL->null if (!defined($c)); $nc = PDL->null if (!defined($nc)); &PDL::_vv_intersect_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)])); } )), Code => (q( PDL_Indx nai=0, nbi=0, nci=0, sizeNA=$SIZE(NA), sizeNB=$SIZE(NB), sizeNC=$SIZE(NC); $GENERIC() aval, bval; int cmpval; for ( ; nci < sizeNC && nai < sizeNA && nbi < sizeNB; ) { $CMPVEC('$a(NA=>nai)','$b(NB=>nbi)','M','cmpval',var1=>'aval',var2=>'bval'); // 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' 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. EOD ); ##------------------------------------------------------ ## vv_setdiff() : set difference vvpp_def ('vv_setdiff', Pars => 'a(M,NA); b(M,NB); [o]c(M,NC); int [o]nc()', #RedoDimsCode => '$SIZE(NC) = $SIZE(NA);', # PDL >= v2.075 RedoDimsCode => (q( pdl * dpdla = $PDL(a); $SIZE(NC) = dpdla->ndims > 1 ? dpdla->dims[1] : 1; )), PMCode=> (q( sub PDL::vv_setdiff { my ($a,$b,$c,$nc) = @_; $c = PDL->null if (!defined($c)); $nc = PDL->null if (!defined($nc)); &PDL::_vv_setdiff_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)])); } )), Code => (q( PDL_Indx nai=0, nbi=0, nci=0, sizeNA=$SIZE(NA), sizeNB=$SIZE(NB), sizeNC=$SIZE(NC); $GENERIC() aval, bval; int cmpval; for ( ; nci < sizeNC && nai < sizeNA && nbi < sizeNB ; ) { $CMPVEC('$a(NA=>nai)','$b(NB=>nbi)','M','cmpval',var1=>'aval',var2=>'bval'); // 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' 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. EOD ); ##====================================================================== ## Sorted Vector Set Operations ##====================================================================== pp_addpm(<<'EOPM'); =pod =head1 Sorted Vector Set Operations The following functions are provided for set operations on flat sorted PDLs with unique values. They may be more efficient to compute than the corresponding implementations via PDL::Primitive::setops(). =cut EOPM ##------------------------------------------------------ ## v_union() : flat set union vvpp_def ('v_union', Pars => 'a(NA); b(NB); [o]c(NC); int [o]nc()', #RedoDimsCode => '$SIZE(NC) = $SIZE(NA) + $SIZE(NB);', # PDL >= v2.075 RedoDimsCode => (q( pdl * dpdla = $PDL(a); pdl * dpdlb = $PDL(b); $SIZE(NC) = (dpdla->ndims > 0 ? dpdla->dims[0] : 1) + (dpdlb->ndims > 0 ? dpdlb->dims[0] : 1); )), PMCode=> (q( sub PDL::v_union { my ($a,$b,$c,$nc) = @_; $c = PDL->null if (!defined($c)); $nc = PDL->null if (!defined($nc)); &PDL::_v_union_int($a,$b,$c,$nc); return ($c,$nc) if (wantarray); return $c->slice("0:".($nc->max-1)); } )), 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' 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. EOD ); ##------------------------------------------------------ ## v_intersect() : flat set intersection vvpp_def ('v_intersect', Pars => 'a(NA); b(NB); [o]c(NC); int [o]nc()', #RedoDimsCode => '$SIZE(NC) = $SIZE(NA) < $SIZE(NB) ? $SIZE(NA) : $SIZE(NB);', # PDL >= v2.075 RedoDimsCode => (q( pdl * dpdla = $PDL(a); pdl * dpdlb = $PDL(b); PDL_Indx na = dpdla->ndims > 0 ? dpdla->dims[0] : 1; PDL_Indx nb = dpdlb->ndims > 0 ? dpdlb->dims[0] : 1; $SIZE(NC) = na < nb ? na : nb; )), PMCode=> (q( sub PDL::v_intersect { my ($a,$b,$c,$nc) = @_; $c = PDL->null if (!defined($c)); $nc = PDL->null if (!defined($nc)); &PDL::_v_intersect_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)])); } )), 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' 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. EOD ); ##------------------------------------------------------ ## v_setdiff() : flat set difference vvpp_def ('v_setdiff', Pars => 'a(NA); b(NB); [o]c(NC); int [o]nc()', #RedoDimsCode => '$SIZE(NC) = $SIZE(NA);', # PDL >= v2.075 RedoDimsCode => (q( pdl * dpdla = $PDL(a); $SIZE(NC) = dpdla->ndims > 0 ? dpdla->dims[0] : 1; )), PMCode=> (q( sub PDL::v_setdiff { my ($a,$b,$c,$nc) = @_; $c = PDL->null if (!defined($c)); $nc = PDL->null if (!defined($nc)); &PDL::_v_setdiff_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)])); } )), 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' 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. EOD ); ##====================================================================== ## Miscellaneous Vector-Valued Operations ##====================================================================== pp_addpm(<<'EOPM'); =pod =head1 Miscellaneous Vector-Valued Operations =cut EOPM ##-------------------------------------------------------------- ## vv_vcos() my $vv_vcos_code = ' $GENERIC(vcos) anorm, bnorm, aval, vval; threadloop %{ /*-- initialize: bnorm --*/ bnorm = 0; loop(M) %{ #ifdef PDL_BAD_CODE if ($ISGOOD(b())) #endif bnorm += $b() * $b(); %} bnorm = sqrt(bnorm); if (bnorm == 0) { /*-- null-vector b(): set all vcos()=NAN --*/ loop (N) %{ $vcos() = NAN; %} } else { /*-- usual case: compute values for N-slice of b() --*/ loop (N) %{ anorm = 0; vval = 0; loop (M) %{ #ifdef PDL_BAD_CODE if ($ISGOOD(a())) { aval = $a(); anorm += aval * aval; if ($ISGOOD(b())) vval += aval * $b(); } #else aval = $a(); anorm += aval * aval; vval += aval * $b(); #endif %} /*-- normalize --*/ anorm = sqrt(anorm); if (anorm != 0) { /*-- usual case a(), b() non-null --*/ $vcos() = vval / (anorm * bnorm); } else { /*-- null-vector a(): set vcos()=NAN --*/ $vcos() = NAN; } %} } %} '; pp_def('vv_vcos', Pars => join('', "a(M,N);", ##-- logical (D,T) "b(M);", ##-- logical (D,1) "float+ [o]vcos(N);", ##-- logical (T) ), HandleBad => 1, Code => $vv_vcos_code, BadCode => $vv_vcos_code, CopyBadStatusCode => q{ if ( $ISPDLSTATEBAD(a) || $ISPDLSTATEBAD(b) ) { $SETPDLSTATEBAD(vcos); } }, Doc => q{ Computes the vector cosine similarity of a dense vector $b() with respect to each row $a(*,i) of a dense PDL $a(). This is basically the same thing as: ($a * $b)->sumover / ($a->pow(2)->sumover->sqrt * $b->pow(2)->sumover->sqrt) ... but should be must faster to compute, and avoids allocating potentially large temporaries for the vector magnitudes. Output values in $vcos() are cosine similarities in the range [-1,1], except for zero-magnitude vectors which will result in NaN values in $vcos(). You can use PDL threading to batch-compute distances for multiple $b() vectors simultaneously: $bx = random($M, $NB); ##-- get $NB random vectors of size $N $vcos = vv_vcos($a,$bx); ##-- $vcos(i,j) ~ sim($a(,i),$b(,j)) }, BadDoc=> q{ vv_vcos() will set the bad status flag on the output piddle $vcos() if it is set on either of the input piddles $a() or $b(), but BAD values will otherwise be ignored for computing the cosine similarity. }, ); ##====================================================================== ## Footer Administrivia ##====================================================================== ##------------------------------------------------------ ## pm additions: footer pp_addpm(<<'EOPM'); ##--------------------------------------------------------------------- =pod =head1 ACKNOWLEDGEMENTS =over 4 =item * Perl by Larry Wall =item * PDL by Karl Glazebrook, Tuomas J. Lukka, Christian Soeller, and others. =item * Code for rlevec() and rldvec() derived from the PDL builtin functions rle() and rld() in $PDL_SRC_ROOT/Basic/Slices/slices.pd =back =cut ##---------------------------------------------------------------------- =pod =head1 KNOWN BUGS Probably many. =cut ##--------------------------------------------------------------------- =pod =head1 AUTHOR Bryan Jurish Emoocow@cpan.orgE =head1 COPYRIGHT =over 4 =item * Code for qsortvec() copyright (C) Tuomas J. Lukka 1997. 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. =item * All other parts copyright (c) 2007-2022, Bryan Jurish. All rights reserved. This package is free software, and entirely without warranty. You may redistribute it and/or modify it under the same terms as Perl itself. =back =head1 SEE ALSO perl(1), PDL(3perl) =cut EOPM # Always make sure that you finish your PP declarations with # pp_done pp_done(); ##---------------------------------------------------------------------- PDL-VectorValued-1.0.22/Utils/Makefile.PL0000644000175000017500000000101214204432223017406 0ustar moocowbovinesuse PDL::Core::Dev; use ExtUtils::MakeMaker; require "../pdlmaker.plm"; PDL::Core::Dev->import(); $package = ['utils.pd','Utils','PDL::VectorValued::Utils']; %hash = pdlmaker_init($package); $hash{AUTHOR} = 'Bryan Jurish'; $hash{VERSION_FROM} = '../VectorValued.pm', $hash{PREREQ_PM}{PDL} = $hash{CONFIGURE_REQUIRES}{PDL} = 0; #push(@{$hash{LIBS}}, '-lm'); ##-- ? #$hash{INC} .= ''; #$hash{OBJECT} .= ''; $hash{DIR} = []; $hash{realclean}{FILES} .= '*~ *.tmp'; $hash{NO_MYMETA} = 1; WriteMakefile(%hash); PDL-VectorValued-1.0.22/t/0000755000175000017500000000000014414235232014611 5ustar moocowbovinesPDL-VectorValued-1.0.22/t/04_types.t0000644000175000017500000000152114244750071016450 0ustar moocowbovines# -*- Mode: CPerl -*- # t/04_types.t: test PDL::VectorValued type-wrappers use Test::More tests=>2; ##-- common subs my $TEST_DIR; BEGIN { use File::Basename; use Cwd; $TEST_DIR = Cwd::abs_path dirname( __FILE__ ); eval qq{use lib ("$TEST_DIR/$_/blib/lib","$TEST_DIR/$_/blib/arch");} foreach (qw(..)); do "$TEST_DIR/common.plt" or die("$0: failed to load $TEST_DIR/common.plt: $@"); } ##-- common modules use PDL; use PDL::VectorValued; #use PDL::VectorValued::Dev; ##-------------------------------------------------------------- ## data ## 1..2: types isok("isa(vv_indx,PDL::Type)", UNIVERSAL::isa(vv_indx,'PDL::Type')); if (defined(&PDL::indx)) { isok("vv_indx == PDL::indx (PDL >= v2.007)", vv_indx(), PDL::indx); } else { isok("vv_indx == PDL::long (PDL < v2.007)", vv_indx(), PDL::long); } print "\n"; # end of t/04_types.t PDL-VectorValued-1.0.22/t/00_basic.t0000644000175000017500000000013214054377310016356 0ustar moocowbovines##-*- Mode: CPerl -*- use Test::More tests=>2; use_ok 'PDL'; use_ok 'PDL::VectorValued'; PDL-VectorValued-1.0.22/t/01_rlevec.t0000644000175000017500000000613014244750071016562 0ustar moocowbovines# -*- Mode: CPerl -*- # t/01_rlevec.t: test rlevec/rldvec use Test::More tests => 17; ##-- common subs my $TEST_DIR; BEGIN { use File::Basename; use Cwd; $TEST_DIR = Cwd::abs_path dirname( __FILE__ ); eval qq{use lib ("$TEST_DIR/$_/blib/lib","$TEST_DIR/$_/blib/arch");} foreach (qw(..)); do "$TEST_DIR/common.plt" or die("$0: failed to load $TEST_DIR/common.plt: $@"); } ##-- common modules use PDL; use PDL::VectorValued; ##-- common vars my ($tmp); ##-------------------------------------------------------------- ## rlevec(), rldvec(): 2d ONLY ## 1..2: test rlevec() my $p = pdl([[1,2],[1,2],[1,2],[3,4],[3,4],[5,6]]); my ($pf,$pv) = vv_rlevec($p); my $pf_expect = pdl(long,[3,2,1,0,0,0]); my $pv_expect = pdl([[1,2],[3,4],[5,6],[0,0],[0,0],[0,0]]); pdlok("rlevec():counts", $pf, $pf_expect); pdlok("rlevec():elts", $pv, $pv_expect); ## 3..3: test rldvec() my $pd = vv_rldvec($pf,$pv); pdlok("rldvec()", $pd, $p); ## 4..4: test enumvec my $pk = vv_enumvec($p); pdlok("enumvec()", $pk, pdl(long,[0,1,2,0,1,0])); ## 5..5: test enumvecg $pk = vv_enumvecg($p); pdlok("enumvecg()", $pk, pdl(long,[0,0,0,1,1,2])); ##-------------------------------------------------------------- ## rleND, rldND: 2d ## 6..7: test rleND(): 2d ($pf,$pv) = vv_rleND($p); pdlok("rleND():2d:counts", $pf, $pf_expect); pdlok("rleND():2d:elts", $pv, $pv_expect); ## 8..8: test rldND(): 2d $pd = vv_rldND($pf,$pv); pdlok("rldND():2d", $pd, $p); ##-------------------------------------------------------------- ## rleND, rldND: Nd my $pnd1 = (1 *(sequence(long, 2,3 )+1))->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); ($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) = vv_rleND($p_nd); pdlok("rleND():Nd:counts", $pf_nd, $pf_expect_nd); pdlok("rleND():Nd:elts", $pv_nd, $pv_expect_nd); ## 11..11: test rldND(): Nd my $pd_nd = vv_rldND($pf_nd,$pv_nd); pdlok("rldND():Nd", $pd_nd, $p_nd); ##-------------------------------------------------------------- ## 12..12: test enumvec(): nd my $v_nd = $p_nd->clump(2); my $k_nd = $v_nd->vv_enumvec(); pdlok("enumvec():Nd", $k_nd, pdl(long,[0,1,2,0,1,0,0])); ##-------------------------------------------------------------- ## 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->vv_rldseq($offs); isok("rldseq():type", $seqs_got->type, $seqs->type); pdlok("rldseq():data", $seqs_got, $seqs); my ($len_got,$off_got) = $seqs->vv_rleseq(); isok("rleseq():type", $off_got->type, $seqs->type); pdlok("rleseq():lens", $len_got->where($len_got), $lens->where($lens)); pdlok("rleseq():offs", $off_got->where($len_got), $offs->where($lens)); print "\n"; # end of t/01_rlevec.t PDL-VectorValued-1.0.22/t/02_cmpvec.t0000644000175000017500000000307614244750071016566 0ustar moocowbovines# -*- Mode: CPerl -*- # t/02_cmpvec.t: test cmpvec, vv_qsortvec, vsearchvec use Test::More tests=>8; ##-- common subs my $TEST_DIR; BEGIN { use File::Basename; use Cwd; $TEST_DIR = Cwd::abs_path dirname( __FILE__ ); eval qq{use lib ("$TEST_DIR/$_/blib/lib","$TEST_DIR/$_/blib/arch");} foreach (qw(..)); do "$TEST_DIR/common.plt" or die("$0: failed to load $TEST_DIR/common.plt: $@"); } ##-- common modules use PDL; use PDL::VectorValued; ##-------------------------------------------------------------- ## cmpvec ## 1..3: test cmpvec my $vdim = 4; my $v1 = zeroes($vdim); my $v2 = pdl($v1); $v2->set(-1,1); isok("cmpvec:1d:<", $v1->vv_cmpvec($v2)<0); isok("cmpvec:1d:>", $v2->vv_cmpvec($v1)>0); isok("cmpvec:1d:==", $v1->vv_cmpvec($v1)->sclr, 0); ##-------------------------------------------------------------- ## vv_qsortvec, vv_qsortveci ##-- 4..5: qsortvec, qsortveci my $p2d = pdl([[1,2],[3,4],[1,3],[1,2],[3,3]]); pdlok("vv_qsortvec", $p2d->vv_qsortvec, pdl(long,[[1,2],[1,2],[1,3],[3,3],[3,4]])); pdlok("vv_qsortveci", $p2d->dice_axis(1,$p2d->vv_qsortveci), $p2d->vv_qsortvec); ##-------------------------------------------------------------- ## vsearchvec ##-- 6..8: vsearchvec 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"); pdlok("vsearchvec():match", $find->vv_vsearchvec($which), pdl(long,[0,2,4,6])); isok("vsearchvev():<<", all(pdl([-1,-1])->vv_vsearchvec($which)==0)); isok("vsearchvev():>>", all(pdl([2,2])->vv_vsearchvec($which)==$which->dim(1)-1)); print "\n"; # end of t/02_cmpvec.t PDL-VectorValued-1.0.22/t/common.plt0000644000175000017500000000652614414234234016634 0ustar moocowbovines# -*- Mode: CPerl -*- # File: t/common.plt # Description: re-usable test subs; requires Test::More BEGIN { $| = 1; } # isok($label,@_) -- prints helpful label sub isok { local $Test::Builder::Level = $Test::Builder::Level + 1; my $label = shift; if (@_==1) { ok($_[0],$label); } elsif (@_==2) { is($_[0],$_[1], $label); } else { die("isok(): expected 1 or 2 non-label arguments, but got ", scalar(@_)); } } # skipok($label,$skip_if_true,@_) -- prints helpful label # skipok($label,$skip_if_true,\&CODE) -- prints helpful label sub skipok { local $Test::Builder::Level = $Test::Builder::Level + 1; my ($label,$skip_if_true) = splice(@_,0,2); if ($skip_if_true) { subtest $label => sub { plan skip_all => $skip_if_true; }; } else { if (@_==1 && ref($_[0]) && ref($_[0]) eq 'CODE') { isok($label, $_[0]->()); } else { isok($label,@_); } } } # skipordo($label,$skip_if_true,sub { ok ... },@args_for_sub) sub skipordo { local $Test::Builder::Level = $Test::Builder::Level + 1; my ($label,$skip_if_true) = splice(@_,0,2); if ($skip_if_true) { subtest $label => sub { plan skip_all => $skip_if_true; }; } else { $_[0]->(@_[1..$#_]); } } # ulistok($label,\@got,\@expect) # --> ok() for unsorted lists sub ulistok { local $Test::Builder::Level = $Test::Builder::Level + 1; my ($label,$l1,$l2) = @_; is_deeply([sort @$l1],[sort @$l2],$label); } # matchpdl($a,$b) : returns pdl identity check, including BAD sub matchpdl { my ($a,$b) = map {PDL->topdl($_)->setnantobad} @_[0,1]; return ($a==$b)->setbadtoval(0) | ($a->isbad & $b->isbad) | ($a->isfinite->not & $b->isfinite->not); } # matchpdl($a,$b,$eps) : returns pdl approximation check, including BAD sub matchpdla { my ($a,$b) = map {$_->setnantobad} @_[0,1]; my $eps = $_[2]; $eps = 1e-5 if (!defined($eps)); return $a->approx($b,$eps)->setbadtoval(0) | ($a->isbad & $b->isbad) | ($a->isfinite->not & $b->isfinite->not); } # cmp_dims($got_pdl,$expect_pdl) sub cmp_dims { my ($p1,$p2) = @_; return $p1->ndims==$p2->ndims && all(pdl(PDL::long(),[$p1->dims])==pdl(PDL::long(),[$p2->dims])); } # pdlok($label, $got, $want) sub pdlok { local $Test::Builder::Level = $Test::Builder::Level + 1; my ($label,$got,$want) = @_; $got = PDL->topdl($got) if (defined($got)); $want = PDL->topdl($want) if (defined($want)); isok($label, defined($got) && defined($want) && cmp_dims($got,$want) && all(matchpdl($want,$got))) or diag "got=$got\nwant=$want"; } # pdlok_nodims($label, $got, $want) # + ignores dimensions sub pdlok_nodims { local $Test::Builder::Level = $Test::Builder::Level + 1; my ($label,$got,$want) = @_; $got = PDL->topdl($got) if (defined($got)); $want = PDL->topdl($want) if (defined($want)); isok($label, defined($got) && defined($want) #&& cmp_dims($got,$want) && all(matchpdl($want,$got))); } # pdlapprox($label, $got, $want, $eps=1e-5) sub pdlapprox { local $Test::Builder::Level = $Test::Builder::Level + 1; my ($label,$got,$want,$eps) = @_; $got = PDL->topdl($got) if (defined($got)); $want = PDL->topdl($want) if (defined($want)); $eps = 1e-5 if (!defined($eps)); isok($label, defined($got) && defined($want) && cmp_dims($got,$want) && all(matchpdla($want,$got,$eps))) or diag "got=$got\nwant=$want"; } print "loaded ", __FILE__, "\n"; 1; PDL-VectorValued-1.0.22/t/03_setops.t0000644000175000017500000003227314244750071016630 0ustar moocowbovines# -*- Mode: CPerl -*- # t/03_setops.t: test PDL::VectorValued set operations use Test::More; ##-- common subs my $TEST_DIR; BEGIN { use File::Basename; use Cwd; $TEST_DIR = Cwd::abs_path dirname( __FILE__ ); eval qq{use lib ("$TEST_DIR/$_/blib/lib","$TEST_DIR/$_/blib/arch");} foreach (qw(..)); do "$TEST_DIR/common.plt" or die("$0: failed to load $TEST_DIR/common.plt: $@"); } ##-- common modules use PDL; use PDL::VectorValued; ##-------------------------------------------------------------- ## vv: data 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])); ## 1..3: vv_union my ($c,$nc) = $v1->vv_union($v2); pdlok("vv_union:list:c", $c, pdl($vtype, [ [0,0],[0,1],[1,0],[1,1],[0,0],[0,0] ])); isok("vv_union:list:nc", $nc, $universe->dim(1)); my $cc = $v1->vv_union($v2); pdlok("vv_union:scalar", $cc, $universe); ## 4..6: vv_intersect ($c,$nc) = $v1->vv_intersect($v2); pdlok("vv_intersect:list:c", $c, pdl($vtype, [ [0,1],[1,0],[0,0] ])); isok("vv_intersect:list:nc", $nc->sclr, 2); $cc = $v1->vv_intersect($v2); pdlok("vv_intersect:scalar", $cc, $universe->slice(",1:2")); ## 7..9: vv_setdiff ($c,$nc) = $v1->vv_setdiff($v2); pdlok("vv_setdiff:list:c", $c, pdl($vtype, [ [0,0], [0,0],[0,0] ])); isok("vv_setdiff:list:nc", $nc, 1); $cc = $v1->vv_setdiff($v2); pdlok("vv_setdiff:scalar", $cc, pdl($vtype, [[0,0]])); ##-------------------------------------------------------------- ## v: data my $all = sequence(20); my $amask = ($all % 2)==0; my $bmask = ($all % 3)==0; my $a = $all->where($amask); my $b = $all->where($bmask); ## 10: v_union pdlok("v_union", scalar($a->v_union($b)), $all->where($amask | $bmask)); ## 11: v_intersect pdlok("v_intersect", scalar($a->v_intersect($b)), $all->where($amask & $bmask)); ## 12: v_setdiff pdlok("v_setdiff", scalar($a->v_setdiff($b)), $all->where($amask & $bmask->not)); ##-------------------------------------------------------------- ## vv_*: dim-checks and implicit thread dimensions ## + see https://github.com/moocow-the-bovine/PDL-VectorValued/issues/4 sub test_vv_thread_dimensions { ##-- vv_union 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]]); # vv_union: basic pdlok("vv_union - thread dims - uw+wx", scalar($uw->vv_union($wx)), pdl([[-3,-2,-1],[1,2,3],[4,5,6]])); pdlok("vv_union - thread dims - uw+xy", scalar($uw->vv_union($xy)), pdl([[-3,-2,-1],[1,2,3],[4,5,6],[7,8,9]])); pdlok("vv_union - thread dims - 0+wx", scalar($empty->vv_union($wx)), $wx); pdlok("vv_union - thread dims - wx+0", scalar($wx->vv_union($empty)), $wx); pdlok("vv_union - thread dims - 0+0", scalar($empty->vv_union($empty)), $empty); # vv_union: threading/broadcasting my $k = 2; my $kempty = $empty->slice(",,*$k"); my $kuw = $uw->slice(",,*$k"); my $kwx = $wx->slice(",,*$k"); my $kxy = $xy->slice(",,*$k"); pdlok("vv_union - thread dims - uw(*k)+wx", scalar($kuw->vv_union($wx)), pdl([[-3,-2,-1],[1,2,3],[4,5,6]])->slice(",,*$k")); pdlok("vv_union - thread dims - uw(*k)+xy", scalar($kuw->vv_union($xy)), pdl([[-3,-2,-1],[1,2,3],[4,5,6],[7,8,9]])->slice(",,*$k")); pdlok("vv_union - thread dims - 0(*k)+wx", scalar($kempty->vv_union($wx)), $kwx); pdlok("vv_union - thread dims - wx(*k)+0", scalar($kwx->vv_union($empty)), $kwx); pdlok("vv_union - thread dims - 0(*k)+0", scalar($kempty->vv_union($empty)), $kempty); ##-- vv_intersect 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]]); # vv_intersect: basic pdlok("vv_intersect - thread dims - needle0&haystack", scalar($needle0->vv_intersect($haystack)), $empty); pdlok("vv_intersect - thread dims - needle1&haystack", scalar($needle1->vv_intersect($haystack)), $needle1); pdlok("vv_intersect - thread dims - needles&haystack", scalar($needles->vv_intersect($haystack)), $needle1); pdlok("vv_intersect - thread dims - haystack&haystack", scalar($haystack->vv_intersect($haystack)), $haystack); pdlok("vv_intersect - thread dims - haystack&empty", scalar($haystack->vv_intersect($empty)), $empty); pdlok("vv_intersect - thread dims - empty&haystack", scalar($empty->vv_intersect($haystack)), $empty); # vv_intersect: threading/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"); pdlok("vv_intersect - thread dims - needle0(*k)&haystack", scalar($kneedle0->vv_intersect($haystack)), $kempty); pdlok("vv_intersect - thread dims - needle1(*k)&haystack", scalar($kneedle1->vv_intersect($haystack)), $kneedle1); pdlok("vv_intersect - thread dims - needles(*k)&haystack", scalar($kneedles->vv_intersect($haystack)), pdl([[[0,0,0]],[[1,2,3]]])); pdlok("vv_intersect - thread dims - haystack(*k)&haystack", scalar($khaystack->vv_intersect($haystack)), $khaystack); pdlok("vv_intersect - thread dims - haystack(*k)&empty", scalar($khaystack->vv_intersect($empty)), $kempty); pdlok("vv_intersect - thread dims - empty(*k)&haystack", scalar($kempty->vv_intersect($haystack)), $kempty); ##-- vv_setdiff # vv_setdiff: basic pdlok("vv_setdiff - thread dims - haystack-needle0", scalar($haystack->vv_setdiff($needle0)), $haystack); pdlok("vv_setdiff - thread dims - haystack-needle1", scalar($haystack->vv_setdiff($needle1)), $haystack->slice(",1:-1")); pdlok("vv_setdiff - thread dims - haystack-needles", scalar($haystack->vv_setdiff($needles)), $haystack->slice(",1:-1")); pdlok("vv_setdiff - thread dims - haystack-haystack", scalar($haystack->vv_setdiff($haystack)), $empty); pdlok("vv_setdiff - thread dims - haystack-empty", scalar($haystack->vv_setdiff($empty)), $haystack); pdlok("vv_setdiff - thread dims - empty-haystack", scalar($empty->vv_setdiff($haystack)), $empty); # vv_setdiff: threading/broadcasting pdlok("vv_setdiff - thread dims - haystack(*k)-needle0", scalar($khaystack->vv_setdiff($needle0)), $khaystack); pdlok("vv_setdiff - thread dims - haystack(*k)-needle1", scalar($khaystack->vv_setdiff($needle1)), $khaystack->slice(",1:-1,")); pdlok("vv_setdiff - thread dims - haystack(*k)-needles", scalar($khaystack->vv_setdiff($needles)), $khaystack->slice(",1:-1,")); pdlok("vv_setdiff - thread dims - haystack(*k)-haystack", scalar($khaystack->vv_setdiff($haystack)), $kempty); pdlok("vv_setdiff - thread dims - haystack(*k)-empty", scalar($khaystack->vv_setdiff($empty)), $khaystack); pdlok("vv_setdiff - thread dims - empty(*k)-haystack", scalar($kempty->vv_setdiff($haystack)), $kempty); } test_vv_thread_dimensions(); ##-------------------------------------------------------------- ## vv_intersect tests as suggested by ETJ/mowhawk2 ## + see https://github.com/moocow-the-bovine/PDL-VectorValued/issues/4 sub test_vv_intersect_implicit_dims { # vv_intersection: 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); pdlok('vv_intersect - implicit dims - titi&toto', $c=vv_intersect($titi,$toto), [[1,2,3]]); pdlok('vv_intersect - implicit dims - notin&toto', $c=vv_intersect($notin,$toto), zeroes(3,0)); pdlok('vv_intersect - implicit dims - titi(*1)&toto', $c=vv_intersect($titi->dummy(1), $toto), [[1,2,3]]); pdlok('vv_intersect - implicit dims - notin(*1)&toto', $c=vv_intersect($notin->dummy(1), $toto), zeroes(3,0)); 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) = vv_intersect($a,$b); my $c_sclr = vv_intersect($a,$b); pdlok("$label - result", $c, $c_want) if (defined($c_want)); pdlok("$label - counts", $nc, $nc_want) if (defined($nc_want)); pdlok("$label - scalar", $c_sclr, $c_sclr_want) if (defined($c_sclr_want)); } intersect_ok('vv_intersect - implicit dims - needle0_in&haystack', $needle0_in, $haystack, [[1,2,3]], 1, [[1,2,3]] ); intersect_ok('vv_intersect - implicit dims - needle_in&haystack', $needle_in, $haystack, [[1,2,3]], 1, [[1,2,3]] ); intersect_ok('vv_intersect - implicit dims - needle0_notin&haystack', $needle0_notin, $haystack, [[0,0,0]], 0, zeroes(3,0) ); intersect_ok('vv_intersect - implicit dims - needle_notin&haystack', $needle_notin, $haystack, [[0,0,0]], 0, zeroes(3,0) ); intersect_ok('vv_intersect - 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('vv_intersect - implicit dims - needles8x&haystack8', $needles8x, $haystack8, $c_want8, $nc_want8, $c_want8 ); } test_vv_intersect_implicit_dims(); ##-------------------------------------------------------------- ## v_*: dim-checks and implicit thread dimensions ## + analogous to https://github.com/moocow-the-bovine/PDL-VectorValued/issues/4 sub test_v_thread_dimensions { # 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: threading/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"); #-- v_union pdlok("v_union - thread dims - 12+34", scalar($v1_2->v_union($v3_4)), $v1_4); pdlok("v_union - thread dims - 34+1234", scalar($v3_4->v_union($v1_4)), $v1_4); pdlok("v_union - thread dims - 0+1234", scalar($empty->v_union($v1_4)), $v1_4); pdlok("v_union - thread dims - 1234+0", scalar($v1_4->v_union($empty)), $v1_4); pdlok("v_union - thread dims - 0+0", scalar($empty->v_union($empty)), $empty); # pdlok("v_union - thread dims - 12(*k)+34", scalar($kv1_2->v_union($v3_4)), $kv1_4); pdlok("v_union - thread dims - 34(*k)+1234", scalar($kv3_4->v_union($v1_4)), $kv1_4); pdlok("v_union - thread dims - 0(*k)+1234", scalar($kempty->v_union($v1_4)), $kv1_4); pdlok("v_union - thread dims - 1234(*k)+0", scalar($kv1_4->v_union($empty)), $kv1_4); pdlok("v_union - thread dims - 0(*k)+0", scalar($kempty->v_union($empty)), $kempty); #-- v_intersect pdlok("v_intersect - thread dims - 12&34", scalar($v1_2->v_intersect($v3_4)), $empty); pdlok("v_intersect - thread dims - 34&1234", scalar($v3_4->v_intersect($v1_4)), $v3_4); pdlok("v_intersect - thread dims - 0&1234", scalar($empty->v_intersect($v1_4)), $empty); pdlok("v_intersect - thread dims - 1234&0", scalar($v1_4->v_intersect($empty)), $empty); pdlok("v_intersect - thread dims - 0&0", scalar($empty->v_intersect($empty)), $empty); # pdlok("v_intersect - thread dims - 12(*k)&34", scalar($kv1_2->v_intersect($v3_4)), $kempty); pdlok("v_intersect - thread dims - 34(*k)&1234", scalar($kv3_4->v_intersect($v1_4)), $kv3_4); pdlok("v_intersect - thread dims - 0(*k)&1234", scalar($kempty->v_intersect($v1_4)), $kempty); pdlok("v_intersect - thread dims - 1234(*k)&0", scalar($kv1_4->v_intersect($empty)), $kempty); pdlok("v_intersect - thread dims - 0(*k)&0", scalar($kempty->v_intersect($empty)), $kempty); #-- v_setdiff pdlok("v_setdiff - thread dims - 12-34", scalar($v1_2->v_setdiff($v3_4)), $v1_2); pdlok("v_setdiff - thread dims - 34-1234", scalar($v3_4->v_setdiff($v1_4)), $empty); pdlok("v_setdiff - thread dims - 1234-0", scalar($v1_4->v_setdiff($empty)), $v1_4); pdlok("v_setdiff - thread dims - 0-1234", scalar($empty->v_setdiff($v1_4)), $empty); pdlok("v_setdiff - thread dims - 0-0", scalar($empty->v_setdiff($empty)), $empty); # pdlok("v_setdiff - thread dims - 12(*k)-34", scalar($kv1_2->v_setdiff($v3_4)), $kv1_2); pdlok("v_setdiff - thread dims - 34(*k)-1234", scalar($kv3_4->v_setdiff($v1_4)), $kempty); pdlok("v_setdiff - thread dims - 1234(*k)-0", scalar($kv1_4->v_setdiff($empty)), $kv1_4); pdlok("v_setdiff - thread dims - 0(*k)-1234", scalar($kempty->v_setdiff($v1_4)), $kempty); pdlok("v_setdiff - thread dims - 0(*k)-0", scalar($kempty->v_setdiff($empty)), $kempty); } test_v_thread_dimensions(); print "\n"; done_testing(); # end of t/03_setops.t PDL-VectorValued-1.0.22/t/05_vcos.t0000644000175000017500000000401514244750071016260 0ustar moocowbovines# -*- Mode: CPerl -*- # t/05_vcos.t: test PDL::VectorValued vector-cosine use Test::More tests=>6; ##-- common subs my $TEST_DIR; BEGIN { use File::Basename; use Cwd; $TEST_DIR = Cwd::abs_path dirname( __FILE__ ); eval qq{use lib ("$TEST_DIR/$_/blib/lib","$TEST_DIR/$_/blib/arch");} foreach (qw(..)); do "$TEST_DIR/common.plt" or die("$0: failed to load $TEST_DIR/common.plt: $@"); } ##-- common modules use PDL; use PDL::VectorValued; #use PDL::VectorValued::Dev; ##-- common vars use version; my $HAVE_PDL_2_014 = version->parse($PDL::VERSION) >= version->parse("2.014"); ##-------------------------------------------------------------- ## tests my $a = pdl([[1,2,3,4],[1,2,2,1],[-1,-2,-3,-4]]); my $b = pdl([1,2,3,4]); my $c_want = pdl([1,0.8660254,-1]); ##-- 1..2: vcos: basic pdlapprox("vv_vcos:flat", $a->vv_vcos($b), $c_want, 1e-4); pdlapprox("vv_vcos:threaded", $a->vv_vcos($b->slice(",*3")), $c_want->slice(",*3"), 1e-4); ##-- 3: vcos: nullvec: a my $a0 = $a->pdl; my $nan = $^O =~ /MSWin32/i ? ((99**99)**99) - ((99**99)**99) : 'nan'; (my $tmp=$a0->slice(",1")) .= 0; pdlapprox("vv_vcos:nullvec:a:nan", $a0->vv_vcos($b), pdl([1,$nan,-1]), 1e-4); ##-- 4: vcos: nullvec: b my $b0 = $b->zeroes; isok("vv_vcos:nullvec:b:all-nan", all($a->vv_vcos($b0)->isfinite->not)); ##-- 5-6: bad values my @chkbad = ( ##-- 5: a~bad ["vv_vcos:bad:a" => sub { my $abad = $a->pdl->setbadif($a->abs==2); my $abad_cwant = pdl([0.93094,0.64549,-0.93094]); pdlapprox("vv_vcos:bad:a", $abad->vv_vcos($b), $abad_cwant, 1e-4); }], ##-- 6: b~bad ["vv_vcos:bad:b" => sub { my $bbad = $b->pdl->setbadif($b->xvals==2); my $bbad_cwant = pdl([0.8366,0.6211,-0.8366]); pdlapprox("vv_vcos:bad:b", $a->vv_vcos($bbad), $bbad_cwant, 1e-4); }], ); my $skipbad = (!$PDL::Bad::Status ? "no bad-value support in PDL" : (!$HAVE_PDL_2_014 ? "PDL >= v2.014 only" : 0)); foreach my $badtest (@chkbad) { skipordo($badtest->[0], $skipbad, $badtest->[1]); } print "\n"; # end of t/05_vcos.t PDL-VectorValued-1.0.22/VectorValued.pm0000644000175000017500000002427114414235125017316 0ustar moocowbovines## $Id$ ## ## File: PDL::VectorValued.pm ## Author: Bryan Jurish ## Description: Vector utilities for PDL: perl side only ##====================================================================== package PDL::VectorValued; use strict; use warnings; ##====================================================================== ## Export hacks use PDL; use PDL::Exporter; use PDL::VectorValued::Utils; our @ISA = qw(PDL::Exporter); our (@EXPORT_OK); BEGIN { ##-------------------------------------------------------------------- ## Conditional bindings for PDL > v2.079 ## + see https://github.com/moocow-the-bovine/PDL-VectorValued/issues/5 ## @VV_SYMBOLS : exportable symbols (vv_FOO) my @VV_SYMBOLS = ( (@PDL::VectorValued::Utils::EXPORT_OK), ##-- inherited qw(vv_uniqvec), qw(vv_rleND vv_rldND), qw(vv_indx), ); # %VV_IMPORT: import these from PDL core if available (PDL > v2.079) my %VV_IMPORT = ( vv_rlevec => {vv=>'rlevec', p=>PDL->can('rlevec')}, vv_rldvec => {vv=>'rldvec', p=>PDL->can('rldvec')}, vv_rleseq => {vv=>'rleseq', p=>PDL->can('rleseq')}, vv_rldseq => {vv=>'rldseq', p=>PDL->can('rldseq')}, vv_enumvec => {vv=>'enumvec', p=>PDL->can('enumvec')}, vv_enumvecg => {vv=>'enumvecg', p=>PDL->can('enumvecg')}, vv_vsearchvec => {vv=>'vsearchvec', p=>PDL->can('vsearchvec')}, vv_cmpvec => {vv=>'cmpvec', p=>PDL->can('cmpvec')}, vv_union => {vv=>'vv_union', p=>PDL->can('unionvec')}, vv_intersect => {vv=>'vv_intersect', p=>PDL->can('intersectvec')}, vv_setdiff => {vv=>'vv_setdiff', p=>PDL->can('setdiffvec')}, v_union => {vv=>'v_union', p=>PDL->can('union_sorted')}, v_intersect => {vv=>'v_intersect', p=>PDL->can('intersect_sorted')}, v_setdiff => {vv=>'v_setdiff', p=>PDL->can('setdiff_sorted')}, vv_rleND => {vv=>'rleND', p=>PDL->can('rleND')}, vv_rldND => {vv=>'rldND', p=>PDL->can('rldND')}, #vv_indx => {vv=>'vv_indx', p=>PDL->can('indx')}, # DEBUG ); @EXPORT_OK = @VV_SYMBOLS; foreach my $vv_sym (@VV_SYMBOLS) { no strict 'refs'; if ($VV_IMPORT{$vv_sym} && defined($VV_IMPORT{$vv_sym}{p})) { # function lives in PDL core: import it here, and clobber $vv_sym here (but not in VV::Utils) no warnings 'redefine'; *$vv_sym = *{$VV_IMPORT{$vv_sym}{vv}} = $VV_IMPORT{$vv_sym}{p}; } elsif ($VV_IMPORT{$vv_sym}) { # $sym is defined here as "vv_$sym" : bind it here & in PDL namespace my $sym = $VV_IMPORT{$vv_sym}{vv}; ${PDL::}{$sym} = *$sym = *$vv_sym; # ... and make it exportable push(@EXPORT_OK, $sym); } } } our %EXPORT_TAGS = ( Func => [@EXPORT_OK], ##-- respect PDL conventions (hopefully) ); ## VERSION was formerly set by PDL::VectorValued::Version, now use perl-reversion from Perl::Version instead our $VERSION = '1.0.22'; ##====================================================================== ## pod: header =pod =head1 NAME PDL::VectorValued - Utilities for vector-valued PDLs =head1 SYNOPSIS use PDL; use PDL::VectorValued; ##--------------------------------------------------------------------- ## ... stuff happens =cut ##====================================================================== ## Description =pod =head1 DESCRIPTION PDL::VectorValued provides generalizations of some elementary PDL functions to higher-order PDLs which treat vectors as "data values". =cut ##====================================================================== ## pod: Aliases =pod =head1 ALIASES To facilitate incorporation of selected vector-valued functions into the PDL core, the PDL:PP-, XS-, C-, and perl-level functions defined by this module in the C package namespace all carry a C prefix as of PDL::VectorValued v1.0.19 Prior to v1.0.19, many of these functions (e.g. C) were defined by this module without a C prefix. For PDL::VectorValued E= v1.0.19 and PDL E v2.079, most vector-valued functions are expected to be defined in the PDL core. For such "moving" functions C, the PDL core implementations will be imported into the C namespace as both C and C, clobbering any local implementation from the C namespace. Local implementations C which were previously defined and exported as C or for which no binding for C<*PDL::FUNC> exists will be bound to both C<*PDL::VectorValued::FUNC> and C<*PDL::FUNC>, and exported by default, for backwards-compatibility. Functions expected to move to the PDL core are: =over 4 =item * New code should use C or C. =item * Backwards-compatible code can use C or C. =item * Direct use of C is deprecated. =item * Direct use of C is likely broken as of PDL::VectorValued v1.0.19. =back =cut ##====================================================================== ## pod: Functions =pod =head1 FUNCTIONS =cut ##---------------------------------------------------------------------- ## vv_uniqvec =pod =head2 vv_uniqvec =for sig Signature: (v(N,M); [o]vu(N,MU)) =for ref Drop-in replacement for broken uniqvec() which uses vv_qsortvec(). Otherwise copied from PDL::Primitive::primitive.pd. See also: PDL::VectorValued::Utils::vv_qsortvec, PDL::Primitive::uniqvec. =cut *PDL::vv_uniqvec = \&vv_uniqvec; sub vv_uniqvec { my($pdl) = shift; # slice is not cheap but uniqvec isn't either -- shouldn't cost too much. return $pdl if($pdl->nelem == 0 || $pdl->ndims <2 || $pdl->slice("(0)")->nelem < 2); my $srt = $pdl->mv(0,-1)-> clump($pdl->ndims - 1)-> mv(-1,0)->vv_qsortvec-> ##-- moo: Tue, 24 Apr 2007 17:17:39 +0200: use vv_qsortvec mv(0,-1); $srt=$srt->dice($srt->mv(0,-1)->ngoodover->which) if ($PDL::Bad::Status && $srt->badflag); ##use dice instead of nslice since qsortvec might be packing the badvals to the front of #the array instead of the end like the docs say. If that is the case and it gets fixed, #it won't bust uniqvec. DAL 14-March 2006 my $uniq = ($srt != $srt->rotate(-1)) -> mv(0,-1) -> orover->which; return $uniq->nelem==0 ? $srt->slice("0,:")->mv(0,-1) : $srt->dice($uniq)->mv(0,-1); } ##====================================================================== ## Run-Length Encoding/Decoding: n-dimensionl =pod =head1 Higher-Order Run-Length Encoding and Decoding The following functions generalize the builtin PDL functions rle() and rld() for higher-order "values". See also: PDL::VectorValued::Utils::vv_rlevec(), PDL::VectorValued::Utils::vv_rldvec(). =cut ##---------------------------------------------------------------------- ## rleND() =pod =head2 vv_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 ocurring 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: PDL::Slices::rle, PDL::Ngrams::VectorValued::Utils::vv_rlevec. =cut *PDL::vv_rleND = \&vv_rleND if !defined &PDL::vv_rleND; *rleND = sub { 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() vv_rlevec($data->clump($#vdimsN), $counts, $elts->clump($#vdimsN)); return ($counts,$elts); } if !defined &rleND; ##---------------------------------------------------------------------- ## rldND() =pod =head2 vv_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: PDL::Slices::rld, PDL::VectorValued::Utils::rldvec =cut *PDL::vv_rldND = \&vv_rldND if !defined &PDL::vv_rldND; *rldND = sub { 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() vv_rldvec($counts, $elts->clump($#vdimsN), $data->clump($#vdimsN)); return $data; } if !defined &rldND; ##====================================================================== ## pod: Functions: datatype utilities =pod =head1 Datatype Utilities =cut ##---------------------------------------------------------------------- ## vv_indx() =pod =head2 vv_indx =for sig Signature: vv_indx() =for ref Returns PDL::Type subclass used for indices. If built with PDL E v2.007, this should return C, otherwise C. =cut sub vv_indx { return defined(&PDL::indx) ? PDL::indx(@_) : PDL::long(@_); } ##====================================================================== ## pod: Functions: low-level =pod =head2 Low-Level Functions Some additional low-level functions are provided in the PDL::VectorValued::Utils package. See L for details. =cut 1; ##-- make perl happy ##====================================================================== ## pod: Footer =pod =head1 ACKNOWLEDGEMENTS perl by Larry Wall. =head1 AUTHOR Bryan Jurish Emoocow@cpan.orgE PDL by Karl Glazebrook, Tuomas J. Lukka, Christian Soeller, and others. =head1 COPYRIGHT Copyright (c) 2007-2022, Bryan Jurish. All rights reserved. This package is free software. You may redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO perl(1), PDL(3perl), PDL::VectorValued::Utils(3perl) =cut PDL-VectorValued-1.0.22/ChangeLog0000644000175000017500000001412114244750354016127 0ustar moocowbovines##-*- Mode: Change-Log; coding: utf-8; -*- ## ## Change log for perl distribution PDL::VectorValued v1.0.21 Sun, 29 May 2022 21:58:45 +0200 moocow * suppress "redefined" warnings under PDL v2.080 which break Debian (contributed by mohawk2) * fix bogus POD references to non-existant PDL::Ngrams::ngutils v1.0.20 Fri, 20 May 2022 17:03:57 +0200 moocow * add rleND, rldND to %VV_IMPORT v1.0.19 Wed, 18 May 2022 14:41:44 +0200 moocow * add vv_ prefix to all VectorValued::Utils functions * add conditional aliases in VectorValued.pm BEGIN block for github issue #5 - import %VV_IMPORT symbols from PDL core if available - export vv_FOO as PDL::FOO otherwise (compatibility) v1.0.18 Wed, 16 Mar 2022 20:23:23 +0100 moocow * removed redundant mv(1,0)->...->mv(0,1) from setops trimming expressions v1.0.17 Sun, 13 Mar 2022 17:43:18 +0100 moocow * overhaul set operations implicit threading, part 2 - use RedoDimsCode for setting default dimensions (adapted from PDL::Primitive::append) - drop klunky (& sometimes wrong) dimension-wrangling stuff in setops PMCode - add PP code to explicitly zero out unpopulated portions of set-op result piddles ($c) + might be worth allowing user to specify "missing" value here (a la PDL::CCS) * added more tests from https://github.com/moocow-the-bovine/PDL-VectorValued/issues/4 v1.0.16 Sat, 12 Mar 2022 15:48:13 +0100 moocow * overhaul set operations implicit threading/broadcasting dimensions and empty results - should hopefully fix https://github.com/moocow-the-bovine/PDL-VectorValued/issues/4 v1.0.15 Sun, 20 Feb 2022 13:40:45 +0100 moocow * fix for PDL v2.075 - PDL::null() is no longer a valid input PDL, even for conversions v1.0.14 Fri, 12 Nov 2021 20:05:32 +0100 moocow * explicitly use PDL::Types from VectorValued/Dev; fixes https://github.com/moocow-the-bovine/PDL-VectorValued/issues/1 v1.0.13 Mon, 20 Sep 2021 17:30:18 +0200 moocow * cleaned up stale acknowledgements in docs v1.0.12 Sun, 19 Sep 2021 21:24:50 +0200 moocow * removed stale vv_qsortvec and vv_qsortveci cruft - original motivation (bug in PDL-2.4.3) is long since fixed - vv_* methods are now just deprecated glob-aliases for the corresponding builtin PDL core functions v1.0.11 Thu, 16 Sep 2021 20:42:46 +0200 moocow * replaced crufty $COMP(__X_size) with $SIZE(X) in Utils/utils.pd - at suggestion of Ed J, for upcoming PDL release * added github repo to CPAN metadata v1.0.10 Wed, 07 Apr 2021 09:52:45 +0200 moocow * applied Zaki Mughal's patch for PDL native complex types in PDL > 2.028 - https://github.com/zmughal/PDL-VectorValued/compare/skip-complex-types - fixes RT bug #134962 v1.0.9 Fri, 18 May 2018 09:44:25 +0200 moocow * added README.rpod to MANIFEST * only include README.txt in "realclean" targets if README.rpod is present v1.0.8 Tue, 15 May 2018 08:55:00 +0200 moocow * fixed some typos in POD documentation (RT ticket #125314) v1.0.7 Tue, 06 Jun 2017 10:21:58 +0200 moocow * added 'use lib "."' to Makefile.PL (RT bug #121661) v1.0.6 Mon, 06 Jun 2016 11:29:23 +0200 moocow * win32/NaN fixes for tests (RT bug #115076) v1.0.5 Thu, 17 Dec 2015 10:02:25 +0100 moocow * fixed wrongly succeeding bogus tests with unary ok() - tests now use Test::More and re-factored common test subroutines * pdlmaker.plm doesn't distribute generated PM files any more (PDL now does this for us) * added vector-cosine similarity vv_vcos() v1.0.4 Mon, 23 Nov 2015 12:10:32 +0100 moocow * shared $VERSION now via perl-reversion script from Perl::Version (debian libperl-version-perl) as suggested by Corion in thread http://www.perlmonks.org/?node_id=1148116 * may or may not help with weird errors building PDL::Ngrams with stale PDL::VectorValued, - new version of PDL::VectorValued will probably mask that bug anyways v1.0.3 Tue, 04 Aug 2015 12:19:25 +0200 moocow * enumvec() regression fix v1.0.2 Wed, 29 Jul 2015 10:05:34 +0200 moocow * enumvecg() fix v1.0.1 Tue, 28 Jul 2015 16:51:18 +0200 moocow * added enumvecg(): global vector id-enumerator v1.0.0 Mon, 27 Jul 2015 10:06:35 +0200 moocow * explicit 3-component versioning for more transparent version.pm compatiblity * added rleseq(), rldseq() for run-length encoding subsequence vectors v0.09002 Thu, 09 Apr 2015 10:31:50 +0200 moocow * tweaked bootstrap logic snafu with PDL::VectorValued::Dev including PDL::VectorValued::Version even though ::Dev is needed at module build time when ::Version is not yet present - this seemed to be causing a lot of UNKNOWN results on cpantesters v0.09001 Wed, 08 Apr 2015 10:58:04 +0200 moocow * added $CMPVAL() and $LB() macros * added v_{union,intersect,setdiff} set operations for flat, sorted, unique-valued PDLs - new implementation is much faster than builtin PDL::Primitive::intersect() [via PDL::Primitive::setops()] - for large-ish intersection (NA=2973, NB=221013) v_intersect($a,qsort($b)) is 2x faster than setops($a,'AND',$b), and v_intersect($a,$b) with all data pre-sorted $b is 42x faster than setops($a,'AND',$b) v0.08001 2014-11-05 moocow * fix annoying PAUSE messages about incompatible version numbers * improved handling of empty pdls v0.07002 Wed, 25 Sep 2013 10:16:54 +0200 moocow * PREREQ_PM{PDL}=CONFIGURE_REQUIRES{PDL}=0, for CPAN-testers friendliness * added support for PDL v2.007 PDL_Indx type (64-bit indices) * changed version convention X.BBCCC to jive with both pp_setversion() and version->parse() v0.06 2012-11-06 moocow * added enumvec(): enumerate repetitions in a sorted vector list v0.05 2012-01-02 moocow * pdlmaker.plm version: for CPAN-friendly docs v0.0401 2011-12-20 moocow * added 'generic' pdlmaker.plm : cpan-friendly pdl module hacks * still not playing too nicely with embedded pd->pm conversions (e.g. Utils/utils.pd -> Utils/utils.pm) v0.04 Wed, 30 Mar 2011 15:12:32 +0200 (moocow) + renamed qsortveci() to vv_qsortveci to avoid conflicts with pdl-2.4.7 (debian squeeze) v0.03 Mon, 16 Apr 2007 09:58:49 +0200 + added @PDL::VectorValued::Dev::MACROS v0.02 Tue, 10 Apr 2007 14:45:00 +0200 (moocow) + added setops: vv_union, vv_intersect, vv_setdiff v0.01 Fri, 06 Apr 2007 11:41:00 +0200 (moocow) + initial version PDL-VectorValued-1.0.22/Makefile.PL0000644000175000017500000000173514241237370016331 0ustar moocowbovinesuse ExtUtils::MakeMaker; #@MY::pdpm = qw(Utils/Utils.pm); require "./pdlmaker.plm"; pdlmaker_init(); WriteMakefile( NAME => 'PDL::VectorValued', VERSION_FROM => 'VectorValued.pm', ABSTRACT => 'Assorted utilities for vector-valued PDLs', AUTHOR => 'Bryan Jurish', LICENSE => 'perl', PREREQ_PM => { PDL => 2.019, # really want 2.075 for $SIZE(N) access in RedoDimsCode for utils.pd 'Test::More' => 0, }, CONFIGURE_REQUIRES => { PDL => 0, }, realclean => { FILES => join(' ', qw(*~ *.tmp),(-e 'README.rpod' ? 'README.txt' : qw())), }, META_MERGE => { "meta-spec" => { version => 2 }, resources => { repository => { url => 'https://github.com/moocow-the-bovine/PDL-VectorValued.git', type => 'git', web => 'https://github.com/moocow-the-bovine/PDL-VectorValued', }, }, }, ); PDL-VectorValued-1.0.22/MANIFEST0000644000175000017500000000075614414235232015507 0ustar moocowbovinesChangeLog MANIFEST MANIFEST.SKIP README.rpod README.txt Makefile.PL pdlmaker.plm VectorValued.pm VectorValued/Dev.pm VectorValued/Version.pm VectorValued/Makefile.PL Utils/Makefile.PL Utils/utils.pd # Utils/Utils.pm Utils/Utils.pm t/common.plt t/00_basic.t t/01_rlevec.t t/02_cmpvec.t t/03_setops.t t/04_types.t t/05_vcos.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) PDL-VectorValued-1.0.22/META.yml0000644000175000017500000000117414414235232015622 0ustar moocowbovines--- abstract: 'Assorted utilities for vector-valued PDLs' author: - 'Bryan Jurish' build_requires: ExtUtils::MakeMaker: '0' configure_requires: PDL: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.44, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: PDL-VectorValued no_index: directory: - t - inc requires: PDL: '2.019' Test::More: '0' resources: repository: https://github.com/moocow-the-bovine/PDL-VectorValued.git version: v1.0.22 x_serialization_backend: 'CPAN::Meta::YAML version 0.018' PDL-VectorValued-1.0.22/README.rpod0000644000175000017500000000242614241237370016200 0ustar moocowbovines=pod README for PDL::VectorValued =head1 ABSTRACT PDL::VectorValued - Assorted PDL utilities treating vectors as values =head1 REQUIREMENTS =over 4 =item * PDL Tested version(s) 2.4.2, 2.4.3, 2.4.7_001, 2.4.9_015, 2.4.10, 2.019, 2.039 =back =head1 DESCRIPTION PDL::VectorValued provides some generalizations of builtin PDL functions to higher order PDLs which treat vectors in the source PDLs as "data values". =head1 BUILDING Build this module as you would any perl module, by doing something akin to the following: gzip -dc distname-XX.YY.tar.gz | tar -xof - cd distname-XX.YY/ perl Makefile.PL make make test # optional make install See L(1) for details. =head1 ACKNOWLEDGEMENTS =over 4 =item * Perl by Larry Wall =item * PDL by Karl Glazebrook, Tuomas J. Lukka, Christian Soeller, and others. =item * Code for rlevec() and rldvec() derived from the PDL builtin functions rle() and rld() in $PDL_SRC_ROOT/Basic/Slices/slices.pd =back =head1 AUTHOR Bryan Jurish Emoocow@cpan.orgE =head1 COPYRIGHT Copyright (c) 2007-2022, Bryan Jurish. All rights reserved. This package is free software, and entirely without warranty. You may redistribute it and/or modify it under the same terms as Perl itself. =cut PDL-VectorValued-1.0.22/pdlmaker.plm0000644000175000017500000001223014204432223016651 0ustar moocowbovines## -*- Mode: CPerl -*- ## ## File: pdlmaker.plm ## Author: Bryan Jurish ## Description: hacks for CPAN-friendly PDL module distribution ## ## Usage: ## + optionally set the variable $MY::README (boolean); default is ## $MY::README = grep {-e $_} (,,) ## + read this file in top-level Makefile.PL: ## require "pdlmaker.plm"; ## + call pdlmaker_init([$pdfile, $pmbase, $module]) as for pdlpp_stdargs() ## - will actually call pdlpp_stdargs() and return that hash if called in list context ## + call WriteMakefile() as usual ## + omit the pdlpp_postamble() call from MY::postamble() ## (you still need to 'use PDL::Core::Dev' though) ## ## Effects: ## + clobbers sub ExtUtils::MakeMaker::WriteMakefile() ## - unlinks all @pdpm files before calling "real" WriteMakefile() ## + clobbers/appends MY::depend (appends) ## x- adds @pdpm dependencies to dist,distcheck,create_distdir ## - also adds README.txt dependencies if README.txt or README.rpod is present ## + clobbers/appends MY::special_targets (appends) ## - adds (pm|pod|rpod) -> (txt|html) rules ## + clobbers/appends MY::postamble (appends) ## - adds pdlpp_postamble($package) if $package is specified package MY; use ExtUtils::MakeMaker qw(); use ExtUtils::Manifest qw(); use Cwd qw(cwd abs_path); use File::Basename qw(dirname basename); use PDL::Core::Dev; require PDL; # for VERSION use strict; ##---------------------------------------------------------------------- sub pdlmaker_init { my $package = shift; my @pdpm = $package ? "$package->[1].pm" : qw(); my $cwd = cwd(); my $label = "pdlmaker_init [DIR=$cwd]"; #print STDERR "$label\n"; ##---------------------------- ## read manifest @pdpm (for user info message) my @manipm = qw(); if (-r 'MANIFEST') { my $mani = ExtUtils::Manifest::maniread(); my ($pd,$pm); foreach $pd (grep {/\.pd$/i} keys %$mani) { if ($mani->{$pd}) { ($pm=$mani->{$pd}) =~ s/^[\#\s]*(?:pm=)?//; if ($pm) { push(@manipm,$pm); next; } } ($pm=$pd)=~s/\.pd$/\.pm/i; push(@manipm,$pm); } print STDERR "Info: ignore any warnings about missing $_\n" foreach (@manipm); } elsif (0 && $package) { print STDERR "Info: ignore any warnings about missing $package->[1].pm\n"; ; } ##---------------------------- ## $MY::README if (!defined($MY::README)) { $MY::README = grep {-e $_} map {glob("README.$_")} qw(txt pod rpod); } ##---------------------------- ## unlink @pdpm files here foreach (@pdpm) { #print STDERR "$label: UNLINK $_\n"; unlink($_) if (-e $_); } ##---------------------------- ## @missed = ExtUtils::Manifest::manicheck() ## + ignore @pdpm files in manicheck my %manipm = (map {($_=>undef)} @manipm,@pdpm); my $_manicheck0 = \&ExtUtils::Manifest::manicheck; my $_manicheck1 = sub { grep {!exists($manipm{$_})} $_manicheck0->(@_); }; *ExtUtils::Manifest::manicheck = $_manicheck1; ##---------------------------- ## depend() ## + add @pdpm, README.txt my $depend0 = MY->can('depend') || sub {''}; my $depend = sub { my $inherited = $depend0->(@_) . shift->SUPER::depend(@_); my $deps = join(' ', ($MY::README ? 'README.txt' : qw()), #sort keys %manipm ); return $inherited if (!$deps); return $inherited .<(txt|html) my $special_targets0 = MY->can('special_targets') || sub {''}; my $special_targets = sub { my $inherited = $special_targets0->(@_) . shift->SUPER::special_targets(@_); $inherited .= <parse($PDL::VERSION) >= version->parse('2.058')); ##---------------------------- ## postamble() ## + add pdlpp postamble if available my $postamble0 = MY->can('postamble') || sub {''}; my $postamble = sub { my $inherited = $postamble0->(@_) . shift->SUPER::postamble(); if (defined($package) && UNIVERSAL::can('PDL::Core::Dev','pdlpp_postamble')) { $inherited .= PDL::Core::Dev::pdlpp_postamble($package); } $inherited; }; *MY::postamble = $postamble; ##--------------------------- ## returning list context? --> call pdlpp_stdargs() return ::pdlpp_stdargs($package,@_) if ($package && wantarray && UNIVERSAL::can('main','pdlpp_stdargs')); } ##---------------------------------------------------------------------- package main; *pdlmaker_init = \&MY::pdlmaker_init; 1; ##-- be happy