File Coverage

blib/lib/Algorithm/Bucketizer.pm

Criterion	Covered	Total	%
statement	108	124	87.1
branch	25	38	65.7
condition	13	15	86.6
subroutine	17	21	80.9
pod	0	9	0.0
total	163	207	78.7

##################################################
package Algorithm::Bucketizer;
##################################################
# Documentation attached as POD below
##################################################

use 5.006;
use strict;
use warnings;

our $VERSION = '0.13';

##################################################
sub new {
##################################################
    my($class, @options) = @_;

    my $self = {     # Overwritable parameters
                 bucketsize      => 100,
                 algorithm       => "simple",
                 add_buckets     => 1,

                 @options,

                     # Internal stuff

                   # index (0-..) of bucket we're currently
                   # inserting items into
                 cur_bucket_idx  => 0,

                 buckets         => [],
               };

    bless $self, $class;
}

##################################################
sub add_item {
##################################################
    my($self, $item, $size) = @_;

      # in 'simple' mode, we continue with the bucket we
      # inserted the last item into
    my $first = $self->{cur_bucket_idx};

      # retry tries all buckets
    $first = 0 if $self->{algorithm} eq 'retry';

        # Check if it fits in any existing bucket.
    for(my $idx = $first; exists $self->{buckets}->[$idx]; $idx++) {

        my $bucket = $self->{buckets}->[$idx];

        if($bucket->probe_item($item, $size)) {
            $bucket->add_item($item, $size);
            $self->{ cur_bucket_idx } = $idx;
            return $bucket;
        }
    }

        # It didn't fit anywhere. Create a new bucket.
    return undef unless $self->{add_buckets};
    my $bucket = $self->add_bucket();

    if($bucket->probe_item($item, $size)) {
        $bucket->add_item($item, $size);
        $self->{ cur_bucket_idx } = $bucket->{ idx };
        return $bucket;
    }

    # It didn't even fit in a new bucket. Forget it.
    return undef;
}

##################################################
sub current_bucket_idx {
##################################################
    my($self, $idx ) = @_;

    if( defined $idx ) {
        $self->{ cur_bucket_idx } = $idx;
    }

    return $self->{ cur_bucket_idx };
}

###########################################
sub add_bucket {
###########################################
    my($self, @options) = @_;

    my $bucket = Algorithm::Bucketizer::Bucket->new(
        maxsize => $self->{bucketsize},
        idx     => $#{ $self->{ buckets } } + 1,
        @options,
    );

      # adding a bucket won't increase the current bucket index,
      # just append it to the end of the chain
    push @{$self->{buckets}}, $bucket;

    return $bucket;
}

##################################################
sub buckets {
##################################################
    my($self) = @_;

    return @{$self->{buckets}};
}

##################################################
sub prefill_bucket {
##################################################
    my($self, $bucket_idx, $item, $size) = @_;

    my $bucket = $self->{buckets}->[$bucket_idx];

        # Create the bucket if it doesn't exist yet
    if(!exists $self->{buckets}->[$bucket_idx]) {
        $bucket = Algorithm::Bucketizer::Bucket->new(
            maxsize => $self->{bucketsize},
            idx     => $bucket_idx,
        );
        $self->{buckets}->[$bucket_idx] = $bucket;
        $self->{cur_bucket_idx}  = $bucket_idx;
    }

    $bucket->add_item($item, $size);
    return $bucket;
}

##################################################
sub optimize {
##################################################
    my($self, %options) = @_;

    $options{algorithm} = "random" unless defined $options{algorithm};
    $options{maxtime}   = 3 if exists $options{maxtime} and
                                       $options{maxtime} < 3;
    my($next);

    my @items = $self->items();

        # Create next() closure for appropriate variation algorithm
    if($options{algorithm} eq "brute_force") {
        require Algorithm::Permute;
        my $p = Algorithm::Permute->new([@items]);
        $next = sub { return $p->next };
    } elsif($options{algorithm} eq "random") {
        # fisher-yates shuffle
        $next = sub { $self->shuffle(@items) };
        die "Need maxrounds|maxtime for 'random' optimizer"
            if !exists $options{maxrounds} and !exists $options{maxtime};
    }

    my $round = 0;

    my $minbuckets;
    my @minitems;
    my $start_time = time();

        # Run through different setups and determine the one
        # requiring a minimum of buckets.
    while (my @res = $next->()) {

       my $b = Algorithm::Bucketizer->new(bucketsize => $self->{bucketsize},
                                          algorithm  => 'retry');
       for (@res) {
           my($name, $weight) = @$_;
           $b->add_item($name, $weight);
       }

       my $nof_buckets = scalar $b->buckets;

       if(! defined $minbuckets or $nof_buckets < $minbuckets) {
           $minbuckets = $nof_buckets;
           @minitems = @res;
       }

       ++$round;
       last if exists $options{maxrounds} and $round >= $options{maxrounds};
       last if exists $options{maxtime} and
           time() > $start_time + $options{maxtime};
    }

    # We should have a ideal distribution now, nuke all buckets and refill
    $self->{buckets}         = [];
    $self->{cur_bucket_idx}  = 0;
    $self->{algorithm}       = "retry"; # We're optimizing

    for (@minitems) {
        my($name, $weight) = @$_;
        $self->add_item($name, $weight);
    }
}

##################################################
sub items {
##################################################
    my($self) = @_;

    my @items = ();

    for my $bucket (@{$self->{buckets}}) {
        for(my $idx = 0; exists $bucket->{items}->[$idx]; $idx++) {
            push @items, [$bucket->{items}->[$idx], $bucket->{sizes}->[$idx]];
        }
    }

    return @items;
}

###########################################
sub shuffle {
###########################################
    my($self, @array) = @_;

    for(my $i=@array; --$i; ) {
        my $j = int rand ($i+1);
        next if $i == $j;
        @array[$i,$j] = @array[$j,$i];
    }

    return @array;
}

##################################################
package Algorithm::Bucketizer::Bucket;
##################################################

##################################################
sub new {
##################################################
    my($class, @options) = @_;

    my $self = { size      => 0,
                 items     => [],
                 sizes     => [],
                 maxsize   => undef,
                 maxitems  => undef,
                 idx       => 0,
                 @options,
               };

    bless $self, $class;
}

##################################################
sub serial {
##################################################
    my($self) = @_;

    return ($self->{idx} + 1);
}

##################################################
sub level {
##################################################
    my($self) = @_;

    return ($self->{size});
}

##################################################
sub idx {
##################################################
    my($self) = @_;

    return ($self->{idx});
}

##################################################
sub add_item {
##################################################
    my($self, $item, $size) = @_;

        # Does item fit in container?
    if($self->probe_item($item, $size)) {
            # Add it
        push @{$self->{items}}, $item;
        push @{$self->{sizes}}, $size;
        $self->{size} += $size;
        return 1;
    }

    return undef;
}

##################################################
sub probe_item {
##################################################
    my($self, $item, $size) = @_;

        # Does item fit in container?
    if($self->{maxitems}) {
        if(scalar $self->{items} >= $self->{maxitems}) {
            return 0;
        }
    }

    if($self->{size} + $size <= $self->{maxsize}) {
        return 1;
    } else {
        return 0;
    }
}

##################################################
sub items {
##################################################
    my($self) = @_;

    return @{$self->{items}};
}

1;

__END__