1#!perl 2 3use strict; 4use warnings; 5 6use Test::More; 7 8use PDL::LiteF; 9 10use PDL::Primitive; 11 12 13# Some of these tests are based upon those in Chapter 5 of Programming 14# Pearls, by J. Bentley 15 16# choose a non-factor of two odd number for the length 17my $N = 723; 18 19my $ones = ones( $N ); 20my $idx = sequence( $N ); 21my $x = $idx * 10; 22 23# create ordered duplicates so can test insertion points. This creates 24# 7 sequential duplicates of the values 0-99 25my $ndup = 7; 26my $xdup = double long sequence( $ndup * 100 ) / $ndup; 27 28# get insertion points and values 29my ( $xdup_idx_insert_left, $xdup_idx_insert_right, $xdup_values ) = do { 30 31 my ( $counts, $values ) = do { my @q = $xdup->rle; where( @q, $q[0] > 0 ) }; 32 33 ( $counts->cumusumover - $counts->at( 0 ), $counts->cumusumover, $values ); 34 35}; 36 37# The tests are table driven, with appropriate inputs and outputs for 38# forward and reverse sorted arrays. The tests sort the input array 39# against itself, so we have a very good idea of which indices should 40# be returned. Most of the tests use that. There are also specific 41# tests for the endpoints as specified in the documentation, which 42# may be easier for humans to parse and validate. 43 44my %search = ( 45 46 sample => { 47 48 all_the_same_element => $N - 1, # finds right-most element 49 50 forward => { 51 idx => $idx, 52 x => $x, 53 equal => $idx, 54 nequal_m => $idx, 55 nequal_p => 56 do { my $t = $idx + 1; $t->set( -1, $t->at( -1 ) - 1 ); $t }, 57 xdup => { 58 set => $xdup, 59 idx => $xdup_idx_insert_left, 60 values => $xdup_values, 61 }, 62 #<<< noperltidy 63 docs => [ 64 ' V <= xs[0] : i = 0 ' => [ ( 0, -1, 0 ), 65 ( 0, 0, 0 ), 66 ], 67 'xs[0] < V <= xs[-1] : i s.t. xs[i-1] < V <= xs[i]' => [ ( 0, 1, 1 ), 68 ( 1, 0, 1 ), 69 ( -1, 0, $N-1 ), 70 ], 71 'xs[-1] < V : i = $xs->nelem -1 ' => [ ( -1, 0, $N-1 ), 72 ( -1, 1, $N-1 ), 73 ], 74 ], 75 #>>> noperltidy 76 }, 77 78 reverse => { 79 idx => $idx, 80 x => $x->mslice( [ -1, 0 ] ), 81 equal => $idx, 82 nequal_m => $idx, 83 nequal_p => do { my $t = $idx - 1; $t->set( 0, 0 ); $t }, 84 xdup => { 85 set => $xdup->slice( [ -1, 0 ] ), 86 idx => $xdup->nelem - 1 - $xdup_idx_insert_left, 87 values => $xdup_values, 88 }, 89 #<<< noperltidy 90 docs => [ 91 ' V > xs[0] : i = 0 ' => [(0, 1, 0) ], 92 'xs[0] >= V > xs[-1] : i s.t. xs[i] >= V > xs[i+1]' => [(0, 0, 0), 93 (0, -1, 0), 94 (1, 0, 1), 95 ], 96 'xs[-1] >= V : i = $xs->nelem - 1 ' => [(-1, 0, $N-1), 97 (-1, -1, $N-1), 98 ], 99 ], 100 #>>> noperltidy 101 102 } 103 104 }, 105 106 insert_leftmost => { 107 108 all_the_same_element => 0, 109 110 forward => { 111 idx => $idx, 112 x => $x, 113 equal => $idx, 114 nequal_m => $idx, 115 nequal_p => $idx + 1, 116 xdup => { 117 set => $xdup, 118 idx => $xdup_idx_insert_left, 119 values => $xdup_values, 120 }, 121 #<<< noperltidy 122 docs => [ 123 ' V <= xs[0] : i = 0 ' => [ ( 0, -1, 0 ), 124 ( 0, 0, 0) 125 ], 126 'xs[0] < V <= xs[-1] : i s.t. xs[i-1] < V <= xs[i]' => [ ( 0, 1, 1 ), 127 ( 1, 0, 1 ), 128 ( -1, 0, $N-1 ), 129 ], 130 'xs[-1] < V : i = $xs->nelem ' => [ 131 ( -1, 1, $N ), 132 ], 133 134 ], 135 #>>> noperltidy 136 137 }, 138 139 reverse => { 140 idx => $idx, 141 x => $x->mslice( [ -1, 0 ] ), 142 equal => $idx, 143 nequal_m => $idx, 144 nequal_p => $idx - 1, 145 xdup => { 146 set => $xdup->mslice( [ -1, 0 ] ), 147 idx => $xdup->nelem - 1 - $xdup_idx_insert_left, 148 values => $xdup_values, 149 }, 150 151 #<<< noperltidy 152 docs => [ 153 ' V > xs[0] : i = -1 ' => [ ( 0, 1, -1 ), ], 154 'xs[0] >= V >= xs[-1] : i s.t. xs[i] >= V > xs[i+1]' => [ ( 0, 0, 0 ), 155 ( 0, -1, 0 ), 156 ], 157 'xs[-1] >= V : i = $xs->nelem -1 ' => [ ( -1, 0, $N-1 ), 158 ( -1, -1, $N-1 ), 159 ], 160 161 ], 162 #>>> noperltidy 163 164 }, 165 }, 166 167 insert_rightmost => { 168 169 all_the_same_element => $N, 170 171 forward => { 172 idx => $idx, 173 x => $x, 174 equal => $idx + 1, 175 nequal_m => $idx, 176 nequal_p => $idx + 1, 177 xdup => { 178 set => $xdup, 179 idx => $xdup_idx_insert_right, 180 values => $xdup_values, 181 idx_offset => -1, # returns index of element *after* the value 182 }, 183 #<<< noperltidy 184 docs => [ 185 ' V < xs[0] : i = 0 ' => [ ( 0, -1, 0 ) ], 186 'xs[0] <= V < xs[-1] : i s.t. xs[i-1] <= V < xs[i]' => [ ( 0, 0, 1 ), 187 ( 0, 1, 1 ), 188 ( 1, 0, 2 ), 189 ], 190 'xs[-1] <= V : i = $xs->nelem ' => [ ( -1, 0, $N ), 191 ( -1, 1, $N ), 192 ], 193 ], 194 #>>> noperltidy 195 }, 196 197 reverse => { 198 idx => $idx, 199 x => $x->mslice( [ -1, 0 ] ), 200 equal => $idx - 1, 201 nequal_m => $idx, 202 nequal_p => $idx - 1, 203 xdup => { 204 set => $xdup->mslice( [ -1, 0 ] ), 205 idx => $xdup->nelem - 1 - $xdup_idx_insert_right, 206 values => $xdup_values, 207 idx_offset => +1, # returns index of element *after* the value 208 }, 209 #<<< noperltidy 210 docs => [ 211 ' V >= xs[0] : i = -1 ' => [ ( 0, 1, -1 ), 212 ( 0, 0, -1 ), 213 ], 214 'xs[0] > V >= xs[-1] : i s.t. xs[i] >= V > xs[i+1]' => [ ( 0, -1, 0 ), 215 ( -1, 1, $N-2 ), 216 ( -1, 0, $N-2 ), 217 ], 218 'xs[-1] > V : i = $xs->nelem -1 ' => [ ( -1, -1, $N-1 ) ] 219 ], 220 #>>> noperltidy 221 }, 222 }, 223 224 match => { 225 226 all_the_same_element => ( $N ) >> 1, 227 228 forward => { 229 idx => $idx, 230 x => $x, 231 equal => $idx, 232 nequal_m => -( $idx + 1 ), 233 nequal_p => -( $idx + 1 + 1 ), 234 xdup => { 235 set => $xdup, 236 values => $xdup_values, 237 }, 238 #<<< noperltidy 239 docs => [ 240 'V < xs[0] : i = -1' => [ ( 0, -1, -1 ), ], 241 'V == xs[n] : i = n' => [ ( 0, 0, 0 ), 242 ( -1, 0, $N-1 ) ], 243 'xs[0] > V > xs[-1], V != xs[n] : -(i+1) s.t. xs[i] > V > xs[i+1]' => [ ( 0, 1, -( 1 + 1) ), 244 ( 1, -1, -( 1 + 1 ) ), 245 ( 1, 1, -( 2 + 1 ) ), 246 ( -1, -1, -( $N - 1 + 1 ) ), 247 ], 248 ' V > xs[-1] : -($xs->nelem - 1 + 1)' => [ ( -1, 1, -( $N + 1) ), ] 249 ], 250 #>>> noperltidy 251 }, 252 253 reverse => { 254 idx => $idx, 255 x => $x->mslice( [ -1, 0 ] ), 256 equal => $idx, 257 nequal_m => -( $idx + 1 ), 258 nequal_p => -( $idx + 1 - 1 ), 259 xdup => { 260 set => $xdup->mslice( [ -1, 0 ] ), 261 values => $xdup_values, 262 }, 263 #<<< noperltidy 264 docs => [ 265 'V > xs[0] : i = 0' => [ ( 0, 1, 0 ), ], 266 'V == xs[n] : i = n' => [ ( 0, 0, 0 ), 267 ( -1, 0, $N-1 ) ], 268 'xs[0] < V < xs[-1], V != xs[n] : -(i+1) s.t. xs[i-1] > V > xs[i]' => [ ( 0, -1, -( 0 + 1) ), 269 ( 1, 1, -( 0 + 1 ) ), 270 ( 1, -1, -( 1 + 1 ) ), 271 ( -1, -1, -( $N - 1 + 1 ) ), 272 ], 273 ' xs[-1] > V: -($xs->nelem - 1 + 1)' => [ ( -1, -1, -( $N - 1 + 1) ), ] 274 ], 275 #>>> noperltidy 276 }, 277 }, 278 279 bin_inclusive => { 280 281 all_the_same_element => $N - 1, 282 283 forward => { 284 idx => $idx, 285 x => $x, 286 equal => $idx, 287 nequal_m => $idx - 1, 288 nequal_p => $idx, 289 xdup => { 290 set => $xdup, 291 idx => $xdup_idx_insert_left + $ndup - 1, 292 values => $xdup_values, 293 }, 294 #<<< noperltidy 295 docs => [ 296 ' V < xs[0] : i = -1 ' => [ ( 0, -1, -1 ), ], 297 'xs[0] <= V < xs[-1] : i s.t. xs[i] <= V < xs[i+1]' => [ ( 0, 0, 0 ), 298 ( 0, 1, 0 ), 299 ( 1, -1, 0 ), 300 ( 1, 0, 1 ), 301 ( -1, -1, $N-2 ), 302 ], 303 'xs[-1] <= V : i = $xs->nelem - 1 ' => [ 304 ( -1, 0, $N-1 ), 305 ( -1, 1, $N-1 ), 306 ] 307 ], 308 #>>> noperltidy 309 }, 310 311 reverse => { 312 idx => $idx, 313 x => $x->mslice( [ -1, 0 ] ), 314 equal => $idx, 315 nequal_m => $idx + 1, 316 nequal_p => $idx, 317 xdup => { 318 set => $xdup->mslice( [ -1, 0 ] ), 319 idx => $xdup->nelem - ( 1 + $xdup_idx_insert_left + $ndup - 1 ), 320 values => $xdup_values, 321 }, 322 #<<< noperltidy 323 docs => [ 324 ' V >= xs[0] : i = 0 ' => [ (0, 1, 0 ), 325 (0, 0, 0 ) 326 ], 327 'xs[0] > V >= xs[-1] : i s.t. xs[i+1] > V >= xs[i]' => [ ( 0, -1, 1 ), 328 ( 1, 1, 1 ), 329 ( 1, 0, 1 ), 330 ( 1, -1, 2 ), 331 ( -1, 0, $N-1 ), 332 ], 333 'xs[-1] > V : i = $xs->nelem -1 ' => [ ( -1, -1, $N ) ], 334 ], 335 #>>> noperltidy 336 }, 337 }, 338 339 bin_exclusive => { 340 341 all_the_same_element => -1, 342 343 forward => { 344 idx => $idx, 345 x => $x, 346 equal => $idx - 1, 347 nequal_m => $idx - 1, 348 nequal_p => $idx, 349 xdup => { 350 set => $xdup, 351 idx => $xdup_idx_insert_left - 1, 352 values => $xdup_values, 353 idx_offset => 1, 354 }, 355 #<<< noperltidy 356 docs => [ 357 ' V <= xs[0] : i = -1 ' => [ ( 0, -1, -1 ), 358 ( 0, 0, -1 ), 359 ], 360 'xs[0] < V <= xs[-1] : i s.t. xs[i] < V <= xs[i+1]' => [ ( 0, 1, 0 ), 361 ( 1, -1, 0 ), 362 ( 1, 0, 0 ), 363 ( 1, 1, 1 ), 364 ( -1, -1, $N-2 ), 365 ( -1, 0, $N-2 ), 366 ], 367 'xs[-1] < V : i = $xs->nelem - 1 ' => [ 368 ( -1, 1, $N-1 ), 369 ], 370 ], 371 #>>> noperltidy 372 }, 373 374 reverse => { 375 idx => $idx, 376 x => $x->mslice( [ -1, 0 ] ), 377 equal => $idx + 1, 378 nequal_m => $idx + 1, 379 nequal_p => $idx, 380 xdup => { 381 set => $xdup->mslice( [ -1, 0 ] ), 382 idx => $xdup->nelem - ( 1 + $xdup_idx_insert_left - 1 ), 383 values => $xdup_values, 384 idx_offset => -1, 385 }, 386 #<<< noperltidy 387 docs => [ 388 ' V > xs[0] : i = 0 ' => [ ( 0, 1, 0 ), ], 389 'xs[0] > V > xs[-1] : i s.t. xs[i-1] >= V > xs[i]' => [ ( 0, 0, 1 ), 390 ( 0, -1, 1 ), 391 ( -1, 1, $N-1 ), 392 ], 393 'xs[-1] >= V : i = $xs->nelem -1 ' => [ ( -1, 0, $N ), 394 ( -1, -1, $N ), 395 ], 396 ], 397 #>>> noperltidy 398 }, 399 }, 400 401); 402 403for my $mode ( 404 keys %search 405 ) 406{ 407 408 my $data = $search{$mode}; 409 410 subtest $mode => sub { 411 412 my ( $got, $exp ); 413 414 #<<< no perltidy 415 for my $sort_direction ( qw[ forward reverse ] ) { 416 417 subtest $sort_direction => sub { 418 419 my $so = $data->{$sort_direction} 420 or plan( skip_all => "not testing $sort_direction!\n" ); 421 422 ok( 423 all( 424 ( $got = vsearch( $so->{x}, $so->{x}, { mode => $mode } ) ) 425 == 426 ( $exp = $so->{equal} ) 427 ), 428 'equal elements' 429 ) or diag "got : $got\nexpected: $exp\n"; 430 431 ok( 432 all( 433 ( $got = vsearch( $so->{x} - 5, $so->{x}, { mode => $mode } ) ) 434 == 435 ( $exp = $so->{nequal_m} ) 436 ), 437 'non-equal elements x[i] < xs[i] (check lower bound)' 438 ) or diag "got : $got\nexpected: $exp\n"; 439 440 ok( 441 all( 442 ( $got = vsearch( $so->{x} + 5, $so->{x}, { mode => $mode } ) ) 443 == 444 ( $exp = $so->{nequal_p} ) 445 ), 446 'non-equal elements x[i] > xs[i] (check upper bound)' 447 ) or diag "got : $got\nexpected: $exp\n"; 448 449 450 # duplicate testing. 451 452 # check for values. note that the rightmost routine returns 453 # the index of the element *after* the last duplicate 454 # value, so we need an offset 455 ok( 456 all( 457 ( $got = $so->{xdup}{set}->index( vsearch( $so->{xdup}{values}, $so->{xdup}{set}, { mode => $mode } ) 458 + ($so->{xdup}{idx_offset} || 0) ) ) 459 == 460 ( $exp = $so->{xdup}{values} ) 461 ), 462 'duplicates values' 463 ) or diag "got : $got\nexpected: $exp\n"; 464 465 # if there are guarantees about which duplicates are returned, test it 466 if ( exists $so->{xdup}{idx} ) { 467 468 ok( 469 all( 470 ( $got = vsearch( $so->{xdup}{values}, $so->{xdup}{set}, { mode => $mode } ) ) 471 == 472 ( $exp = $so->{xdup}{idx} ) 473 ), 474 'duplicate indices' 475 ) or diag "got : $got\nexpected: $exp\n"; 476 477 } 478 479 if ( exists $so->{docs} ) { 480 481 while( my ($label, $inputs ) = splice( @{$so->{docs}}, 0, 2 ) ) { 482 483 while( @$inputs ) { 484 485 my ( $idx, $offset, $exp ) = splice( @$inputs, 0, 3 ); 486 my $value = $so->{x}->at($idx) + $offset; 487 488 is ( $got = ( vsearch( $value, $so->{x}, { mode => $mode } )->sclr), $exp, "$label: ($idx, $offset)" ); 489 490 } 491 } 492 } 493 494 495 }; 496 } 497 498 ok( 499 all( 500 ( $got = vsearch( $ones, $ones, { mode => $mode } ) ) 501 == 502 ( $exp = $data->{all_the_same_element} ) 503 ), 504 'all the same element' 505 ) or diag "got : $got\nexpected: $exp\n"; 506 507 #>>> no perltidy 508 509 }; 510 511} 512 513# test vsearch API to ensure backwards compatibility 514{ 515 my $vals = random( 100 ); 516 my $xs = sequence(100) / 99; 517 518 # implicit output piddle 519 my $indx0 = vsearch( $vals, $xs ); 520 521 my $ret = vsearch( $vals, $xs, my $indx1 = PDL->null() ); 522 523 is( $ret, undef, "no return from explicit output piddle" ); 524 525 ok ( all ( $indx0 == $indx1 ), 526 'explicit piddle == implicit piddle' ); 527} 528 529done_testing; 530