Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Branch: master
Fetching contributors…

Cannot retrieve contributors at this time

584 lines (455 sloc) 16.744 kB
use v6;
use Test;
plan 28;
# This is a perl6 implementation of L<S29/List/"=item sort">
# based on mergesort.
=begin comment
* Existence
* Clarify why this implementation of a spec'ed feature
exists in the "unspecced" directory of the test suite.
* That was where suggested when asked for suggestions
on #perl6. Other suggestions welcome.
* Pugs
* `subset`
* Spec
* any Ordering has traits or only top level?
* {.TEST(:M)} is descending => &fuzzy_cmp is insensitive
* Syntax cleanup
* guidance on making this the builtin sort()
=end comment
# L<S29/"List"/"=item sort">
my $prelude_sort = q:to 'END_PRELUDE_SORT';
subset KeyExtractor of Code where { .sig === :(Any --> Any) };
subset Comparator of Code where { .sig === :(Any, Any --> Int) };
subset OrderingPair
of Pair where { .key ~~ KeyExtractor && .value ~~ Comparator };
subset Ordering
of Signature | KeyExtractor | Comparator | OrderingPair;
module Prelude::Sort {
our Order
sub qby_cmp (Code @qby, $a, $b)
{
my $result = Order::Same;
my &return_ifn0 ::= -> $v { if $v { $result = $v; leave LOOP; } };
LOOP: for @by -> $cmpr {
return_ifn0 $cmpr($a, $b);
}
$result;
}
our bool
sub in_order (Code @qby, *$x, *@xs)
{
my $result = 1;
my $y := $x;
for @xs -> $z {
if by_cmp(@qby, $y, $z) > 0 {
$result = 0;
last;
}
$y := $z;
}
$result;
}
our Array of Code
sub qualify_by (Ordering @by)
{
my Any sub keyex (KeyExtractor $ex, Any $v) is cached
{ $ex($v); }
my Array sub sigkex (Signature $sig is copy, Any $v) is cached
{ $sig := $v; @$sig; }
gather {
for @by -> $criterion {
when Signature {
my Signature $sig := $crierion;
my Array &kex := &sigkex;
my $cmpr -> $a, $b {
my $value;
for zip(@$a; @$b; @$sig) -> $x, $y, ::T {
my $u;
my $v;
if ( ::T ~~ canonicalized ) {
$u = ::T.canonicalized.($x);
$v = ::T.canonicalized.($y);
}
else {
$u := $x;
$v := $y;
}
last if $value = $u cmp $v;
}
$value;
}
if ( $sig ~~ descending ) {
$cmpr = -> $a, $b { $cmpr($b, $a) };
}
take( -> $a, $b {
$cmpr(kex($sig, $a), kex($sig, $b))
});
}
when KeyExtractor {
my KeyExtractor $ex := $criterion;
my &kex := &keyex;
my $cmpr = &cmp;
if ( $ex ~~ canonicalized ) {
$cmpr = -> $a is copy, $b is copy {
$a = $ex.canonicalized.($a);
$b = $ex.canonicalized.($b);
$cmpr($a, $b)
};
}
if ( $ex ~~ descending ) {
$cmpr = -> $a, $b { $cmpr($b, $a) };
}
take( -> $a, $b { $cmpr(kex($ex, $a), kex($ex, $b)) } );
}
when Comparator {
my Comparator $cmpr = $criterion;
if ( $criterion ~~ insensitive ) {
$cmpr = -> $a, $b {
$a = $criterion.canonicalized.($a);
$b = $criterion.canonicalized.($b);
$cmpr($a, $b)
};
}
if ( $criterion ~~ descending ) {
$cmpr = -> $a, $b { $cmpr($b, $a) };
}
take($cmpr);
}
when Pair {
my OrderingPair $scp := $criterion;
my &kex := &keyex;
my KeyExtractor $ex = $scp.key;
my Comparator $cmpr = $scp.value;
if ( $pair ~~ canonicalized ) {
$cmpr = -> $a, $b {
$a = $pair.canonicalized.($a);
$b = $pair.canonicalized.($b);
$cmpr($a, $b)
};
}
if ( $pair ~~ descending ) {
$cmpr = -> $a, $b { $cmpr($b, $a) };
}
take( -> $a, $b { $cmpr(kex($ex, $a), kex($ex, $b)) } );
}
}
}
}
# mergesort() --
# O(N*log(N)) time
# O(N*log(N)) space
# stable
our Array
sub mergesort (@values is rw, Ordering @by? = list(&infix:<cmp>),
Bit $inplace?)
{
my @result;
my @qby = qualify_by(@by);
if $inplace {
inplace_mergesort(@values, 0 => +@values, @qby);
@result := @values;
}
else {
my @copy = @values;
inplace_mergesort(@copy, 0 => +@copy, @qby);
@result := @copy;
}
@result;
}
our Pair
sub inplace_mergesort (@values is rw, Pair $span, Code @qby)
{
my $result = $span;
unless ( $span.value - $span.key == 1 || in_order(@qby, @values) ) {
my $mid = $span.key + int( ($span.value - $span.key)/ 2 );
$result = merge(
@values,
inplace_mergesort(@values, $span.key => $mid, @qby),
inplace_mergesort(@values, $mid => $span.value, @qby),
@qby
);
}
$result;
}
our Pair
sub merge (@values is rw, Pair $lspan, Pair $rspan, Code @qby)
{
# copy @left to a scratch area
my @scratch = @values[$lspan.key ..^ $lspan.value];
# merge @scratch and @right into and until @left is full
my $lc = $lspan.key;
my $rc = $rspan.key;
my $sc = 0;
while ( $lc < $lspan.value ) {
@values[$lc++] = by_cmp(@qby, @scratch[$sc], @values[$rc]) <= 0
?? @scratch[$sc++]
!! @values[$rc++];
}
# at this point @left is full. start populating @right
# until @scratch or @right is empty
my $ri = $rspan.key;
while ( $sc < +@scratch && $rc < $rspan.value ) {
@values[$ri++] = by_cmp(@qby, @scratch[$sc], @values[$rc]) <= 0
?? @scratch[$sc++]
!! @values[$rc++];
}
# anything remaining in @right is in the correct place.
# anything remaining in @scratch needs to be filled into @right
@values[$ri..^$rspan.value] = @scratch[$sc..^+@scratch];
# return the merged span
$lspan.key => $rspan.value;
}
}
our Array multi Array::p6sort( @values is rw, *&by, Bit $inplace? )
{
Prelude::Sort::mergesort(@values, list(&by), $inplace);
}
our Array multi Array::p6sort( @values is rw, Ordering @by, Bit $inplace? )
{
Prelude::Sort::mergesort(@values, @by, $inplace);
}
our Array multi Array::p6sort( @values is rw, Ordering $by = &infix:<cmp>,
Bit $inplace? )
{
Array::sort(@values, $by, $inplace);
}
our List multi List::p6sort( Ordering @by, *@values )
{
my @result = Prelude::Sort::mergesort(@values, @by);
@result[];
}
our List multi List::p6sort( Ordering $by = &infix:<cmp>, *@values )
{
my @result = Prelude::Sort::mergesort(@values, list($by));
@result[];
}
END_PRELUDE_SORT
ok(eval($prelude_sort), 'prelude sort parses', :todo<sort>,
:depends<subset and argument list return signatures>);
## tests
## sample() -- return a random sample of the input
sub sample (:$count, :$resample, *@data)
{
my $max = $count ?? $count !! +@data;
return gather {
if ! ( $resample ) {
my @copy = @data;
loop (my $i = 0; $i < $max; ++$i ) {
take @copy.splice((1..+@copy).pick, 1);
}
}
else {
loop (my $i = 0; $i < $max; ++$i ) {
take @data[(1..+@data).pick];
}
}
}
}
my @num = sample 1..26;
my @str = sample 'a'..'z';
my @num_as_str = sample( '' >>~<< @num);
my @sorted_num = 1..26;
my @sorted_str = 'a'..'z';
my @sorted_num_as_str =
<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>;
class Thingy {
has $.name;
}
my @sorted_things = map { Thingy.new( :name($_) ) },
( reverse('N'..'Z'), reverse('a'..'m') );
my @unsorted_things = sample(@sorted_things);
{
my @sorted;
ok(eval('@sorted = p6sort @str;'), 'parse of p6sort',
:todo<feature>);
ok(@sorted eqv @sorted_str, 'string ascending; default cmp',
:todo, :depends<p6sort>);
}
{
my @sorted;
ok(eval('@sorted = p6sort { $^a <=> $^b }, @num;'), 'parse of p6sort',
:todo<feature>);
ok(@sorted eqv @sorted_num, 'number ascending; Comparator',
:todo, :depends<p6sort>);
}
{
my @sorted;
ok(eval('@sorted = p6sort { lc $^b.name cmp lc $^a.name }, @unsorted_things;'),
'parse of p6sort', :todo<feature>);
ok(@sorted eqv reverse(@sorted_things), 'string descending; Comparator',
:todo, :depends<p6sort>);
}
{
my @sorted;
ok(eval('@sorted = p6sort { $^b.name cmp $^a.name } is insensitive, @str;'),
'parse trait on block closure',
:todo<feature>,
:depends<traits on block closures>);
ok(@sorted eqv reverse(@sorted_str),
'string descending; Comparator is insensitive',
:todo, :depends<p6sort>);
}
{
my @sorted;
ok(eval('@sorted = p6sort { $^a.name cmp $^b.name } is descending is insensitive, @str;'),
'parse trait on block closure',
:todo<feature>,
:depends<traits on block closures>);
ok(@sorted eqv reverse(@sorted_str),
'string descending; Comparator is descending is insensitive',
:todo, :depends<p6sort>);
}
# TODO: Modtimewise numerically ascending...
#
# my @files = sample { ... };
# my @sorted_files = qx( ls -t @files[] );
{
# my @sorted = p6sort { $^a.:M <=> $^b.:M }, @files;
#
# ok(@sorted eqv @sorted_files, 'number ascending; Comparator',
# :todo<sort>);
}
sub fuzzy_cmp($x, $y) returns Int
{
if ( 10 >= $x < 20 && 10 >= $y < 20 ) {
return $y <=> $x;
}
return $x <=> $y;
}
{
my @answer = 5..9, reverse(10..19), 20..24;
my @unsorted = sample(@answer);
my @sorted;
ok(eval('@sorted = p6sort &fuzzy_cmp, @unsorted;'),
'parse of p6sort', :todo<feature>);
ok(@sorted eqv @answer, 'number fuzzy; Comparator', :todo,
:depends<sort>);
}
{
my @sorted;
ok(eval('@sorted = p6sort { + $^elem }, @num_as_str;'),
'parse of p6sort', :todo<feature>);
ok(@sorted eqv @sorted_num,
'number ascending; KeyExtractor uses context',
:todo, :depends<p6sort>);
ok(eval('@sorted = p6sort { + $_ }, @num_as_str;'),
'parse of p6sort', :todo<feature>);
ok(@sorted eqv @sorted_num,
'number ascending; KeyExtractor uses $_',
:todo, :depends<p6sort>);
}
class Thingy {
has $.name;
}
my @sorted_things = map { Thingy.new( :name($_) ) },
( reverse('N'..'Z'), reverse('a'..'m') );
my @unsorted_things = sample(@sorted_things);
{
my @sorted;
ok(eval('@sorted = p6sort { ~ $^elem.name } is descending is insensitive, @unsorted_things;'),
'parse trait on block closure',
:todo<feature>,
:depends<traits on block closures>);
ok(@sorted eqv @sorted_things,
'string descending; KeyExtractor is descending is insensitive',
:todo, :depends<p6sort>);
ok(eval('@sorted = p6sort { lc $^elem.name } is descending, @unsorted_things;'),
'parse trait on block closure',
:todo<feature>,
:depends<traits on block closures>);
ok(@sorted eqv @sorted_things,
'string descending; KeyExtractor is descending uses context',
:todo, :depends<p6sort>);
ok(eval('@sorted = p6sort { lc .name } is descending, @unsorted_things;'),
'parse trait on block closure',
:todo<feature>,
:depends<traits on block closures>);
ok(@sorted eqv @sorted_things,
'string descending; KeyExtractor is descending uses dot',
:todo, :depends<p6sort>);
}
{
# my @sorted = p6sort { .:M } @files;
#
# ok(@sorted eqv @sorted_files, 'number ascending; KeyExtractor',
# :todo<sort>);
}
sub get_key ($elem) { return $elem.name; }
{
my @sorted;
ok(eval('@sorted = p6sort &get_key, @unsorted_things;'),
'parse of p6sort', :todo<feature>);
ok(@sorted eqv @sorted_things,
'string ascending; KeyExtractor via sub',
:todo, :depends<p6sort>);
}
my @numstr = sample( 1..3, 'A'..'C', 'x'..'z', 10..12 );
my @sorted_di_numstr = list(<z y x>, <C B A>, reverse(1..3, 10..12)),
{
my @sorted;
# Not sure you can have traits on objects but
# L<S29/List/=item sort>
# says that any Ordering can have `descending` and `canonicalized($how)` traits.
ok(eval('@sorted = p6sort ( { $_ } => {
given $^a {
when Num {
given $^b {
when Num { $^a <=> $^b }
default { $^a cmp $^b }
}
}
default { $^a cmp $^b }
}
}) is descending is canonicalized({$^v ~~ Str ?? lc($v) !! $v}),
@numstr;'),
'parse trait on object',
:todo<feature>,
:depends<traits on objects>);
ok(@sorted eqv @sorted_di_numstr,
'Num|Str fuzzy; Pair is descending is insensitive',
:todo, :depends<p6sort>);
# @sorted = p6sort { $_ ~~ :M } => { $^b cmp $^a }, @files;
#
# ok(@sorted eqv @sorted_modtime_cmp_files,
# 'string descending; Pair uses cmp',
# :todo<sort>);
#
# @sorted = p6sort { $_ ~~ :M } => &fuzzy_cmp, @files;
#
# ok(@sorted eqv @sorted_modtime_fuzzy_files,
# 'number fuzzy; Pair',
# :todo<sort>);
#
# @sorted = p6sort ( { $_ ~~ :M } => { $^a cmp $^b } ) is descending, @files;
#
# ok(@sorted eqv @sorted_modtime_cmp_files,
# 'string descending; Pair is descending',
# :todo<sort>);
}
{
# Need to think about this one to create a meaningful dataset.
#
# # Numerically ascending
# # or else namewise stringifically descending case-insensitive
# # or else modtimewise numerically ascending
# # or else namewise fuzz-ifically
# # or else fuzz-ifically...
# @sorted = p6sort [ {+ $^elem},
# {$^b.name cmp $^a.name} is insensitive,
# {.TEST(:M)},
# {.name}=>&fuzzy_cmp,
# &fuzzy_cmp,
# ],
# @unsorted;
#
# ok(@sorted eqv @sorted_whacky, 'obj whacky; @by', :todo<sort>);
}
my @inplace = @str;
{
ok(@inplace !eqv @sorted_str, 'sampled data differs from answer');
ok(eval('@inplace.p6sort(:inplace);', 'parse of p6sort with optional $inplace'),
:todo<feature>);
ok(@inplace eqv @sorted_str, 'inplace sort on array', :todo,
:depends<p6sort>);
}
Jump to Line
Something went wrong with that request. Please try again.