PDL-VectorValued-1.0.9/0000755000175000017500000000000013277502542014302 5ustar moocowbovinesPDL-VectorValued-1.0.9/Utils/0000755000175000017500000000000013277502542015402 5ustar moocowbovinesPDL-VectorValued-1.0.9/Utils/Makefile.PL0000644000175000017500000000076413277501651017363 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'; WriteMakefile(%hash); PDL-VectorValued-1.0.9/Utils/utils.pd0000644000175000017500000007626313277502240017100 0ustar moocowbovines##-*- Mode: CPerl -*- ##====================================================================== ## Header Administrivia ##====================================================================== #require "../VectorValued/Version.pm"; ##-- use perl-reversion from Perl::Version instead my $VERSION = '1.0.9'; 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('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('rldvec', Pars => 'int a(N); b(M,N); [o]c(M,N)', PMCode=><<'EOC', sub PDL::rldvec { my ($a,$b,$c) = @_; if (!defined($c)) { # XXX Need to improve emulation of threading in auto-generating c my ($rowlen) = $b->dim(0); my ($size) = $a->sumover->max; my (@dims) = $a->dims; shift(@dims); $c = $b->zeroes($b->type,$rowlen,$size,@dims); } &PDL::_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('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('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('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('rldseq', Pars => 'int a(N); b(N); [o]c(M)', PMCode=><<'EOC', sub PDL::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::_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 ('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 = ccs_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. Note that vv_qsortvec() is functionally identical to the builtin PDL function qsortvec(), but also that the latter is broken in the stock PDL-2.4.3 distribution. The version included here includes Chris Marshall's "uniqsortvec" patch, which is available here: http://sourceforge.net/tracker/index.php?func=detail&aid=1548824&group_id=612&atid=300612 =cut EOPM ##------------------------------------------------------ ## cmpvec() : make vector comparison available in perl vvpp_def ('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 ); ##====================================================================== ## qsortvec drop-in replacement ## + adopted from patched $PDL_SRC_ROOT/Basic/Ufunc/ufunc.pd ## - nearly a verbatim copy: C names have been changed to protect the innocent ## + includes Chris Marshall's "uniqsortvec" patch, from: ## http://sourceforge.net/tracker/index.php?func=detail&aid=1548824&group_id=612&atid=300612 ##====================================================================== # Internal utility sorting routine for median/qsort/qsortvec routines. # # note: we export them to the PDL Core structure for use in # other modules (eg Image2D) foreach (keys %PDL::Types::typehash) { my $ctype = $PDL::Types::typehash{$_}{ctype}; my $ppsym = $PDL::Types::typehash{$_}{ppsym}; pp_addhdr(<<"FOO" /******* * qsortvec helper routines * --CED 21-Aug-2003 */ /* Compare a vector in lexicographic order, returning the * equivalent of "<=>". */ signed char pdl_vecval_cmpvec_$ppsym($ctype *a, $ctype *b, int n) { int i; for(i=0; i *b ) return 1; } return 0; } void pdl_vecval_qsortvec_$ppsym($ctype *xx, int n, PDL_Indx a, PDL_Indx b) { PDL_Indx i,j, median_ind; $ctype t; i = a; j = b; median_ind = (i+j)/2; do { while( pdl_vecval_cmpvec_$ppsym( &(xx[n*i]), &(xx[n*median_ind]), n ) < 0 ) i++; while( pdl_vecval_cmpvec_$ppsym( &(xx[n*j]), &(xx[n*median_ind]), n ) > 0 ) j--; if(i<=j) { int k; $ctype *aa = &xx[n*i]; $ctype *bb = &xx[n*j]; for( k=0; k 1, Pars => 'a(n,m); [o]b(n,m);', Code => 'int nn; int nd; loop(n,m) %{ $b() = $a(); %} nn = ($COMP(__m_size))-1; nd = $COMP(__n_size); if ($SIZE(m) > 0) { '.generic_vecval_qsortvec('b','nd').' }', Doc => ' =for ref Drop-in replacement for qsortvec(), which is broken in the stock PDL-2.4.3 release. See PDL::Ufunc::qsortvec. ', BadDoc => ' Vectors with bad components should be moved to the end of the array. ', ); # pp_def vv_qsortvec ##====================================================================== ## vv_qsortveci: new ## + adopted from patched $PDL_SRC_ROOT/Basic/Ufunc/ufunc.pd ##====================================================================== # Internal utility sorting routine for vv_qsortveci foreach (keys %PDL::Types::typehash) { my $ctype = $PDL::Types::typehash{$_}{ctype}; my $ppsym = $PDL::Types::typehash{$_}{ppsym}; pp_addhdr(<<"FOO" /*-- vector-based sorted index acquisition --*/ void pdl_vecval_qsortvec_ind_$ppsym($ctype *xx, PDL_Indx *ix, int n, PDL_Indx a, PDL_Indx b) { PDL_Indx i,j, median_ind, tmpi; $ctype t; i = a; j = b; median_ind = (i+j)/2; /*-- an index into ix, NOT into xx --*/ do { while( pdl_vecval_cmpvec_$ppsym( &(xx[n*ix[i]]), &(xx[n*ix[median_ind]]), n ) < 0 ) /*-- xx[ix[i]] < median --*/ i++; while( pdl_vecval_cmpvec_$ppsym( &(xx[n*ix[j]]), &(xx[n*ix[median_ind]]), n ) > 0 ) /*-- median < xx[ix[j]] --*/ j--; if(i<=j) { tmpi = ix[i]; ix[i] = ix[j]; ix[j] = tmpi; if (median_ind==i) median_ind=j; else if (median_ind==j) median_ind=i; i++; j--; } } while (i <= j); if (a < j) pdl_vecval_qsortvec_ind_$ppsym( xx, ix, n, a, j ); if (i < b) pdl_vecval_qsortvec_ind_$ppsym( xx, ix, n, i, b ); } FOO ); } sub generic_vecval_qsortvec_ind { my $pdl = shift; my $ix = shift; my $ndim = shift; return ('$T'.join('',@vv_target_typechars) .'(' .join(',', map {'pdl_vecval_qsortvec_ind_'.$_} @vv_target_typechars) .')' .'($P('.$pdl.'), $P('.$ix.'), '.$ndim.', 0, nn);' ); } pp_def( 'vv_qsortveci', HandleBad => 1, Pars => "a(n,m); $INDX \[o]ix(m);", Code => 'int nn, nd; PDL_Indx mi=0; loop(m) %{ $ix() = mi++; %} nn = ($COMP(__m_size))-1; nd = $COMP(__n_size); if ($SIZE(m) > 0) { '.generic_vecval_qsortvec_ind('a','ix','nd').' }', Doc => ' =for ref Get lexicographic sort order of a matrix $a() viewed as a list of vectors. ', BadDoc => ' Vectors with bad components should be treated as last in the lexicographic order. ', ); # pp_def 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()', PMCode=> (q( sub PDL::vv_union { my ($a,$b,$c,$nc) = @_; barf("PDL::VectorValued::vv_union(): dimension mismatch") if ($a->dim(-2) != $b->dim(-2)); my @adims = $a->dims; if (!defined($c)) { my $ctype = $a->type > $b->type ? $a->type : $b->type; $c = PDL->zeroes($ctype, @adims[0..($#adims-1)], $adims[$#adims] + $b->dim(-1)); } $nc = PDL->zeroes(PDL::long(), (@adims > 2 ? @adims[0..($#adims-2)] : 1)) if (!defined($nc)); &PDL::_vv_union_int($a,$b,$c,$nc); return ($c,$nc) if (wantarray); return $c->mv(-1,0)->slice("0:".($nc->sclr-1))->mv(0,-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; )), 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()', PMCode=> (q( sub PDL::vv_intersect { my ($a,$b,$c,$nc) = @_; barf("PDL::VectorValued::vv_intersect(): dimension mismatch") if ($a->dim(-2) != $b->dim(-2)); my @adims = $a->dims; my $NA = $adims[$#adims]; my $NB = $b->dim(-1); if (!defined($c)) { my $ctype = $a->type > $b->type ? $a->type : $b->type; $c = PDL->zeroes($ctype, @adims[0..($#adims-1)], $NA < $NB ? $NA : $NB); } $nc = PDL->zeroes(PDL::long(), (@adims > 2 ? @adims[0..($#adims-2)] : 1)) if (!defined($nc)); &PDL::_vv_intersect_int($a,$b,$c,$nc); return ($c,$nc) if (wantarray); return $c->mv(-1,0)->slice("0:".($nc->sclr-1))->mv(0,-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; )), 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()', PMCode=> (q( sub PDL::vv_setdiff { my ($a,$b,$c,$nc) = @_; barf("PDL::VectorValued::vv_setdiff(): dimension mismatch") if ($a->dim(-2) != $b->dim(-2)); my @adims = $a->dims; my $NA = $adims[$#adims]; my $NB = $b->dim(-1); if (!defined($c)) { my $ctype = $a->type > $b->type ? $a->type : $b->type; $c = PDL->zeroes($ctype, @adims[0..($#adims-1)], $NA); } $nc = PDL->zeroes(PDL::long(), (@adims > 2 ? @adims[0..($#adims-2)] : 1)) if (!defined($nc)); &PDL::_vv_setdiff_int($a,$b,$c,$nc); return ($c,$nc) if (wantarray); return $c->mv(-1,0)->slice("0:".($nc->sclr-1))->mv(0,-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; )), 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()', PMCode=> (q( sub PDL::v_union { my ($a,$b,$c,$nc) = @_; barf("PDL::VectorValued::v_union(): only 1d vectors are supported") if ($a->ndims > 1 || $b->ndims > 1); $nc = PDL->pdl(PDL::long(), $a->dim(0) + $b->dim(0)) if (!defined($nc)); if (!defined($c)) { my $ctype = $a->type > $b->type ? $a->type : $b->type; $c = PDL->zeroes($ctype, ref($nc) ? $nc->sclr : $nc); } &PDL::_v_union_int($a,$b,$c,$nc); return ($c,$nc) if (wantarray); return $c->reshape($nc->sclr); } )), 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; )), 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()', PMCode=> (q( sub PDL::v_intersect { my ($a,$b,$c,$nc) = @_; barf("PDL::VectorValued::v_intersect(): only 1d vectors are supported") if ($a->ndims > 1 || $b->ndims > 1); my $NA = $a->dim(0); my $NB = $b->dim(0); $nc = PDL->pdl(PDL::long(), $NA < $NB ? $NA : $NB) if (!defined($nc)); if (!defined($c)) { my $ctype = $a->type > $b->type ? $a->type : $b->type; $c = PDL->zeroes($ctype, ref($nc) ? $nc->sclr : $nc); } &PDL::_v_intersect_int($a,$b,$c,$nc); return ($c,$nc) if (wantarray); return $c->reshape($nc->sclr); } )), 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; )), 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()', PMCode=> (q( sub PDL::v_setdiff { my ($a,$b,$c,$nc) = @_; barf("PDL::VectorValued::v_setdiff(): only 1d vectors are supported") if ($a->ndims > 1 || $b->ndims > 1); my $NA = $a->dim(0); my $NB = $b->dim(0); $nc = PDL->pdl(PDL::long(), $NA) if (!defined($nc)); if (!defined($c)) { my $ctype = $a->type > $b->type ? $a->type : $b->type; $c = PDL->zeroes($ctype, $NA); } &PDL::_v_setdiff_int($a,$b,$c,$nc); return ($c,$nc) if (wantarray); return $c->reshape($nc->sclr); } )), 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; )), 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 =item * Code for vv_qsortvec() copied nearly verbatim from the builtin PDL functions in $PDL_SRC_ROOT/Basic/Ufunc/ufunc.pd, with Chris Marshall's "uniqsortvec" patch. Code for vv_qsortveci() based on the same. =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-2015, 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.9/README.txt0000644000175000017500000000401612624575275016011 0ustar moocowbovines README for PDL::VectorValued ABSTRACT PDL::VectorValued - Assorted PDL utilities treating vectors as values REQUIREMENTS * PDL Tested versions 2.4.3, 2.4.7_001, 2.4.9, 2.4.9_015. 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 * Code for vv_qsortvec() copied nearly verbatim from the builtin PDL functions in $PDL_SRC_ROOT/Basic/Ufunc/ufunc.pd, with Chris Marshall's "uniqsortvec" patch. Code for vv_qsortveci() based on the same. AUTHOR Bryan Jurish COPYRIGHT * 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. * All other parts copyright (c) 2007-2011, 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.9/ChangeLog0000644000175000017500000000710613277502220016051 0ustar moocowbovines##-*- Mode: Change-Log; coding: utf-8; -*- ## ## Change log for perl distribution PDL::VectorValued 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.9/MANIFEST.SKIP0000644000175000017500000000040113277501436016174 0ustar moocowbovines\#$ \.svn \.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$ PDL-VectorValued-1.0.9/META.json0000644000175000017500000000166113277502542015727 0ustar moocowbovines{ "abstract" : "Assorted utilities for vector-valued PDLs", "author" : [ "Bryan Jurish" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.1002, 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" : "0", "Test::More" : "0" } } }, "release_status" : "stable", "version" : "v1.0.9", "x_serialization_backend" : "JSON::PP version 2.27400" } PDL-VectorValued-1.0.9/pdlmaker.plm0000644000175000017500000001162313277501712016614 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 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 .= <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 PDL-VectorValued-1.0.9/Makefile.PL0000644000175000017500000000112713277500571016255 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 => 0, 'Test::More' => 0, }, CONFIGURE_REQUIRES => { PDL => 0, }, realclean => { FILES => join(' ', qw(*~ *.tmp),(-e 'README.rpod' ? 'README.txt' : qw())), }, ); PDL-VectorValued-1.0.9/t/0000755000175000017500000000000013277502542014545 5ustar moocowbovinesPDL-VectorValued-1.0.9/t/05_vcos.t0000644000175000017500000000401612725241073016205 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.9/t/03_setops.t0000644000175000017500000000372612634474712016564 0ustar moocowbovines# -*- Mode: CPerl -*- # t/03_setops.t: test PDL::VectorValued set operations use Test::More tests=>12; ##-- 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)); print "\n"; # end of t/03_setops.t PDL-VectorValued-1.0.9/t/common.plt0000644000175000017500000000557012634506143016562 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 { 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 { 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 { 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 { 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 { 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))); } # pdlok_nodims($label, $got, $want) # + ignores dimensions sub pdlok_nodims { 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 { 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))); } print "loaded ", __FILE__, "\n"; 1; PDL-VectorValued-1.0.9/t/00_basic.t0000644000175000017500000000013212634472712016307 0ustar moocowbovines##-*- Mode: CPerl -*- use Test::More tests=>2; use_ok 'PDL'; use_ok 'PDL::VectorValued'; PDL-VectorValued-1.0.9/t/04_types.t0000644000175000017500000000152212634475007016402 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.9/t/01_rlevec.t0000644000175000017500000000606312634473437016525 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) = 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 = rldvec($pf,$pv); pdlok("rldvec()", $pd, $p); ## 4..4: test enumvec my $pk = enumvec($p); pdlok("enumvec()", $pk, pdl(long,[0,1,2,0,1,0])); ## 5..5: test enumvecg $pk = enumvecg($p); pdlok("enumvecg()", $pk, pdl(long,[0,0,0,1,1,2])); ##-------------------------------------------------------------- ## rleND, rldND: 2d ## 6..7: test rleND(): 2d ($pf,$pv) = rleND($p); pdlok("rleND():2d:counts", $pf, $pf_expect); pdlok("rleND():2d:elts", $pv, $pv_expect); ## 8..8: test rldND(): 2d $pd = 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) = 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 = 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->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 = null->short; $seqs = $seqs->append(sequence(short,$_)) foreach ($lens->list); $seqs += $lens->rld($offs); my $seqs_got = $lens->rldseq($offs); isok("rldseq():type", $seqs_got->type, $seqs->type); pdlok("rldseq():data", $seqs_got, $seqs); my ($len_got,$off_got) = $seqs->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.9/t/02_cmpvec.t0000644000175000017500000000305512634473657016525 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->cmpvec($v2)<0); isok("cmpvec:1d:>", $v2->cmpvec($v1)>0); isok("cmpvec:1d:==", $v1->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->vsearchvec($which), pdl(long,[0,2,4,6])); isok("vsearchvev():<<", all(pdl([-1,-1])->vsearchvec($which)==0)); isok("vsearchvev():>>", all(pdl([2,2])->vsearchvec($which)==$which->dim(1)-1)); print "\n"; # end of t/02_cmpvec.t PDL-VectorValued-1.0.9/README.rpod0000644000175000017500000000372311700312222016111 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 versions 2.4.3, 2.4.7_001, 2.4.9, 2.4.9_015. =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 =item * Code for vv_qsortvec() copied nearly verbatim from the builtin PDL functions in $PDL_SRC_ROOT/Basic/Ufunc/ufunc.pd, with Chris Marshall's "uniqsortvec" patch. Code for vv_qsortveci() based on the same. =back =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-2011, 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 =cut PDL-VectorValued-1.0.9/MANIFEST0000644000175000017500000000075613277502542015443 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.9/VectorValued/0000755000175000017500000000000013277502542016705 5ustar moocowbovinesPDL-VectorValued-1.0.9/VectorValued/Makefile.PL0000644000175000017500000000335013277501662020662 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', ], ); ##-- 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.9/VectorValued/Dev.pm0000644000175000017500000003352513277502350017766 0ustar moocowbovines## -*- Mode: CPerl -*- ## + CPerl pukes on '/esg'-modifiers.... bummer ## ## $Id: Dev.pm 9589 2018-05-18 07:47:27Z moocow $ ## ## File: PDL::VectorValued::Dev.pm ## Author: Bryan Jurish ## Description: Vector utilities for PDL: development ##====================================================================== package PDL::VectorValued::Dev; use strict; ##====================================================================== ## Export hacks #use PDL::PP; ##-- do NOT do this! use Exporter; our $VERSION = '1.0.9'; ##-- 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 sub vvpp_def { my ($name,%args) = @_; foreach (qw(Code BadCode)) { $args{$_} = vvpp_expand($args{$_}) if (defined($args{$_})); } 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 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::ngutils 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(). Unfortunately, I don't currently have the time to figure out how to use the (undocumented) PDL::PP macro expansion mechanism. Feel free to add real macro support. =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-2015, 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.9/VectorValued/Version.pm0000644000175000017500000000123613277502240020665 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.9'; #$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.9/META.yml0000644000175000017500000000104613277502542015554 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.1002, 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: '0' Test::More: '0' version: v1.0.9 x_serialization_backend: 'CPAN::Meta::YAML version 0.018' PDL-VectorValued-1.0.9/VectorValued.pm0000644000175000017500000001510113277502350017236 0ustar moocowbovines## $Id: VectorValued.pm 9589 2018-05-18 07:47:27Z moocow $ ## ## File: PDL::VectorValued.pm ## Author: Bryan Jurish ## Description: Vector utilities for PDL: perl side only ##====================================================================== package PDL::VectorValued; use strict; ##====================================================================== ## Export hacks use PDL; use PDL::Exporter; use PDL::VectorValued::Utils; our @ISA = qw(PDL::Exporter); our @EXPORT_OK = ( (@PDL::VectorValued::Utils::EXPORT_OK), ##-- inherited qw(vv_uniqvec), qw(rleND rldND), qw(vv_indx), ); 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.9'; ##====================================================================== ## 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: 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::rlevec(), PDL::VectorValued::Utils::rldvec(). =cut ##---------------------------------------------------------------------- ## rleND() =pod =head2 rleND =for sig Signature: (data(@vdims,N); int [o]counts(N); [o]elts(@vdims,N)) =for ref Run-length encode a set of (sorted) n-dimensional values. Generalization of rle() and 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::rlevec. =cut *PDL::rleND = \&rleND; sub rleND { my $data = shift; my @vdimsN = $data->dims; ##-- construct output pdls my $counts = $#_ >= 0 ? $_[0] : zeroes(long, $vdimsN[$#vdimsN]); my $elts = $#_ >= 1 ? $_[1] : zeroes($data->type, @vdimsN); ##-- guts: call rlevec() rlevec($data->clump($#vdimsN), $counts, $elts->clump($#vdimsN)); return ($counts,$elts); } ##---------------------------------------------------------------------- ## rldND() =pod =head2 rldND =for sig Signature: (int counts(N); elts(@vdims,N); [o]data(@vdims,N);) =for ref Run-length decode a set of (sorted) n-dimensional values. Generalization of rld() and rldvec(): given a vector $counts() of the number of occurrences of each @vdims-dimensioned element, and a set $elts() of @vdims-dimensioned elements, run-length decode to $data(). Really just a wrapper for clump() and rldvec(). See also: PDL::Slices::rld, PDL::VectorValued::Utils::rldvec =cut *PDL::rldND = \&rldND; sub rldND { my ($counts,$elts) = (shift,shift); my @vdimsN = $elts->dims; ##-- construct output pdl my ($data); if ($#_ >= 0) { $data = $_[0]; } else { my $size = $counts->sumover->max; ##-- get maximum size for Nth-dimension for small encodings my @countdims = $counts->dims; shift(@countdims); $data = zeroes($elts->type, @vdimsN, @countdims); } ##-- guts: call rldvec() rldvec($counts, $elts->clump($#vdimsN), $data->clump($#vdimsN)); return $data; } ##====================================================================== ## 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(@_); } 1; ##-- make perl happy ##====================================================================== ## 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 ##====================================================================== ## 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, 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