File Coverage

blib/lib/Algorithm/SetCovering.pm

Criterion	Covered	Total	%
statement	94	100	94.0
branch	21	24	87.5
condition	6	6	100.0
subroutine	10	11	90.9
pod	3	8	37.5
total	134	149	89.9

package Algorithm::SetCovering;

use strict;
use warnings;
use Log::Log4perl qw(:easy);

our $VERSION = '0.05';

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

    my %options = @options;

    die "No value given for mandatory parameter 'columns'"
        unless exists $options{columns};

    my $self = {
        mode     => "greedy",
        @options,
        rows     => [],
        prepared => 0,
        combos   => [],
    };

    bless $self, $class;
}

##############################################
sub add_row {
##############################################
    my($self, @columns) = @_;

    if($self->{columns} != scalar @columns) {
        die "add_row expects $self->{columns} columns" .
            "but received " . scalar @columns . "\n";
    }

    DEBUG "Adding row @columns";

    push @{$self->{rows}}, [@columns];

    $self->{prepared} = 0;
}

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

    return @{$self->{rows}->[$idx]};
}

##############################################
sub min_row_set {
##############################################
    my($self, @columns_to_cover) = @_;

    if($self->{mode} eq "brute_force") {
        return brute_force_run(@_);
    } elsif($self->{mode} eq "greedy") {
        return greedy_run(@_);
    } else {
        die "$self->{mode} not implemented\n";
    }
}

##############################################
sub brute_force_run {
##############################################
    my($self, @columns_to_cover) = @_;

    $self->brute_force_prepare() unless $self->{prepared};

    COMBO:
    for my $combo (@{$self->{combos}}) {

        for(my $idx = 0; $idx < @columns_to_cover; $idx++) {
            # Check if the combo covers it, [0] is a ref
            # to a hash for quick lookups.
            next unless $columns_to_cover[$idx];
            next COMBO unless $combo->[0]->[$idx];
        }
            # We found a minimal set, return all of its elements
            # (which are idx numbers into the @rows array)
        return @{$combo->[1]};
    }

        # Can't find a minimal set
    return ();
}

##############################################
sub brute_force_prepare {
##############################################
# Create data structures for fast lookups
##############################################
    my($self) = @_;

        # Delete old combos;
    $self->{combos} = [];

    my $nrows = scalar @{$self->{rows}};

    # Create all possible permutations of keys.
    # (TODO: To optimize, we should get rid of
    #        keys which are subsets of other
    #        keys)
    # Sort combos ascending by the number of keys
    # they contain, i.e. combos with fewer keys
    # come first.
    my @combos =
        sort { bitcount($a) <=> bitcount($b) }
             (1..2**$nrows-1);

    DEBUG "Combos are: @combos";

    # A bunch of bitmasks to easily determine
    # if a combo contains a certain key or not.
    my @masks = map { 2**$_ } (0..$nrows-1);

    for my $combo (@combos) {
            # The key values of the combo as (1,0,...)
        my @keys    = ();
        my @covered = ();

        for(my $key_idx = 0; $key_idx < @masks; $key_idx++) {
            if($combo & $masks[$key_idx]) {
                # Key combo contains the current key. Iterate
                # over all locks and store in @covered if
                # the current key opens them.
                for(0..$self->{columns}-1) {
                    $covered[$_] ||= $self->{rows}->[$key_idx]->[$_];
                }
                push @keys, $key_idx;
            }
        }

        DEBUG "Combo '@keys' covers '@covered'";

            # Push hash ref and combo fields to 'combos'
            # array
        push @{$self->{combos}}, [\@covered, \@keys];
    }

    $self->{prepared} = 1;
}

##############################################
sub bitcount {
##############################################
# Count the number of '1' bits in a number
##############################################
    my($num) = @_;

    my $count = 0;

    while ($num) {
         $count += ($num & 0x1) ;
         $num >>= 1 ;
    }

    return $count ;
}

##############################################
sub greedy_run {
##############################################
    my($self, @columns_to_cover) = @_;

    my @hashed_rows    = ();
    my %column_hash    = ();
    my @result         = ();

    for(my $i=0; $i<@columns_to_cover; $i++) {
        $column_hash{$i} = 1 if $columns_to_cover[$i];
    }

    for my $row (@{$self->{rows}}) {
        my $rowhash = {};
        for(my $i=0; $i<@columns_to_cover; $i++) {
            $rowhash->{$i}++ if $columns_to_cover[$i] and $row->[$i];
        }
        push @hashed_rows, $rowhash;
        DEBUG("Hash of idx (", join('-', keys %$rowhash), ")");
    }

    my %not_covered = %column_hash;

    do {
            # Get the longest list
        my $max_len  = 0;
        my @max_keys = ();
        my $max_idx  = 0;
        for my $idx (0..$#hashed_rows) {
            my $row = $hashed_rows[$idx];
            my @keys = keys %$row;
            if(scalar @keys > $max_len) {
                @max_keys = @keys;
                $max_len  = scalar @keys;
                $max_idx  = $idx;
            }
        }

        # Return empty solution if rows can't cover columns_to_cover
        return () unless $max_len;

        DEBUG("Removing max_keys: @max_keys");

        delete $not_covered{$_} for @max_keys;
        push @result, $max_idx;

            # Remove max_keys columns from all keys
        foreach my $row (@hashed_rows) {
            delete $row->{$_} for @max_keys;
            DEBUG("Remain (", join('-', keys %$row), ")");
        }

        DEBUG("Not covered: (", join('-', keys %not_covered), ")");

    } while(scalar keys %not_covered);

    return @result;
}

1;

__END__