view release on metacpan or  search on metacpan

SetCovering.pm  view on Meta::CPAN

            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__

=head1 NAME

Algorithm::SetCovering - Algorithms to solve the "set covering problem"

=head1 SYNOPSIS

    use Algorithm::SetCovering;

    my $alg = Algorithm::SetCovering->new(
        columns => 4,
        mode    => "greedy");

    $alg->add_row(1, 0, 1, 0);
    $alg->add_row(1, 1, 0, 0);
    $alg->add_row(1, 1, 1, 0);
    $alg->add_row(0, 1, 0, 1);
    $alg->add_row(0, 0, 1, 1);

    my @to_be_opened = (@ARGV || (1, 1, 1, 1));
    
    my @set = $alg->min_row_set(@to_be_opened);
    
    print "To open (@to_be_opened), we need ",
          scalar @set, " keys:\n";

    for(@set) {
        print "$_: ", join('-', $alg->row($_)), "\n";
    }

=head1 DESCRIPTION

Consider having M keys and N locks. Every key opens one or more locks:

         | lock1 lock2 lock3 lock4
    -----+------------------------
    key1 |   x           x
    key2 |   x     x
    key3 |   x     x     x
    key4 |         x           x
    key5 |               x     x

Given an arbitrary set of locks you have to open (e.g. 2,3,4), 
the task is to find a minimal set of keys to accomplish this.
In the example above, the set [key4, key5] fulfils that condition.

The underlying problem is called "set covering problem" and
the corresponding decision problem is NP-complete.

=head2 Methods

=over 4