1#!/usr/local/bin/perl 2# 3# Test for bug in the pdl constructor for mixed arguments. 4# Separate from core.t because the problem crashes perl 5# and I'd like to keep the granularity of the core.t tests 6# 7use Test::More tests => 87; 8use PDL::LiteF; 9use PDL::Config; 10 11my $scalar = 1; 12my $pdl_e = pdl([]); 13my $pdl_s = pdl(2); 14my $pdl_v = pdl(3,4); 15my $pdl_vec2 = pdl([9,10]); 16my $pdl_m = pdl([5,6],[7,8]); 17my $pdl_row = pdl([[10,11]]); 18my $pdl_col = pdl([[12],[13]]); 19 20 21############################## 22# Test the basics (21 tests) 23isa_ok($pdl_s, 'PDL'); 24 25is $pdl_s->ndims(), 0, "scalar goes to scalar PDL"; 26is $pdl_s, 2, "PDL gets assigned scalar value"; 27 28is $pdl_v->ndims(), 1, "vector dims"; 29is $pdl_v->dim(0), 2, "vector size is 2"; 30is !!($pdl_v->at(0)==3 && $pdl_v->at(1)==4), 1, "vector contents"; 31 32is $pdl_vec2->ndims(), 1, "vector2 dims"; 33is $pdl_vec2->dim(0),2, "vector2 size is 2"; 34is !!($pdl_vec2->at(0)==9 && $pdl_vec2->at(1)==10), 1, "vector2 contents"; 35 36is $pdl_m->ndims(), 2, "matrix dims"; 37is $pdl_m->dim(0), 2, "matrix is 2 wide"; 38is $pdl_m->dim(1), 2, "matrix is 2 high"; 39is !!($pdl_m->at(0,0)==5 && $pdl_m->at(1,0)==6 && $pdl_m->at(0,1)==7 && $pdl_m->at(1,1)==8), 1, "matrix contents"; 40 41is $pdl_row->ndims(), 2, "row dims"; 42is $pdl_row->dim(0), 2, "row is 2 wide"; 43is $pdl_row->dim(1), 1, "row is 1 tall"; 44is !!($pdl_row->at(0,0)==10 && $pdl_row->at(1,0)==11), 1, "row contents"; 45 46is $pdl_col->ndims(), 2, "col dims"; 47is $pdl_col->dim(0), 1, "col is 1 wide"; 48is $pdl_col->dim(1), 2, "col is 2 tall"; 49is !!($pdl_col->at(0,0)==12 && $pdl_col->at(0,1)==13), 1, "col contents"; 50 51############################## 52# Test more complex array-ingestion case (6 tests) with padding 53my @a = (1,[2,3],[[4,5],[6,7]]); 54my $pdl_a = pdl(@a); 55my @testvals = ( [ [0,0,0], 1 ], 56 [ [1,0,0], 0 ], 57 [ [0,1,0], 0 ], 58 [ [1,1,0], 0 ], 59 [ [0,0,1], 2 ], 60 [ [1,0,1], 0 ], 61 [ [0,1,1], 3 ], 62 [ [1,1,1], 0 ], 63 [ [0,0,2], 4 ], 64 [ [1,0,2], 5 ], 65 [ [0,1,2], 6 ], 66 [ [1,1,2], 7 ] 67 ); 68 69is $pdl_a->ndims(), 3, 'complex array case dims'; 70is $pdl_a->dim(0), 2, 'complex dim 0'; 71is $pdl_a->dim(1), 2, 'complex dim 1'; 72is $pdl_a->dim(2), 3, 'complex dim 2'; 73 74my $test_ok = 1; 75for my $i(0..$#testvals) { 76 $test_ok *= $pdl_a->at( @{$testvals[$i]->[0]} ) == $testvals[$i]->[1]; 77} 78is $test_ok, 1, "contents of complex array-ingestion case"; 79 80{ 81 local $PDL::undefval = 99; 82 $pdl_a = pdl(@a); 83 $test_ok = 1; 84 for my $i(0..$#testvals) { 85 $test_ok *= $pdl_a->at( @{$testvals[$i]->[0]} ) == ($testvals[$i]->[1] || 99); 86 } 87 is $test_ok, 1, "complex array-ingestion with variant padding"; 88} 89 90############################## 91# Test some basic PDL-as-PDL cases 92 93## Ingest a scalar PDL 94my $p = pdl($pdl_s); 95isa_ok($p, 'PDL'); 96is $p->ndims(), 0, "scalar PDL goes to scalar PDL"; 97is $p, $pdl_s, "pdl(pdl(2)) same as pdl(2)"; 98 99## Ingest five scalar PDLs -- should make a 1-D array 100$p = pdl($pdl_s, $pdl_s, $pdl_s, $pdl_s, $pdl_s); 101isa_ok($p, 'PDL'); 102is $p->ndims(), 1, "two scalar PDLs -> a vector"; 103is $p->dim(0), 5, "5-vector"; 104is $p->at(0), $pdl_s, 'vector element 0 ok'; 105is $p->at(1), $pdl_s, 'vector element 1 ok'; 106is $p->at(2), $pdl_s, 'vector element 2 ok'; 107is $p->at(3), $pdl_s, 'vector element 3 ok'; 108is $p->at(4), $pdl_s, 'vector element 4 ok'; 109 110## Ingest a vector PDL and a scalar PDL - should make a 2-D array 111$p = pdl($pdl_v, $pdl_s); 112isa_ok($p, 'PDL'); 113is $p->ndims(), 2, 'pdl($pdl_v, $pdl_s) -> 2x2 matrix'; 114is $p->dim(0), 2, '2 wide'; 115is $p->dim(1), 2, '2 high'; 116is $p->at(0,0), $pdl_v->at(0), "vector element 0 got copied OK"; 117is $p->at(1,0), $pdl_v->at(1), "vector element 1 got copied OK"; 118is $p->at(0,1), $pdl_s, "scalar copied OK"; 119is $p->at(1,1), $PDL::undefval, "scalar got padded OK"; 120 121## Ingest a scalar PDL and a vector PDL - should make a 2-D array 122$p = pdl($pdl_s, $pdl_v); 123isa_ok($p, 'PDL'); 124is $p->ndims(), 2, 'pdl($pdl_s, $pdl_v) -> 2x2 matrix'; 125is $p->dim(0), 2, '2 wide'; 126is $p->dim(1), 2, '2 high'; 127is $p->at(0,0), $pdl_s, "scalar copied OK"; 128is $p->at(1,0), $PDL::undefval, "scalar got padded OK"; 129is $p->at(0,1), $pdl_v->at(0), "vector element 0 got copied OK"; 130is $p->at(1,1), $pdl_v->at(1), "vector element 1 got copied OK"; 131 132## A more complicated case 133$p = pdl($pdl_s, 5, $pdl_v, $pdl_m, [$pdl_v, $pdl_v]); 134isa_ok($p,'PDL'); 135is $p->ndims(), 3, 'complicated case -> 3-d PDL'; 136is $p->dim(0), 2, 'complicated case -> dim 0 is 2'; 137is $p->dim(1), 2, 'complicated case -> dim 1 is 2'; 138is $p->dim(2), 5, 'complicated case -> dim 1 is 5'; 139@testvals = ([ [0,0,0], 2 ], [ [1,0,0], 0 ], [ [0,1,0], 0 ], [ [1,1,0], 0 ], 140 [ [0,0,1], 5 ], [ [1,0,1], 0 ], [ [0,1,1], 0 ], [ [1,1,1], 0 ], 141 [ [0,0,2], 3 ], [ [1,0,2], 0 ], [ [0,1,2], 4 ], [ [1,1,2], 0 ], 142 [ [0,0,3], 5 ], [ [1,0,3], 6 ], [ [0,1,3], 7 ], [ [1,1,3], 8 ], 143 [ [0,0,4], 3 ], [ [1,0,4], 4 ], [ [0,1,4], 3 ], [ [1,1,4], 4 ] 144 ); 145$test_ok = 1; 146for my $i(0..$#testvals) { 147 $test_ok *= $p->at(@{$testvals[$i]->[0]}) == $testvals[$i]->[1]; 148} 149is $test_ok, 1, "contents of complicated case"; 150 151############################## 152# test empty PDLs. 153$p = pdl($pdl_e); 154is $p->nelem, 0, "piddlifying an empty piddle yields 0 elements"; 155 156$p = pdl($pdl_e, $pdl_e); 157is $p->ndims, 2, "piddlifying two 0-PDLs makes a 2D-PDL"; 158is $p->dim(0),0, "piddlifying two empty piddles makes a 0x2-PDL"; 159is $p->dim(1),2, "piddlifying two empty piddles makes a 0x2-PDL"; 160eval { $p->at(0,0) }; 161ok( $@ =~ m/^Position out of range/ , "can't index an empty PDL with at" ); 162 163$p = pdl(pdl([4]),5); 164is $p->ndims, 2, "catenating a 1-PDL and a scalar yields a 2D PDL"; 165is $p->dim(0), 1, "catenating a 1-PDL and a scalar yields a 1x2-PDL"; 166is $p->dim(1), 2, "catenating a 1-PDL and a scalar yields a 1x2-PDL"; 167is $p->at(0,0), 4, "catenating a 1-PDL and a scalar does the Right Thing"; 168is $p->at(0,1), 5, "catenating a 1-PDL and a scalar does the Right Thing, redux"; 169 170$p = pdl($pdl_e, 5); 171is $p->ndims, 2, "catenating an empty and a scalar yields a 2D PDL"; 172is $p->dim(0), 1, "catenating an empty and a scalar yields a 1x2-PDL"; 173is $p->dim(1), 2, "catenating an empty and a scalar yields a 1x2-PDL"; 174is $p->at(0,0), $PDL::undefval, "padding OK for empty & scalar case"; 175is $p->at(0,1), 5, "scalar OK for empty & scalar"; 176 177 178$p = pdl(5, $pdl_e); 179is $p->ndims, 2, "catenating a scalar and an empty yields a 2D PDL"; 180is $p->dim(0), 1, "catenating a scalar and an empty yields a 1x2-PDL"; 181is $p->dim(1), 2, "catenating a scalar and an empty yields a 1x2-PDL"; 182is $p->at(0,0), 5, "scalar OK for scalar & empty"; 183is $p->at(0,1), $PDL::undefval, "padding OK for scalar & empty"; 184 185 186# This is from sf.net bug #3011879 187my @c; 188$c[0][0]=pdl(0,4,2,1); 189$c[1][0]=pdl(0,0,1,1); 190$c[2][0]=pdl(0,0,0,1); 191$c[0][1]=pdl(0,0,3,1); 192$c[1][1]=pdl(0,0,2,1); 193$c[2][1]=pdl(5,1,1,1); 194my $d = pdl(@c); 195 196############################## 197# test bad values 198 SKIP: { 199 skip "BAD values not compiled in",7 unless($PDL::Bad::Status); 200 201 $a = pdl(3,4,5); 202 $a=$a->setbadif($a==4); 203 eval '$b = pdl($a,5);'; 204 ok(!$@, "a badvalue PDL works in the constructor"); 205 206 ok( $b->badflag, "bad value propagates from inner PDL to constructed PDL" ); 207 ok( $b->slice("(1),(0)") == $b->badvalue, "bad value was passed in" ); 208 ok( $b->at(1,1) == 0, "padding was correct" ); 209 210 eval '$b = pdl(short, $a, 5);'; 211 212 ok(!$@, "constructed a short PDL"); 213 ok( $b->slice("(1),(0)") == $b->badvalue, "bad value was translated" ); 214 ok( $b->at(1,1) == 0, "padding was correct"); 215 216} 217 218 219 220 221