File Coverage

blib/lib/Algorithm/Kuhn/Munkres.pm

Criterion	Covered	Total	%
statement	94	94	100.0
branch	21	24	87.5
condition	6	6	100.0
subroutine	12	12	100.0
pod	2	2	100.0
total	135	138	97.8

package Algorithm::Kuhn::Munkres;

use warnings;
use strict;
use Carp;
use List::Util qw( sum );
use base 'Exporter';
our @EXPORT_OK = qw( max_weight_perfect_matching assign );
our $VERSION = '1.0.7';

my @weights;
my $N;
my %S;
my %T;
my @labels_u;
my @labels_v;
my @min_slack;
my %matching_u;
my %matching_v;


sub _improve_labels {
    my ($val) = @_;

    foreach my $u (keys %S) {
        $labels_u[$u] -= $val;
    }

    for (my $v = 0; $v < $N; $v++) {
        if (exists($T{$v})) {
            $labels_v[$v] += $val;
        } else {
            $min_slack[$v]->[0] -= $val;
        }
    }
}

sub _improve_matching {
    my ($v) = @_;
    my $u = $T{$v};
    if (exists($matching_u{$u})) {
        _improve_matching($matching_u{$u});
    }
    $matching_u{$u} = $v;
    $matching_v{$v} = $u;
}

sub _slack {
    my ($u,$v) = @_;
    my $val = $labels_u[$u] + $labels_v[$v] - $weights[$u][$v];
    return $val;
}

sub _augment {

    while (1) {
        my ($val, $u, $v);
        for (my $x = 0; $x < $N; $x++) {
            if (!exists($T{$x})) {
                if (!defined($val) || ($min_slack[$x]->[0] < $val)) {
                    $val = $min_slack[$x]->[0];
                    $u = $min_slack[$x]->[1];
                    $v = $x;
                }
            }
        }
        die "u should be in S" if (!exists($S{$u}));
        if ($val > 0) {
            _improve_labels($val);
        }
        die "slack(u,v) should be 0" if (_slack($u,$v) != 0);
        $T{$v} = $u;
        if (exists($matching_v{$v})) {
            my $u1 = $matching_v{$v};
            die "u1 should not be in S" if (exists($S{$u1}));
            $S{$u1} = 1;
            for (my $x = 0; $x < $N; $x++) {
                my $s = _slack($u1,$x);
                if (!exists($T{$x}) && $min_slack[$x]->[0] > $s) {
                    $min_slack[$x] = [$s, $u1];
                }
            }
        } else {
            _improve_matching($v);
            return;
        }
    }

}

sub max_weight_perfect_matching {

    %S = ();
    %T = ();
    @labels_u = ();
    @labels_v = ();
    @min_slack = ();
    %matching_u = ();
    %matching_v = ();

    @weights = @_;
    $N = scalar @weights;
    for (my $i = 0; $i < $N; $i++) {
        $labels_v[$i] = 0;
    }
    for (my $i = 0; $i < $N; $i++) {
        my $max = 0;
        for (my $j = 0; $j < $N; $j++) {
            if ($weights[$i][$j] > $max) {
                $max = $weights[$i][$j];
            }
        }
        $labels_u[$i] = $max;
    }


    while ($N > scalar keys %matching_u) {
        my $free;
        for (my $x = 0; $x < $N; $x++) {
            if (!exists($matching_u{$x})) {
                $free = $x;
                last;
            }
        }

        %S = ($free => 1);
        %T = ();
        @min_slack = ();
        for (my $i = 0; $i < $N; $i++) {
            my $x = [_slack($free,$i), $free];
            push @min_slack, $x;
        }
        _augment();
    }

    my $val = sum(@labels_u) + sum(@labels_v);
    return ($val, \%matching_u);

}

sub assign {
    max_weight_perfect_matching(@_);
}

sub _show_hash {
    my ($hash_ref) = @_;
    my $output = "{";
    foreach my $key (sort keys %$hash_ref) {
        $output .= "$key" . ": " . $hash_ref->{$key} . ", ";
    }
    $output =~ s/, $//;
    $output .= "}";
    return $output;
}

1; # Magic true value required at end of module
__END__