File Coverage

blib/lib/List/EvenMoreUtils.pm

Criterion	Covered	Total	%
statement	65	95	68.4
branch	12	40	30.0
condition	1	4	25.0
subroutine	7	12	58.3
pod	7	8	87.5
total	92	159	57.8

package List::EvenMoreUtils;

use strict;
use warnings;
require Exporter;
use Carp qw(confess);

our @ISA = qw(Exporter);
our @EXPORT = ();
our @EXPORT_OK = qw(
	do_sublist
	keys_to_regex
	list_to_text
	partial_ordering_differs
	list_difference_position
	initial_sublist_match
	longer_list
	repeatable_list_shuffler
);

our $VERSION = 0.11;

sub do_sublist(&&@)
{
	my $selector = shift;
	my $actor = shift;

	my @order;
	my %buckets;

	for (@_) {
		my $bucket = &$selector;
		if ($buckets{$bucket}) {
			push(@{$buckets{$bucket}}, $_);
		} else {
			push(@order, $bucket);
			$buckets{$bucket} = [ $_ ];
		}
	}
	my @ret;
	for my $sublist (@buckets{@order}) {
		push(@ret, $actor->(@$sublist));
	}
	return @ret;
}

sub keys_to_regex
{
	my (%hash) = @_;
	my $s = join('|', map { "\Q$_\E" } sort keys %hash);
	return qr/(?:$s)/;
}

sub list_to_text
{
	my ($last, @rest) = reverse @_;
	return $last unless @rest;
	return join(", ", reverse @rest) . " and " . $last;
}

#
# name = \@list
#
sub partial_ordering_differs
{
	my (%lists) = @_;

	my %positions;
	for my $list (keys %lists) {
		my $c = 1;
		$positions{$list} = { map { $_ => $c++ } @{$lists{$list}} };
	}

	my %done;
	for my $one (keys %lists) {
		for my $two (keys %lists) {
			next if $done{$one}{$two}++;
			next if $done{$two}{$one}++;

			my @common = grep { exists $positions{$two}{$_} } @{$lists{$one}};

			next unless @common;

			my @onekeys = sort { $positions{$one}{$a} <=> $positions{$one}{$b} } @common;
			my @twokeys = sort { $positions{$two}{$a} <=> $positions{$two}{$b} } @common;

			my $after;
			while (@onekeys) {
				next if $onekeys[0] eq $twokeys[0];
				if ($after) {
					return "Item '$onekeys[0]' in $one needs to come after '$after' since it does so in $two";
				} else {
					return "Item '$onekeys[0]' in $one needs to come before '$onekeys[1]' since it does so in $two";
				}
			} continue {
				$after = shift @onekeys;
				shift @twokeys;
			}
		}
	}
	return undef;
}

#
# A return value of 1 means the first elements are
# different.
#

sub list_difference_position(\@\@)
{
	my ($a, $b, $start) = @_;
	$start ||= 0;
	for my $i ($start..$#$a) {
		if (defined($a->[$i])) {
			return $i+1 unless defined $b->[$i];
			return $i+1 unless $a->[$i] eq $b->[$i];
		} else {
			return $i+1 if defined $b->[$i];
		}
	}
	if ($#$a < $#$b) {
		return $#$a+2;
	} elsif ($#$b < $#$a) {
		return $#$b+2;
	} else {
		return undef;
	}
}

sub initial_sublist_match(\@\@)
{
	my ($a, $b) = @_;
	for my $i (0..$#$a) {
		return 1 if $i > $#$b;
		if (defined($a->[$i])) {
			return 0 unless defined $b->[$i];
			return 0 unless $a->[$i] eq $b->[$i];
		} else {
			return 0 if defined $b->[$i];
		}
	}
	return 1;
}

sub longer_list(\@\@)
{
	my ($a, $b) = @_;
	return $a if $#$a > $#$b;
	return $b;
}


#
# Determanistic pseudo-random list shuffler
#
sub repeatable_list_shuffler
{
	my ($seed) = @_;
	my $previous = 0;
	require String::CRC;
	return sub {
		my (@list) = @_;
		my %ret;
		for my $l (@list) {
			$previous++;
			my $pos = String::CRC::crc($previous.($l || '').$seed, 32);
			redo if exists $ret{$pos};
			$ret{$pos} = $l;
		}
		return map { $ret{$_} } sort { $a <=> $b } keys %ret;
	};
}


1;

__END__