File Coverage

blib/lib/Set/Partition.pm

Criterion	Covered	Total	%
statement	82	82	100.0
branch	28	28	100.0
condition	7	7	100.0
subroutine	7	7	100.0
pod	3	3	100.0
total	127	127	100.0

# Set::Partition.pm
#
# Copyright (c) 2006 David Landgren
# All rights reserved

package Set::Partition;
use strict;

use vars qw/$VERSION/;
$VERSION = '0.03';

use constant DEBUG => 0; # if you want to see what's going on

=head1 NAME

Set::Partition - Enumerate all arrangements of a set in fixed subsets

=head1 VERSION

This document describes version 0.03 of Set::Partition,
released 2006-10-11.

=head1 SYNOPSIS

  use Set::Partition;

  my $s = Set::Partition->new(
    list      => [qw(a b c d e)],
    partition => [2, 3],
  );
  while (my $p = $s->next) {
    print join( ' ', map { "(@$_)" } @$p ), $/;
  }
  # produces
  (a b) (c d e)
  (a c) (b d e)
  (a d) (b c e)
  (a e) (b c d)
  (b c) (a d e)
  (b d) (a c e)
  (b e) (a c d)
  (c d) (a b e)
  (c e) (a b d)
  (d e) (a b c)

  # or with a hash
  my $s = Set::Partition->new(
    list      => { b => 'bat', c => 'cat', d => 'dog' },
    partition => [2, 1],
  );
  while (my $p = $s->next) {
    ...
  }

=head1 DESCRIPTION

C takes a list or hash of elements  and a list
numbers that represent the sizes of the partitions into which the
list of elements should be arranged.

The resulting object can then be used as an iterator which returns
a reference to an array of lists, that represents the original list
arranged according to the given partitioning. All possible arrangements
are returned, and the object returns C when the entire
combination space has been exhausted.

=head1 METHODS

=over 8

=item new

Creates a new C object. A set of key/value parameters
can be supplied to control the finer details of the object's
behaviour.

B, the list of elements in the set.

B, the list of integers representing the size of the
partitions used to arrange the set. The sum should be equal to the
number of elements given by B. If it less than the number of
elements, a dummy partition will be added to equalise the count.
This partition will be returned during iteration. If the sum is
greater than the number of elements, C will C with a
fatal error.

=cut

sub new {
    my $class = shift;
    my %args = @_;
    my $part = $args{partition} || [];
    my $in   = $args{list};
    my $list;
    my $val;
    if ($in) {
        if (ref($in) eq 'HASH') {
            $list = [keys %$in];
            $val  = [values %$in];
        }
        else {
            $list = $in;
        }
    }
    else {
        $list = [];
    }
    my $sum  = 0;
    $sum += $_ for @$part;
    if ($sum > @$list) {
        my $list_nr = @$list;
        require Carp;
        Carp::croak("sum of partitions ($sum) exceeds available elements ($list_nr)\n");
    }
    elsif ($sum < @$list) {
        push @$part, @$list - $sum;
    }

    bless {
        list => $list,
        val  => $val,
        part => $args{partition},
        num  => [0..$#$list],
    },
    $class;
}

=item next

Returns the next arrangement of subsets, or C when all arrangements
have been enumerated.

=cut

sub next {
    my $self  = shift;
    my $list  = $self->{list};
    my $state = $self->{state};
    if ($state) {
        return unless $self->_bump();
    }
    else {
        my $s = 0;
        push @$state, ($s++) x $_ for @{$self->{part}};
        $state ||= [(0) x (@$list)] if @$list; # if no partition was given
        $self->{state} = $state;
    }
    my $out;
    if ($self->{val}) {
        $out->[$state->[$_]]{$list->[$_]} = $self->{val}[$_] for @{$self->{num}};
    }
    else {
        push @{$out->[$state->[$_]]}, $list->[$_] for @{$self->{num}};
    }
    DEBUG and print "@{$self->{state}}\n";
    return $out;
}

sub _bump {
    my $self = shift;
    my $in   = $self->{state};
    my $end  = $#$in;
    my $off  = $end-1;
    my $inc  = 0;
    while ($off >= 0) {
        my $sib = $off+1;
        ++$inc if $in->[$off] > $in->[$sib];
        if ($in->[$off] < $in->[$sib]) {
            if ($in->[$sib] > 1+$in->[$off]) {
                # find smallest in [$sib..$end] > $in->[$off];
                my $next = @$in;
                while (--$next) {
                    last if $in->[$next] > $in->[$off];
                }
                (@{$in}[$off, $next]) = (@{$in}[$next, $off]);
                if (DEBUG) {
                    print "@$in (reverse @{$in}[$sib..$end] needed)\n"
                        if $sib < $end;
                }
                @{$in}[$sib..$end] = reverse @{$in}[$sib..$end]
                    if $sib < $end;
            }
            else {
                # just have to flip the current and next
                DEBUG and print +(' ' x ($off*2)) . "^ ^\n";
                (@{$in}[$off, $sib]) = (@{$in}[$sib, $off]);
                if (DEBUG) {
                    print "@$in (sort @{$in}[$sib..$end] needed d=$inc)\n"
                        if $sib < $end and $inc;
                }
                # have to sort
                @{$in}[$sib..$end] = sort {$a <=> $b} @{$in}[$sib..$end]
                    if $sib < $end and $inc;
            }
            return 1;
        }
        --$off;
    }
    return 0;
}

=item reset

Resets the object, which causes it to enumerate the arrangements from the
beginning.

  $p->reset; # begin again

=cut

sub reset {
    my $self  = shift;
    delete $self->{state};
    return $self;
}

=back

=head1 DIAGNOSTICS

=head2 sum of partitions (%d) exceeds available elements (%d)

A list of partition sizes (for instance, 2, 3, 4) was given, along
with a list to partition (for instance, containing 8 elements),
however, the number of elements required to fill the different
partitions (9) exceeds the number available in the source list (8).

=head1 NOTES

The order within a set is unimportant, thus, if

  (a b) (c d)

is produced, then the following arrangement will never be encountered:

  (a b) (d c)

On the other hand, the order of the sets is important, which means
that the following arrangement I be encountered:

  (c d) (a b)

=head1 SEE ALSO

=over 8

=item L

Permutations, combinations, derangements and more; all you need
for your set transformations.

=back

=head1 BUGS

Using a partition of length 0 is valid, although you get back an C,
rather than an empty array. This could be construed as a bug.

Please report all bugs at
L

Make sure you include the output from the following two commands:

  perl -MSet::Partition -le 'print Set::Partition::VERSION'
  perl -V

=head1 ACKNOWLEDGEMENTS

Ken Williams suggested the possibility to use a hash as a source
for partitioning.

=head1 AUTHOR

David Landgren, copyright (C) 2006. All rights reserved.

http://www.landgren.net/perl/

If you (find a) use this module, I'd love to hear about it. If you
want to be informed of updates, send me a note. You know my first
name, you know my domain. Can you guess my e-mail address?

=head1 LICENSE

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut

'The Lusty Decadent Delights of Imperial Pompeii';
__END__