examples/sort.t

   1 use v6;
   2
   3 use Test;
   4
   5 plan 28;
   6
   7 # This is a perl6 implementation of L<S29/List/"=item sort">
   8 # based on mergesort.
   9
  10 =begin comment
  11
  12   * Existence
  13      * Clarify why this implementation of a spec'ed feature
  14        exists in the "unspecced" directory of the test suite.
  15         * That was where suggested when asked for suggestions
  16           on #perl6.  Other suggestions welcome.
  17
  18   * Pugs
  19      * `subset`
  20
  21   * Spec
  22      * any Ordering has traits or only top level?
  23         *  {.TEST(:M)} is descending => &fuzzy_cmp is insensitive
  24
  25   * Syntax cleanup
  26      * guidance on making this the builtin sort()
  27
  28 =end comment
  29
  30 # L<S29/"List"/"=item sort">
  31
  32 my $prelude_sort = q:to 'END_PRELUDE_SORT';
  33     subset KeyExtractor of Code where { .sig === :(Any --> Any) };
  34     subset Comparator   of Code where { .sig === :(Any, Any --> Int) };
  35     subset OrderingPair
  36         of Pair where { .key ~~ KeyExtractor && .value ~~ Comparator };
  37     subset Ordering
  38         of Signature | KeyExtractor | Comparator | OrderingPair;
  39
  40     module Prelude::Sort {
  41         our Order
  42         sub qby_cmp (Code @qby, $a, $b)
  43         {
  44             my $result        = Order::Same;
  45             my &return_ifn0 ::= -> $v { if $v { $result = $v; leave LOOP; } };
  46
  47             LOOP: for @by -> $cmpr {
  48                 return_ifn0 $cmpr($a, $b);
  49             }
  50
  51             $result;
  52         }
  53
  54         our bool
  55         sub in_order (Code @qby, *$x, *@xs)
  56         {
  57             my $result = 1;
  58             my $y := $x;
  59
  60             for @xs -> $z {
  61                 if by_cmp(@qby, $y, $z) > 0 {
  62                     $result = 0;
  63                     last;
  64                 }
  65
  66                 $y := $z;
  67             }
  68
  69             $result;
  70         }
  71
  72         our Array of Code
  73         sub qualify_by (Ordering @by)
  74         {
  75             my Any sub keyex (KeyExtractor $ex, Any $v) is cached
  76                 { $ex($v); }
  77
  78             my Array sub sigkex (Signature $sig is copy, Any $v) is cached
  79                 { $sig := $v; @$sig; }
  80
  81             gather {
  82                 for @by -> $criterion {
  83                     when Signature {
  84                         my Signature $sig := $crierion;
  85                         my Array &kex     := &sigkex;
  86
  87                         my $cmpr -> $a, $b {
  88                             my $value;
  89
  90                             for zip(@$a; @$b; @$sig) -> $x, $y, ::T {
  91                                 my $u;
  92                                 my $v;
  93
  94                                 if ( ::T ~~ canonicalized ) {
  95                                     $u = ::T.canonicalized.($x);
  96                                     $v = ::T.canonicalized.($y);
  97                                 }
  98                                 else {
  99                                     $u := $x;
 100                                     $v := $y;
 101                                 }
 102
 103                                 last if $value = $u cmp $v;
 104                             }
 105
 106                             $value;
 107                         }
 108
 109                         if ( $sig ~~ descending ) {
 110                             $cmpr = -> $a, $b { $cmpr($b, $a) };
 111                         }
 112
 113                         take( -> $a, $b {
 114                             $cmpr(kex($sig, $a), kex($sig, $b))
 115                             });
 116                     }
 117
 118                     when KeyExtractor {
 119                         my KeyExtractor $ex := $criterion;
 120                         my &kex             := &keyex;
 121
 122                         my $cmpr = &cmp;
 123
 124                         if ( $ex ~~ canonicalized ) {
 125                             $cmpr = -> $a is copy, $b is copy {
 126                                 $a = $ex.canonicalized.($a);
 127                                 $b = $ex.canonicalized.($b);
 128                                 $cmpr($a, $b)
 129                                 };
 130                         }
 131
 132                         if ( $ex ~~ descending ) {
 133                             $cmpr = -> $a, $b { $cmpr($b, $a) };
 134                         }
 135
 136                         take( -> $a, $b { $cmpr(kex($ex, $a), kex($ex, $b)) } );
 137                     }
 138
 139                     when Comparator {
 140                         my Comparator $cmpr = $criterion;
 141
 142                         if ( $criterion ~~ insensitive ) {
 143                             $cmpr = -> $a, $b {
 144                                 $a = $criterion.canonicalized.($a);
 145                                 $b = $criterion.canonicalized.($b);
 146                                 $cmpr($a, $b)
 147                                 };
 148                         }
 149
 150                         if ( $criterion ~~ descending ) {
 151                             $cmpr = -> $a, $b { $cmpr($b, $a) };
 152                         }
 153
 154                         take($cmpr);
 155                     }
 156
 157                     when Pair {
 158                         my OrderingPair $scp := $criterion;
 159                         my &kex              := &keyex;
 160
 161                         my KeyExtractor $ex = $scp.key;
 162                         my Comparator $cmpr = $scp.value;
 163
 164                         if ( $pair ~~ canonicalized ) {
 165                             $cmpr = -> $a, $b {
 166                                 $a = $pair.canonicalized.($a);
 167                                 $b = $pair.canonicalized.($b);
 168                                 $cmpr($a, $b)
 169                                 };
 170                         }
 171
 172                         if ( $pair ~~ descending ) {
 173                             $cmpr = -> $a, $b { $cmpr($b, $a) };
 174                         }
 175
 176                         take( -> $a, $b { $cmpr(kex($ex, $a), kex($ex, $b)) } );
 177                     }
 178                 }
 179             }
 180         }
 181
 182         # mergesort() --
 183         #   O(N*log(N)) time
 184         #   O(N*log(N)) space
 185         #   stable
 186
 187         our Array
 188         sub mergesort (@values is rw, Ordering @by? = list(&infix:<cmp>),
 189             Bit $inplace?)
 190         {
 191             my @result;
 192
 193             my @qby = qualify_by(@by);
 194
 195             if $inplace {
 196                 inplace_mergesort(@values, 0 => +@values, @qby);
 197                 @result := @values;
 198             }
 199             else {
 200                 my @copy = @values;
 201                 inplace_mergesort(@copy, 0 => +@copy, @qby);
 202                 @result := @copy;
 203             }
 204
 205             @result;
 206         }
 207
 208         our Pair
 209         sub inplace_mergesort (@values is rw, Pair $span, Code @qby)
 210         {
 211             my $result = $span;
 212
 213             unless ( $span.value - $span.key == 1 || in_order(@qby, @values) ) {
 214                 my $mid = $span.key + int( ($span.value - $span.key)/ 2 );
 215
 216                 $result = merge(
 217                     @values,
 218                     inplace_mergesort(@values, $span.key => $mid, @qby),
 219                     inplace_mergesort(@values, $mid => $span.value, @qby),
 220                     @qby
 221                 );
 222             }
 223
 224             $result;
 225         }
 226
 227         our Pair
 228         sub merge (@values is rw, Pair $lspan, Pair $rspan, Code @qby)
 229         {
 230             # copy @left to a scratch area
 231             my @scratch = @values[$lspan.key ..^ $lspan.value];
 232
 233             # merge @scratch and @right into and until @left is full
 234             my $lc = $lspan.key;
 235             my $rc = $rspan.key;
 236             my $sc = 0;
 237
 238             while ( $lc < $lspan.value ) {
 239                 @values[$lc++] = by_cmp(@qby, @scratch[$sc], @values[$rc]) <= 0
 240                     ?? @scratch[$sc++]
 241                     !! @values[$rc++];
 242             }
 243
 244             # at this point @left is full.  start populating @right
 245             # until @scratch or @right is empty
 246             my $ri = $rspan.key;
 247
 248             while ( $sc < +@scratch && $rc < $rspan.value ) {
 249                 @values[$ri++] = by_cmp(@qby, @scratch[$sc], @values[$rc]) <= 0
 250                     ?? @scratch[$sc++]
 251                     !! @values[$rc++];
 252             }
 253
 254             # anything remaining in @right is in the correct place.
 255             # anything remaining in @scratch needs to be filled into @right
 256                 @values[$ri..^$rspan.value] = @scratch[$sc..^+@scratch];
 257
 258             # return the merged span
 259             $lspan.key => $rspan.value;
 260         }
 261     }
 262
 263     our Array multi Array::p6sort( @values is rw, *&by, Bit $inplace? )
 264     {
 265         Prelude::Sort::mergesort(@values, list(&by), $inplace);
 266     }
 267
 268     our Array multi Array::p6sort( @values is rw, Ordering @by, Bit $inplace? )
 269     {
 270         Prelude::Sort::mergesort(@values, @by, $inplace);
 271     }
 272
 273     our Array multi Array::p6sort( @values is rw, Ordering $by = &infix:<cmp>,
 274         Bit $inplace? )
 275     {
 276         Array::sort(@values, $by, $inplace);
 277     }
 278
 279     our List multi List::p6sort( Ordering @by, *@values )
 280     {
 281         my @result = Prelude::Sort::mergesort(@values, @by);
 282         @result[];
 283     }
 284
 285     our List multi List::p6sort( Ordering $by = &infix:<cmp>, *@values )
 286     {
 287         my @result = Prelude::Sort::mergesort(@values, list($by));
 288         @result[];
 289     }
 290 END_PRELUDE_SORT
 291
 292 ok(eval($prelude_sort), 'prelude sort parses', :todo<sort>,
 293     :depends<subset and argument list return signatures>);
 294
 295 ## tests
 296
 297 ## sample() -- return a random sample of the input
 298 sub sample (:$count, :$resample, *@data)
 299 {
 300     my $max = $count ?? $count !! +@data;
 301
 302     return gather {
 303         if ! ( $resample ) {
 304             my @copy = @data;
 305
 306             loop (my $i = 0; $i < $max; ++$i ) {
 307                 take  @copy.splice((1..+@copy).pick, 1);
 308             }
 309         }
 310         else {
 311             loop (my $i = 0; $i < $max; ++$i ) {
 312                 take  @data[(1..+@data).pick];
 313             }
 314         }
 315     }
 316 }
 317
 318 my @num = sample   1..26;
 319 my @str = sample 'a'..'z';
 320 my @num_as_str = sample( '' >>~<< @num);
 321
 322 my @sorted_num =   1..26;
 323 my @sorted_str = 'a'..'z';
 324 my @sorted_num_as_str =
 325     <1 10 11 12 13 14 15 16 17 18 19 2 20 21 22 23 24 25 26 3 4 5 6 7 8 9>;
 326
 327 class Thingy {
 328     has $.name;
 329 }
 330
 331 my @sorted_things = map { Thingy.new( :name($_) ) },
 332     ( reverse('N'..'Z'), reverse('a'..'m') );
 333
 334 my @unsorted_things = sample(@sorted_things);
 335
 336 {
 337     my @sorted;
 338
 339     ok(eval('@sorted = p6sort @str;'), 'parse of p6sort',
 340         :todo<feature>);
 341
 342     ok(@sorted eqv @sorted_str, 'string ascending; default cmp',
 343         :todo, :depends<p6sort>);
 344 }
 345
 346 {
 347     my @sorted;
 348
 349     ok(eval('@sorted = p6sort { $^a <=> $^b }, @num;'), 'parse of p6sort',
 350         :todo<feature>);
 351
 352     ok(@sorted eqv @sorted_num, 'number ascending; Comparator',
 353         :todo, :depends<p6sort>);
 354 }
 355
 356 {
 357     my @sorted;
 358
 359     ok(eval('@sorted = p6sort { lc $^b.name cmp lc $^a.name }, @unsorted_things;'),
 360         'parse of p6sort', :todo<feature>);
 361
 362     ok(@sorted eqv reverse(@sorted_things), 'string descending; Comparator',
 363         :todo, :depends<p6sort>);
 364 }
 365
 366 {
 367     my @sorted;
 368
 369     ok(eval('@sorted = p6sort { $^b.name cmp $^a.name } is insensitive, @str;'),
 370         'parse trait on block closure',
 371         :todo<feature>,
 372         :depends<traits on block closures>);
 373
 374
 375     ok(@sorted eqv reverse(@sorted_str),
 376         'string descending; Comparator is insensitive',
 377         :todo, :depends<p6sort>);
 378 }
 379
 380 {
 381     my @sorted;
 382
 383     ok(eval('@sorted = p6sort { $^a.name cmp $^b.name } is descending is insensitive, @str;'),
 384         'parse trait on block closure',
 385         :todo<feature>,
 386         :depends<traits on block closures>);
 387
 388     ok(@sorted eqv reverse(@sorted_str),
 389         'string descending; Comparator is descending is insensitive',
 390         :todo, :depends<p6sort>);
 391 }
 392
 393 # TODO: Modtimewise numerically ascending...
 394 #
 395 # my @files = sample { ... };
 396 # my @sorted_files = qx( ls -t @files[] );
 397
 398 {
 399     # my @sorted = p6sort { $^a.:M <=> $^b.:M }, @files;
 400     #
 401     # ok(@sorted eqv @sorted_files, 'number ascending; Comparator',
 402     #     :todo<sort>);
 403
 404 }
 405
 406 sub fuzzy_cmp($x, $y) returns Int
 407 {
 408     if ( 10 >= $x < 20 && 10 >= $y < 20 ) {
 409         return $y <=> $x;
 410     }
 411
 412     return $x <=> $y;
 413 }
 414
 415 {
 416     my @answer   = 5..9, reverse(10..19), 20..24;
 417     my @unsorted = sample(@answer);
 418
 419     my @sorted;
 420
 421     ok(eval('@sorted = p6sort &fuzzy_cmp, @unsorted;'),
 422         'parse of p6sort', :todo<feature>);
 423
 424     ok(@sorted eqv @answer, 'number fuzzy; Comparator', :todo,
 425         :depends<sort>);
 426 }
 427
 428 {
 429     my @sorted;
 430
 431     ok(eval('@sorted = p6sort { + $^elem }, @num_as_str;'),
 432         'parse of p6sort', :todo<feature>);
 433
 434     ok(@sorted eqv @sorted_num,
 435         'number ascending; KeyExtractor uses context',
 436         :todo, :depends<p6sort>);
 437
 438     ok(eval('@sorted = p6sort { + $_ }, @num_as_str;'),
 439         'parse of p6sort', :todo<feature>);
 440
 441     ok(@sorted eqv @sorted_num,
 442         'number ascending; KeyExtractor uses $_',
 443         :todo, :depends<p6sort>);
 444 }
 445
 446 class Thingy {
 447     has $.name;
 448 }
 449
 450 my @sorted_things = map { Thingy.new( :name($_) ) },
 451     ( reverse('N'..'Z'), reverse('a'..'m') );
 452
 453 my @unsorted_things = sample(@sorted_things);
 454
 455 {
 456     my @sorted;
 457
 458     ok(eval('@sorted = p6sort { ~ $^elem.name } is descending is insensitive, @unsorted_things;'),
 459         'parse trait on block closure',
 460         :todo<feature>,
 461         :depends<traits on block closures>);
 462
 463     ok(@sorted eqv @sorted_things,
 464         'string descending; KeyExtractor is descending is insensitive',
 465         :todo, :depends<p6sort>);
 466
 467     ok(eval('@sorted = p6sort { lc $^elem.name } is descending, @unsorted_things;'),
 468         'parse trait on block closure',
 469         :todo<feature>,
 470         :depends<traits on block closures>);
 471
 472     ok(@sorted eqv @sorted_things,
 473         'string descending; KeyExtractor is descending uses context',
 474         :todo, :depends<p6sort>);
 475
 476     ok(eval('@sorted = p6sort { lc .name } is descending, @unsorted_things;'),
 477         'parse trait on block closure',
 478         :todo<feature>,
 479         :depends<traits on block closures>);
 480
 481     ok(@sorted eqv @sorted_things,
 482         'string descending; KeyExtractor is descending uses dot',
 483         :todo, :depends<p6sort>);
 484 }
 485
 486 {
 487     # my @sorted = p6sort { .:M } @files;
 488     #
 489     # ok(@sorted eqv @sorted_files, 'number ascending; KeyExtractor',
 490     #     :todo<sort>);
 491 }
 492
 493 sub get_key ($elem) { return $elem.name; }
 494
 495 {
 496     my @sorted;
 497
 498     ok(eval('@sorted = p6sort &get_key, @unsorted_things;'),
 499         'parse of p6sort', :todo<feature>);
 500
 501     ok(@sorted eqv @sorted_things,
 502         'string ascending; KeyExtractor via sub',
 503         :todo, :depends<p6sort>);
 504 }
 505
 506 my @numstr           = sample( 1..3, 'A'..'C', 'x'..'z', 10..12 );
 507 my @sorted_di_numstr = list(<z y x>, <C B A>, reverse(1..3, 10..12)),
 508
 509 {
 510     my @sorted;
 511
 512     # Not sure you can have traits on objects but
 513     # L<S29/List/=item sort>
 514     # says that any Ordering can have `descending` and `canonicalized($how)` traits.
 515     ok(eval('@sorted = p6sort ( { $_ } => {
 516         given $^a {
 517             when Num {
 518                 given $^b {
 519                     when Num { $^a <=> $^b }
 520                     default { $^a cmp $^b }
 521                 }
 522             }
 523             default { $^a cmp $^b }
 524         }
 525         }) is descending is canonicalized({$^v ~~ Str ?? lc($v) !! $v}),
 526         @numstr;'),
 527         'parse trait on object',
 528         :todo<feature>,
 529         :depends<traits on objects>);
 530
 531     ok(@sorted eqv @sorted_di_numstr,
 532         'Num|Str fuzzy; Pair is descending is insensitive',
 533         :todo, :depends<p6sort>);
 534
 535     # @sorted = p6sort { $_ ~~ :M } => { $^b cmp $^a }, @files;
 536     #
 537     # ok(@sorted eqv @sorted_modtime_cmp_files,
 538     #     'string descending; Pair uses cmp',
 539     #     :todo<sort>);
 540     #
 541     # @sorted = p6sort { $_ ~~ :M } => &fuzzy_cmp, @files;
 542     #
 543     # ok(@sorted eqv @sorted_modtime_fuzzy_files,
 544     #     'number fuzzy; Pair',
 545     #     :todo<sort>);
 546     #
 547     # @sorted = p6sort ( { $_ ~~ :M } => { $^a cmp $^b } ) is descending, @files;
 548     #
 549     # ok(@sorted eqv @sorted_modtime_cmp_files,
 550     #     'string descending; Pair is descending',
 551     #     :todo<sort>);
 552 }
 553
 554 {
 555     # Need to think about this one to create a meaningful dataset.
 556     #
 557     #   # Numerically ascending
 558     #   # or else namewise stringifically descending case-insensitive
 559     #   # or else modtimewise numerically ascending
 560     #   # or else namewise fuzz-ifically
 561     #   # or else fuzz-ifically...
 562     #   @sorted = p6sort [ {+ $^elem},
 563     #                    {$^b.name cmp $^a.name} is insensitive,
 564     #                    {.TEST(:M)},
 565     #                    {.name}=>&fuzzy_cmp,
 566     #                    &fuzzy_cmp,
 567     #                  ],
 568     #                  @unsorted;
 569     #
 570     #   ok(@sorted eqv @sorted_whacky, 'obj whacky; @by', :todo<sort>);
 571 }
 572
 573 my @inplace = @str;
 574
 575 {
 576     ok(@inplace !eqv @sorted_str, 'sampled data differs from answer');
 577
 578     ok(eval('@inplace.p6sort(:inplace);', 'parse of p6sort with optional $inplace'),
 579         :todo<feature>);
 580
 581     ok(@inplace eqv @sorted_str, 'inplace sort on array', :todo,
 582         :depends<p6sort>);
 583 }