File Coverage

blib/lib/Algorithm/Munkres.pm

Criterion	Covered	Total	%
statement	161	162	99.3
branch	50	50	100.0
condition	9	9	100.0
subroutine	18	18	100.0
pod	0	15	0.0
total	238	254	93.7

package Algorithm::Munkres;

use 5.006;
use strict;
use warnings;

require Exporter;

our @ISA = qw(Exporter);

our @EXPORT = qw( assign );

our $VERSION = '0.08';

#Variables global to the package
my @mat = ();
my @mask = ();
my @colcov = ();
my @rowcov = ();
my $Z0_row = 0;
my $Z0_col = 0;
my @path = ();

#The exported subroutine.
#Expected Input: Reference to the input matrix (MxN)
#Output: Mx1 matrix, giving the column number of the value assigned to each row. (For more explaination refer perldoc)
sub assign
{
    #reference to the input matrix
    my $rmat = shift;
    my $rsolution_mat = shift;
    my ($row, $row_len) = (0,0);

    # re-initialize that global variables
    @mat = ();
    @mask = ();
    @colcov = ();
    @rowcov = ();
    $Z0_row = 0;
    $Z0_col = 0;
    @path = ();

    #variables local to the subroutine
    my $step = 0;
    my ($i, $j) = (0,0);

    #the input matrix
    my @inp_mat = @$rmat;

    #copy the orginal matrix, before applying the algorithm to the matrix
    foreach (@inp_mat)
    {
	push @mat, [ @$_ ];
    }

    #check if the input matrix is well-formed i.e. either square or rectangle.
    $row_len = $#{$mat[0]};
    foreach my $row (@mat)
    {
	if($row_len != $#$row)
	{
	    die "Please check the input matrix.\nThe input matrix is not a well-formed matrix!\nThe input matrix has to be rectangular or square matrix.\n";
	}
    }

    #check if the matrix is a square matrix,
    #if not convert it to square matrix by padding zeroes.
    if($#mat < $#{$mat[0]})
    {
	# Add rows
	my $diff = $#{$mat[0]} - $#mat;
	for (1 .. $diff)
	{
	    push @mat, [ (0) x @{$mat[0]} ];
	}
    }
    elsif($#mat > $#{$mat[0]})
    {
	# Add columns
	my $diff = $#mat - $#{$mat[0]};
	for (0 .. $#mat)
	{
	    push @{$mat[$_]}, (0) x $diff;
	}
    }

    #initialize mask, column cover and row cover matrices
    clear_covers();

    for($i=0;$i<=$#mat;$i++)
    {
 	push @mask, [ (0) x @mat ];
    }

    #The algorithm can be grouped in 6 steps.
    &stepone();
    &steptwo();
    $step = &stepthree();
    while($step == 4)
    {
	$step = &stepfour();
	while($step == 6)
	{
	    &stepsix();
	    $step = &stepfour();
	}
	&stepfive();
	$step = &stepthree();
    }

    #create the output matrix
    for my $i (0 .. $#mat)
    {
	for my $j (0 .. $#{$mat[$i]})
	{
	    if($mask[$i][$j] == 1)
	    {
		$rsolution_mat->[$i] = $j;
	    }
	}
    }


#Code for tracing------------------
    <<'ee';
    print "\nInput Matrix:\n";
    for($i=0;$i<=$#mat;$i++)
    {
	for($j=0;$j<=$#mat;$j++)
	{
	    print $mat[$i][$j] . "\t";
	}
	print "\n";
    }

    print "\nMask Matrix:\n";
    for($i=0;$i<=$#mat;$i++)
    {
	for($j=0;$j<=$#mat;$j++)
	{
	    print $mask[$i][$j] . "\t";
	}
	print "\n";
    }

    print "\nOutput Matrix:\n";
    print "$_\n" for @$rsolution_mat;
ee

#----------------------------------

}

#Step 1 - Find minimum value for every row and subtract this min from each element of the row.
sub stepone
{
#    print "Step 1 \n";

    #Find the minimum value for every row
    for my $row (@mat)
    {
	my $min = $row->[0];
	for (@$row)
	{
	    $min = $_ if $min > $_;
	}

        #Subtract the minimum value of the row from each element of the row.
	@$row = map {$_ - $min} @$row;
    }
#    print "Step 1 end \n";
}

#Step 2 - Star the zeroes, Create the mask and cover matrices. Re-initialize the cover matrices for next steps.
#To star a zero: We search for a zero in the matrix and than cover the column and row in which it occurs. Now this zero is starred.
#A next starred zero can occur only in those columns and rows which have not been previously covered by any other starred zero.
sub steptwo
{
#    print "Step 2 \n";

    my ($i, $j) = (0,0);

    for($i=0;$i<=$#mat;$i++)
    {
	for($j=0;$j<=$#{$mat[$i]};$j++)
	{
	    if($mat[$i][$j] == 0 && $colcov[$j] == 0 && $rowcov[$i] == 0)
	    {
		$mask[$i][$j] = 1;
		$colcov[$j] = 1;
		$rowcov[$i] = 1;
	    }
	}
    }
    #Re-initialize the cover matrices
    &clear_covers();
#    print "Step 2 end\n";
}

#Step 3 - Check if each column has a starred zero. If yes then the problem is solved else proceed to step 4
sub stepthree
{
#    print "Step 3 \n";

    my $cnt = 0;

    for my $i (0 .. $#mat)
    {
	for my $j (0 .. $#mat)
	{
	    if($mask[$i][$j] == 1)
	    {
		$colcov[$j] = 1;
		$cnt++;
	    }
	}
    }
    if($cnt > $#mat)
    {
#       print "Step 3 end. Next expected step 7 \n";
       return 7;
    }
    else
    {
#       print "Step 3 end. Next expected step 4 \n";
       return 4;
    }

}

#Step 4 - Try to find a zero which is not starred and whose columns and rows are not yet covered.
#If such a zero found, prime it, try to find a starred zero in its row,
#                                                 if not found proceed to step 5
#                                                 else continue
#Else proceed to step 6.
sub stepfour
{
#    print "Step 4 \n";

    while(1)
    {
	my ($row, $col) = &find_a_zero();
	if ($row < 0)
	{
	    # No zeroes
	    return 6;
	}

	$mask[$row][$col] = 2;
	my $star_col = &find_star_in_row($row);
	if ($star_col >= 0)
	{
	    $col = $star_col;
	    $rowcov[$row] = 1;
	    $colcov[$col] = 0;
	}
	else
	{
	    $Z0_row = $row;
	    $Z0_col = $col;
	    return 5;
	}
    }
}

#Tries to find yet uncovered zero
sub find_a_zero
{
    for my $i (0 .. $#mat)
    {
	next if $rowcov[$i];

	for my $j (reverse(0 .. $#mat))  # Prefer large $j
	{
	    next if $colcov[$j];
	    return ($i, $j) if $mat[$i][$j] == 0;
	}
    }

    return (-1, -1);
}

#Tries to find starred zero in the given row and returns the column number
sub find_star_in_row
{
    my $row = shift;

    for my $j (0 .. $#mat)
    {
	if($mask[$row][$j] == 1)
	{
	    return $j;
	}
    }
    return -1;
}

#Step 5 - Try to find a starred zero in the column of the uncovered zero found in the step 4.
#If starred zero found, try to find a prime zero in its row.
#Continue finding starred zero in the column and primed zero in the row until,
#we get to a primed zero which does not have a starred zero in its column.
#At this point reduce the non-zero values of mask matrix by 1. i.e. change prime zeros to starred zeroes.
#Clear the cover matrices and clear any primes i.e. values=2 from mask matrix.
sub stepfive
{
#    print "Step 5 \n";

    my $cnt = 0;
    my $done = 0;

    $path[$cnt][0] = $Z0_row;
    $path[$cnt][1] = $Z0_col;

    while($done == 0)
    {
	my $row = &find_star_in_col($path[$cnt][1]);
	if($row > -1)
	{
	    $cnt++;
	    $path[$cnt][0] = $row;
	    $path[$cnt][1] = $path[$cnt - 1][1];
	}
	else
	{
	    $done = 1;
	}
	if($done == 0)
	{
	    my $col = &find_prime_in_row($path[$cnt][0]);
	    $cnt++;
	    $path[$cnt][0] = $path[$cnt - 1][0];
	    $path[$cnt][1] = $col;
	}
    }
    &convert_path($cnt);
    &clear_covers();
    &erase_primes();

#    print "Step 5 end \n";
}

#Tries to find starred zero in the given column and returns the row number
sub find_star_in_col
{
    my $col = shift;

    for my $i (0 .. $#mat)
    {
	return $i if $mask[$i][$col] == 1;
    }

    return -1;
}

#Tries to find primed zero in the given row and returns the column number
sub find_prime_in_row
{
    my $row = shift;

    for my $j (0 .. $#mat)
    {
	return $j if $mask[$row][$j] == 2;
    }

    return -1;
}

#Reduces non-zero value in the mask matrix by 1.
#i.e. converts all primes to stars and stars to none.
sub convert_path
{
    my $cnt = shift;

    for my $i (0 .. $cnt)
    {
	for ( $mask[$path[$i][0]][$path[$i][1]] ) {
	    $_ = ( $_ == 1 ) ? 0 : 1;
	}
    }
}

#Clears cover matrices
sub clear_covers
{
    @rowcov = @colcov = (0) x @mat;
}

#Changes all primes i.e. values=2 to 0.
sub erase_primes
{
    for my $row (@mask)
    {
	for my $j (0 .. $#$row)
	{
	    $row->[$j] = 0 if $row->[$j] == 2;
	}
    }
}

#Step 6 - Find the minimum value from the rows and columns which are currently not covered.
#Subtract this minimum value from all the elements of the columns which are not covered.
#Add this minimum value to all the elements of the rows which are covered.
#Proceed to step 4.
sub stepsix
{
#    print "Step 6 \n";
    my ($i, $j);
    my $minval = 0;

    $minval = &find_smallest();

    for($i=0;$i<=$#mat;$i++)
    {
	for($j=0;$j<=$#{$mat[$i]};$j++)
	{
	    if($rowcov[$i] == 1)
	    {
		$mat[$i][$j] += $minval;
	    }
	    if($colcov[$j] == 0)
	    {
		$mat[$i][$j] -= $minval;
	    }
	}
    }

#    print "Step 6 end \n";
}

#Finds the minimum value from all the matrix values which are not covered.
sub find_smallest
{
    my $minval;

    for my $i (0 .. $#mat)
    {
	next if $rowcov[$i];

	for my $j (0 .. $#mat)
	{
	    next if $colcov[$j];
	    if( !defined($minval) || $minval > $mat[$i][$j])
	    {
		$minval = $mat[$i][$j];
	    }
	}
    }
    return $minval;
}


1;
__END__