List::EvenMoreUtils - Array manipulation functions

 List::EvenMoreUtils - Array manipulation functions

 use List::EvenMoreUtils qw(partial_ordering_differs);
 use List::EvenMoreUtils qw(list_difference_position);
 use List::EvenMoreUtils qw(keys_to_regex);
 use List::EvenMoreUtils qw(list_to_text);
 use List::EvenMoreUtils qw(initial_sublist_match);
 use List::EvenMoreUtils qw(longer_list);
 use List::EvenMoreUtils qw(repeatable_list_shuffler);

 $difference = partial_ordering_differs( 
	name_of_list1 => \@list1, 
	name_of_list2 => \@list2,
 )




 $diffpos = list_difference_position(@list1, @list2);

 $regex = keys_to_regex(%hash);

 printf "We gave apples to %s.\n", list_to_text(@people);

 print "unequal\n" if initial_sublist_match(@list1, @list2);

 $longer = longer_list(@list1, @list2);

 @urls = (qw(
	http://foo.com/ 
	http://foo.com/xy/
	http://bar.com/xy/
 ));
 do_sublist(
	sub {
		m{^http://([^/]+)};
		return $1;
	},
	sub {
		my $u = $_[0];
		$u =~ m{^(http://([^/]+))};
		print "paths for $2 = ".join(" ", map { substr($_, length($1)) } @_)."\n";
	},
	@urls
 )

 %x = (
	Hope => 1,
	April => 7,
	Jane => 8,
 );
 my $re = keys_to_regex(%hash);
 print "match\n" if $name =~ /^$re$/;

 print list_to_text("Jane", "Ellen");

 Jane and Ellen

 Item 'Fred' in list1 needs to come after 'Jane' since it does so in list2.

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__