develooper Front page | perl.perl5.porters | Postings from December 2001

Test Suite for stable sort

From:
John P. Linderman
Date:
December 23, 2001 12:06
Subject:
Test Suite for stable sort
Message ID:
200112232006.PAA15925@raptor.research.att.com
There follows a test suite for confirming correctness of a supposedly
stable sort method.  It won't work prior to the availability of
  Test::More  (thanks for the tutorial, Michael!)
but no sort prior to that advertised stability anyway.
It's a rather stringent test, demanding not only that stability
is honored, but also that original contents of the array are
still present (Ken's joke on Jon won't go undetected).

It succeeds, satisfyingly, by default, and with
  -Msort=_quicksort -Msort=stable
and it fails, unsurprisingly, with
  -Msort=_quicksort
once the test sizes escape the domain of simple insertion sort.

It only tests the version of perl that invokes it, not the
combinations of sort options available via -Msort.  This is
partially because it's hard (for me) to set up such a loop,
and mostly because it just seems cleaner to have this chunk
of the test unchanging as options come and go.

I don't know where (or if) this belongs in the overall tests,
beyond it following Test::More and, quite probably, lib/sort,
if it is extended to check -Msort combinations.

-- jpl

===== snip snip snip

BEGIN {
    our $BigWidth  = 6;				# Digits in $BigEnough-1
    our $BigEnough = 10**$BigWidth;		# Largest array we'll attempt
    our $RootWidth = int(($BigWidth+1)/2);	# Digits in sqrt($BigEnough-1)
    our $ItemFormat = "%0${RootWidth}d%0${BigWidth}d";	# Array item format
    our @TestSizes = (0, 1, 2);			# Small special cases
    # Testing all the way up to $BigEnough takes too long
    # for casual testing.  There are some cutoffs (~256)
    # in pp_sort that should be tested, but 10_000 is ample.
    our $WellSoaked = 10_000;			# <= $BigEnough
    for (my $ts = 3; $ts < $WellSoaked; $ts *= 10**(1/3)) {
	push(@TestSizes, int($ts));		# about 3 per decade
    }
}
use Test::More tests => @TestSizes * 2;

# Generate array of specified size for testing sort.
#
# We ensure repeated items, where possible, by drawing the $size items
# from a pool of size sqrt($size).  Each randomly chosen item is
# tagged with the item index, so we can detect original input order,
# and reconstruct the original array order.

sub genarray {
    my $size = int(shift);		# fractions not welcome
    my ($items, $i);
    my @a;

    if    ($size < 0) { $size = 0; }	# avoid complexity with sqrt
    elsif ($size > $BigEnough) { $size = $BigEnough; }
    $#a = $size - 1;			# preallocate array
    $items = int(sqrt($size));		# number of distinct items
    for ($i = 0; $i < $size; ++$i) {
	$a[$i] = sprintf($ItemFormat, int($items * rand()), $i);
    }
    return \@a;
}


# Check for correct order (including stability)

sub checkorder {
    my $aref = shift;
    my $status = '';			# so far, so good
    my $i;

    for ($i = 0; $i < $#$aref; ++$i) {
	next if ($aref->[$i] lt $aref->[$i+1]);
	$status = (substr($aref->[$i], 0, $RootWidth) eq
		   substr($aref->[$i+1], 0, $RootWidth)) ?
		  "instability" : "disorder";
	$status .= " at $i between $aref->[$i] and $aref->[$i+1]";
	last;
    }
    return $status;
}


# Verify that the two array refs reference identical arrays

sub checkequal {
    my ($aref, $bref) = @_;
    my $status = '';
    my $i;

    if (@$aref != @$bref) {
	$status = "Sizes differ: " . @$aref . " vs " . @$bref;
    } else {
	for ($i = 0; $i < @$aref; ++$i) {
	    next if ($aref->[$i] eq $bref->[$i]);
	    $status = "Element $i differs: $aref->[$i] vs $bref->[$i]";
	    last;
	}
    }
    return $status;
}


# Test sort on arrays of various sizes (set up in @TestSizes)

sub main {
    my ($test, $ts);
    my ($unsorted, @sorted, $status);

    $test = 0;
    foreach $ts (@TestSizes) {
	++$test;
	$unsorted = genarray($ts);
	# Sort only on item portion of each element.
	# There will typically be many repeated items,
	# and their order had better be preserved.
	@sorted = sort { substr($a, 0, $RootWidth)
				    cmp
	                 substr($b, 0, $RootWidth) } @$unsorted;
	$status = checkorder(\@sorted);
	# Put the items back into the original order.
	# The contents of the arrays had better be identical.
	is($status, '', "order ok for size $ts");
	@sorted = sort { substr($a, $RootWidth)
				    cmp
	                 substr($b, $RootWidth) } @sorted;
	$status = checkequal(\@sorted, $unsorted);
	is($status, '', "contents ok for size $ts");
    }
}
main();



nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About