view release on metacpan or  search on metacpan

lib/Algorithm/Bertsekas.pm  view on Meta::CPAN

	my %objects_with_the_same_values;
	
	my $number_of_assignned_object = scalar keys %assignned_object;	

	if ( $verbose >= 8 )
	{
		print $output "\n Start: Matrix Size N x M: $min_size x $max_size ; epsilon_scaling = $epsilon_scaling ; Number of Global Iterations = $iter_count_global ; Number of Local Iterations = $iter_count_local ; epsilon = $epsilon ; \$number_of_assignned_...
		
		foreach my $person ( sort { $a <=> $b } keys %assignned_person ){
			my $object = $assignned_person{$person};
			printf $output " \$assignned_person{%3s} --> object %3s --> \$price_object{%3s} = $price_object{$object} \n", $person, $object, $object;
		}
		foreach my $object ( sort { $a <=> $b } keys %price_object ){
			printf $output " \$price_object{%3s} = $price_object{$object} \n", $object;
		}
		print $output "\n";
	}
   
	my $seen_ghost;

	for my $person ( 0 .. $max_size - 1 )
	{		
		last if $seen_ghost; # don't need to fill the matrix with zeros, that is, don't need to convert rectangular N x M to square matrix by padding zeroes. Need just one more row: N+1 x M
		
		if ( not defined $assignned_person{$person} )
		{		
			##     ------> j          object 0   object 1   object 2   object 3 ...  object (M - 1)
			##  |  person 0          price_0_0  price_0_1  price_0_2  price_0_3      price_0_j
			##  |  person 1          price_1_0
			##  |  person 2          price_2_0
			##  |  ...
			##  i  person (N - 1)    price_i_0	

			my ( $Opt01ObjForPersonI, $Opt02ObjForPersonI, $Opt03ObjForPersonI );
			my ( $Opt01ValForPersonI, $Opt02ValForPersonI, $Opt03ValForPersonI ) = ( -10 * exp ($max_matrix_value), -10 * exp ($max_matrix_value), -10 * exp ($max_matrix_value) );
			
			my ( $Opt01ObjForPersonI_new_list, $Opt02ObjForPersonI_new_list, $Opt03ObjForPersonI_new_list );
			my ( $Opt01ValForPersonI_new_list, $Opt02ValForPersonI_new_list, $Opt03ValForPersonI_new_list ) = ( -10 * exp ($max_matrix_value), -10 * exp ($max_matrix_value), -10 * exp ($max_matrix_value) );

			my $Opt01ValForPersonI_old_list;
			my $bidForPersonI;
			my %current_value;			
			my @updated_price;			
			
			$seen_ghost++ if ( not defined $matrix[$person] and $min_size < $max_size );						

			# The @objects_with_greater_benefits list are updated dynamically by $objects_desired_by_this{$person} by considering the current price (or current value) of objects.		
			# For each person, the Current Value $current_value{$object} of the most desired objects contained in the @objects_with_greater_benefits list tends to converge to a specific value.
			
			my @objects_with_greater_benefits = keys %{$objects_desired_by_this{$person}}; # sort { $a <=> $b }
			
			# There is at least one object in the @objects_with_greater_benefits list whose price is updated ? use old list : generate new list;
			
			for my $object ( @objects_with_greater_benefits )  # use old list	
			{				
				my $matrix_value = $seen_ghost ? 0 : $matrix[$person]->[$object];
				$current_value{$object} = $matrix_value - $price_object{$object};
				
				push @updated_price, $object if ( $objects_desired_by_this{$person}{$object} == $current_value{$object} );								
				
				if ( $current_value{$object} > $Opt01ValForPersonI ) # search for the best 3 objects
				{
					$Opt03ValForPersonI = $Opt02ValForPersonI;
					$Opt03ObjForPersonI = $Opt02ObjForPersonI;
					$Opt02ValForPersonI = $Opt01ValForPersonI;
					$Opt02ObjForPersonI = $Opt01ObjForPersonI;
					$Opt01ValForPersonI = $current_value{$object};
					$Opt01ObjForPersonI = $object;
					
					$Opt01ValForPersonI_old_list = $Opt01ValForPersonI;
				}
				elsif ( $current_value{$object} > $Opt02ValForPersonI )
				{
					$Opt03ValForPersonI = $Opt02ValForPersonI;
					$Opt03ObjForPersonI = $Opt02ObjForPersonI;
					$Opt02ValForPersonI = $current_value{$object};
					$Opt02ObjForPersonI = $object;
				}
				elsif ( $current_value{$object} > $Opt03ValForPersonI )
				{
					$Opt03ValForPersonI = $current_value{$object};
					$Opt03ObjForPersonI = $object;
				}								
				
				if ( $verbose >= 8 ){
					printf $output " personI = %3s ; objectJ = %3s ; Current Value %20.5f = \$matrix[%3s][%3s] %12.0f - \$price_object{%3s} %20.5f <old list> Max01_CurVal = %12.5f (%3s), Max02_CurVal = %12.5f (%3s), Max03_CurVal = %12.5f (%3s)\n", 
					$person, $object, $current_value{$object}, $person, $object, $matrix_value, $object, $price_object{$object}, 
					$Opt01ValForPersonI, defined $Opt01ObjForPersonI ? $Opt01ObjForPersonI : '', 
					$Opt02ValForPersonI, defined $Opt02ObjForPersonI ? $Opt02ObjForPersonI : '', 
					$Opt03ValForPersonI, defined $Opt03ObjForPersonI ? $Opt03ObjForPersonI : '';
				}
			}
			
			if ( not @updated_price and not $locked_list{$person} ) # if all prices are outdated
			{
				for my $object ( 0 .. $max_size - 1 ) # generate new list
				{
					next if ( defined $current_value{$object} );
					
					my $matrix_value = $seen_ghost ? 0 : $matrix[$person]->[$object];				
					$current_value{$object} = $matrix_value - $price_object{$object};						
				
					if ( $current_value{$object} > $Opt01ValForPersonI_new_list ) # to find the best 3 objects in the complementary subset <new list>
					{
						$Opt03ValForPersonI_new_list = $Opt02ValForPersonI_new_list;
						$Opt03ObjForPersonI_new_list = $Opt02ObjForPersonI_new_list;
						$Opt02ValForPersonI_new_list = $Opt01ValForPersonI_new_list;
						$Opt02ObjForPersonI_new_list = $Opt01ObjForPersonI_new_list;
						$Opt01ValForPersonI_new_list = $current_value{$object};
						$Opt01ObjForPersonI_new_list = $object;
					}
					elsif ( $current_value{$object} > $Opt02ValForPersonI_new_list )
					{
						$Opt03ValForPersonI_new_list = $Opt02ValForPersonI_new_list;
						$Opt03ObjForPersonI_new_list = $Opt02ObjForPersonI_new_list;
						$Opt02ValForPersonI_new_list = $current_value{$object};
						$Opt02ObjForPersonI_new_list = $object;
					}
					elsif ( $current_value{$object} > $Opt03ValForPersonI_new_list )
					{
						$Opt03ValForPersonI_new_list = $current_value{$object};
						$Opt03ObjForPersonI_new_list = $object;
					}

					if ( $verbose >= 8 ){
						printf $output " personI = %3s ; objectJ = %3s ; Current Value %20.5f = \$matrix[%3s][%3s] %12.0f - \$price_object{%3s} %20.5f <new list> Max01_CurVal = %12.5f (%3s), Max02_CurVal = %12.5f (%3s), Max03_CurVal = %12.5f (%3s)\n", 
						$person, $object, $current_value{$object}, $person, $object, $matrix_value, $object, $price_object{$object}, 
						$Opt01ValForPersonI_new_list, defined $Opt01ObjForPersonI_new_list ? $Opt01ObjForPersonI_new_list : '', 
						$Opt02ValForPersonI_new_list, defined $Opt02ObjForPersonI_new_list ? $Opt02ObjForPersonI_new_list : '', 
						$Opt03ValForPersonI_new_list, defined $Opt03ObjForPersonI_new_list ? $Opt03ObjForPersonI_new_list : '';
					}				
				}			
				
				# to find the best 3 out of 6 objects

				if ( $Opt01ValForPersonI_new_list > $Opt01ValForPersonI )
				{
					$Opt03ValForPersonI = $Opt02ValForPersonI;
					$Opt03ObjForPersonI = $Opt02ObjForPersonI;
					$Opt02ValForPersonI = $Opt01ValForPersonI;
					$Opt02ObjForPersonI = $Opt01ObjForPersonI;
					$Opt01ValForPersonI = $Opt01ValForPersonI_new_list;
					$Opt01ObjForPersonI = $Opt01ObjForPersonI_new_list;
				}
				elsif ( $Opt01ValForPersonI_new_list > $Opt02ValForPersonI )
				{
					$Opt03ValForPersonI = $Opt02ValForPersonI;
					$Opt03ObjForPersonI = $Opt02ObjForPersonI;
					$Opt02ValForPersonI = $Opt01ValForPersonI_new_list;
					$Opt02ObjForPersonI = $Opt01ObjForPersonI_new_list;
				}
				elsif ( $Opt01ValForPersonI_new_list > $Opt03ValForPersonI )
				{
					$Opt03ValForPersonI = $Opt01ValForPersonI_new_list;
					$Opt03ObjForPersonI = $Opt01ObjForPersonI_new_list;
				}
 
				if ( $Opt02ValForPersonI_new_list > $Opt02ValForPersonI )
				{
					$Opt03ValForPersonI = $Opt02ValForPersonI;
					$Opt03ObjForPersonI = $Opt02ObjForPersonI;
					$Opt02ValForPersonI = $Opt02ValForPersonI_new_list;
					$Opt02ObjForPersonI = $Opt02ObjForPersonI_new_list;
				}
				elsif ( $Opt02ValForPersonI_new_list > $Opt03ValForPersonI )
				{
					$Opt03ValForPersonI = $Opt02ValForPersonI_new_list;
					$Opt03ObjForPersonI = $Opt02ObjForPersonI_new_list;
				}

				if ( $Opt03ValForPersonI_new_list > $Opt03ValForPersonI )
				{
					$Opt03ValForPersonI = $Opt03ValForPersonI_new_list;
					$Opt03ObjForPersonI = $Opt03ObjForPersonI_new_list;
				}
			}
			
			$bidForPersonI = $Opt01ValForPersonI - $Opt02ValForPersonI + $epsilon;
			
			my @objects_with_same_values;
			
			if ( $Opt01ValForPersonI == $Opt02ValForPersonI ) # this person can choose different objects that have the same values = $Opt01ValForPersonI
			{
				@objects_with_same_values = grep { $current_value{$_} == $Opt01ValForPersonI } keys %current_value;
				$objects_with_the_same_values{$_}{$person} = $Opt01ValForPersonI for (@objects_with_same_values);
				$count_object{$_}++ for (@objects_with_same_values);
				
				if ( not @updated_price and defined $Opt01ValForPersonI_old_list ){
					for my $object ( @objects_with_same_values ){
						next unless ( $current_value{$object} > $Opt01ValForPersonI_old_list ); # objects in the new list that have values greater than the objects in the old list
						$objects_desired_by_this{$person}{$object} = $current_value{$object};   # add information about the most desired objects
					}
				}

			} else 
			{
				$choose_object{$Opt01ObjForPersonI}++;
			
				if ( (not defined $info{$Opt01ObjForPersonI}) || ($bidForPersonI > $info{$Opt01ObjForPersonI}{'bid'}) || ($bidForPersonI == $info{$Opt01ObjForPersonI}{'bid'} and $current_value{$Opt01ObjForPersonI} > $info{$Opt01ObjForPersonI}{'CurVal'}) )
				{			
					$info{$Opt01ObjForPersonI}{'bid'   } = $bidForPersonI; # Stores the bidding info for future use
					$info{$Opt01ObjForPersonI}{'person'} = $person;
					$info{$Opt01ObjForPersonI}{'CurVal'} = $current_value{$Opt01ObjForPersonI};
				
					#printf " object = %3s ; person = %3s ; bid = %12.5f ; CurVal = %12.5f \n", $Opt01ObjForPersonI, $info{$Opt01ObjForPersonI}{'person'}, $info{$Opt01ObjForPersonI}{'bid'}, $info{$Opt01ObjForPersonI}{'CurVal'}; sleep 1;
				}
			}
			
			if ( $epsilon_scaling >= 6 and $epsilon_scaling % 2 == 0 and not $seen_person{$person}++ ) # filter the old list
			{					
				for my $object ( @objects_with_greater_benefits ){ # frequently check the quality of objects in the old list
					next if ( $current_value{$object} >= $Opt03ValForPersonI );
					next unless ( ($Opt03ValForPersonI - $current_value{$object}) > $min_size * $epsilon ); # critical value ($min_size * $epsilon)
					delete $objects_desired_by_this{$person}{$object}; # delete objects of little benefit from the old list
					printf $output "<> PersonI = %3s ; *** delete the object %3s from the old list *** \n", $person, $object if ( $verbose >= 8 );
				}
			}
					
			if ( not @updated_price ) # if all prices are outdated
			{			
				for my $object ( @objects_with_greater_benefits ){
					next unless ( defined $objects_desired_by_this{$person}{$object} );
					$objects_desired_by_this{$person}{$object} = $current_value{$object}; # update current values for all objects in the old list	
				}
				
				$objects_desired_by_this{$person}{$Opt01ObjForPersonI} = $current_value{$Opt01ObjForPersonI}; # add information about the most desired objects
				$objects_desired_by_this{$person}{$Opt02ObjForPersonI} = $current_value{$Opt02ObjForPersonI} if (defined $Opt02ObjForPersonI);
				$objects_desired_by_this{$person}{$Opt03ObjForPersonI} = $current_value{$Opt03ObjForPersonI} if (defined $Opt03ObjForPersonI);				

				$locked_list{$person} = 1 if ( $epsilon_scaling > (1/10) * $max_epsilon_scaling and ($Opt03ValForPersonI - $Opt01ValForPersonI_new_list) > $min_size * $epsilon );
				$locked_list{$person} = 1 if ( $epsilon_scaling > (3/10) * $max_epsilon_scaling ); # Lock the old list. Is this the minimum value to find a possible solution?
				delete $locked_list{$person} if ( $epsilon == 1/(1+$min_size) ); # Otherwise unlock the person's old list in the last $epsilon_scaling round.
			}
			
			if ( $verbose >= 8 ){
				my @old_list = sort { $a <=> $b } @objects_with_greater_benefits;
				my @new_list = sort { $a <=> $b } keys %{$objects_desired_by_this{$person}};
				@updated_price = sort { $a <=> $b } @updated_price;
				my @best_3_objects = ( $Opt01ObjForPersonI, $Opt02ObjForPersonI, $Opt03ObjForPersonI );				
				my $msg = $locked_list{$person} ? '[locked list] ' : '';
				
				@objects_with_same_values = sort { $a <=> $b } @objects_with_same_values;
				$this_person_can_choose_n_different_objects{$person}{'objects'} = \@objects_with_same_values; #reference to an array								

				printf $output "<> PersonI = %3s ; %3s objects desired by this person (old list) = (@old_list) ; objects whose current values are still updated = (@updated_price) : %2s >= 1 ? \n", $person, scalar @old_list, scalar @updated_price;
				printf $output "<> PersonI = %3s ; %3s objects desired by this person (new list) = (@new_list) $msg; \@best_3_objects = (@best_3_objects) \n", $person, scalar @new_list if ( defined $Opt03ObjForPersonI );
				printf $output "<> PersonI = %3s chose ObjectJ = %3s ; \$bidForPersonI %10.5f = \$Opt01ValForPersonI %.5f - \$Opt02ValForPersonI %.5f + \$epsilon %.5f \n", $person, $Opt01ObjForPersonI, $bidForPersonI, $Opt01ValForPersonI, $Opt02ValForPersonI, $e...
				printf $output "<> PersonI = %3s ; these objects (@objects_with_same_values) have the same values \$Opt01ValForPersonI = %10.5f ; \$Opt01ObjForPersonI = $Opt01ObjForPersonI ; *** equal values *** \n", $person, $Opt01ValForPersonI if (@objects_wit...
			}
		}
	}

	# first, choose objects that appear a few times
	foreach my $object ( sort { $count_object{$a} <=> $count_object{$b} || $seen_assignned_objects{$a} <=> $seen_assignned_objects{$b} } keys %objects_with_the_same_values ){ # sort { $price_object{$b} <=> $price_object{$a} }
	foreach my $person ( keys %{$objects_with_the_same_values{$object}} ){ # sort { $objects_with_the_same_values{$object}{$a} <=> $objects_with_the_same_values{$object}{$b} }
		
		next if ( $choose_object{$object} );
		next if ( $choose_person{$person} );
	
		my $CurVal = $objects_with_the_same_values{$object}{$person}; # $CurVal = $current_value{$object} = $Opt01ValForPersonI.
		my $Opt01ObjForPersonI = $object;
			
		$info{$Opt01ObjForPersonI}{'bid'   } = $epsilon;
		$info{$Opt01ObjForPersonI}{'person'} = $person;
			
		$objects_desired_by_this{$person}{$object} = $CurVal;							
		
		if ( $verbose >= 8 ){
		
			my @objects_with_same_values_full = sort { $a <=> $b } @{$this_person_can_choose_n_different_objects{$person}{'objects'}};
			my @objects_with_same_values_free = grep { not $choose_object{$_} } @objects_with_same_values_full;
			
			printf $output "<*** equal values ***> \$bidForPersonI = \$epsilon = %.5f ; PersonI = %3s chose ObjectJ = %3s between these (@objects_with_same_values_full) --> free (@objects_with_same_values_free) ; \$count_object{$object} = $count_object{$objec...
		}
		
		$choose_object{$object}++;
		$choose_person{$person}++;
	}}
	
	foreach my $object ( keys %info ) # sort { $a <=> $b } or sort { $info{$a}{'person'} <=> $info{$b}{'person'} }
	{
		my $bid    = $info{$object}{'bid'   };
		my $person = $info{$object}{'person'};

		my $other_person = $assignned_object{$object}; # Find the other person who has objectJ and make them unassigned
	   	   	   
		if ( defined $other_person ) {
		  
			if ( $verbose >= 8 ){
				print $output " ***--> PersonI $person was assigned objectJ $object. Before that, remove the objectJ $object from personI $other_person  --> delete \$assignned_person{$other_person} \n";
			}
		  
			# The other person that was assigned to objectJ at the beginning of the iteration (if any) 
			# is now left without an object (and becomes eligible to bid at the next iteration).
	   
			delete $assignned_person{$other_person};
		}
	   
		# Each objectJ that receives one or more bids, determines the highest of these bids, increases the price_j 
		# to the highest bid, and gets assigned to the personI who submitted the highest bid.

		$seen_assignned_objects{$object}++;
		
		$assignned_person{$person} = $object;
		$assignned_object{$object} = $person;

		$price_object{$object} += $bid;				
	   
		if ( $verbose >= 8 ){
			printf $output " --> Assigning to personI = %3s the objectJ = %3s with highestBidForJ = %20.5f and update the price vector ; \$assignned_person{%3s} = %3s ; \$price_object{%3s} = %.5f \n", $person, $object, $bid, $person, $assignned_person{$person...
		}
	}
	
	if ( $verbose >= 9 )
	{		
		$number_of_assignned_object = scalar keys %assignned_object;
		print $output "\n Final: Matrix Size N x M: $min_size x $max_size ; epsilon_scaling = $epsilon_scaling ; Number of Global Iterations = $iter_count_global ; Number of Local Iterations = $iter_count_local ; epsilon = $epsilon ; \$number_of_assignned_...
		
		foreach my $person ( sort { $a <=> $b } keys %assignned_person ){
			my $object = $assignned_person{$person};
			printf $output " \$assignned_person{%3s} --> object %3s --> \$price_object{%3s} = $price_object{$object} \n", $person, $object, $object;
		}
		foreach my $object ( sort { $a <=> $b } keys %price_object ){
			printf $output " \$price_object{%3s} = $price_object{$object} \n", $object;
		}
		print $output "\n";
	}

}

1;  # don't forget to return a true value from the file

__END__

=head1 NAME

	Algorithm::Bertsekas - auction algorithm for the assignment problem.
	
	This is a perl implementation for the auction algorithm for the asymmetric (N<=M) assignment problem.

=head1 DESCRIPTION
 
 The assignment problem in the general form can be stated as follows:

 "Given N jobs (or persons), M tasks (or objects) and the effectiveness of each job for each task, 
 the problem is to assign each job to one and only one task in such a way that the measure of 
 effectiveness is optimised (Maximised or Minimised)."
 
 "Each assignment problem has associated with a table or matrix. Generally, the rows contain the 
 jobs (or persons) we wish to assign, and the columns comprise the tasks (or objects) we want them 
 assigned to. The numbers in the table are the costs associated with each particular assignment."
 
 In Auction Algorithm (AA) the N persons iteratively submit the bids to M objects.
 The AA take cost Matrix N×M = [aij] as an input and produce assignment as an output.
 In the AA persons iteratively submit the bids to the objects which are then reassigned 
 to the bidders which offer them the best bid.
 
 Another application is to find the (nearest/more distant) neighbors. 
 The distance between neighbors can be represented by a matrix or a weight function, for example:
 1: f(i,j) = abs ($array1[i] - $array2[j])
 2: f(i,j) = ($array1[i] - $array2[j]) ** 2
 

=head1 SYNOPSIS

 ### --- simple and direct application --- ###
 ### ---            start              --- ###

 #!/usr/bin/perl

 use strict;
 use warnings FATAL => 'all';
 use diagnostics;
 use Algorithm::Bertsekas qw(auction); # To install this modulus: 'cpan Algorithm::Bertsekas' or 'ppm install Algorithm-Bertsekas'

 my @array1; my @array2;
 my @input_matrix;

 my $N = 10;
 my $M = 10;
 my $range = 1000;

 for my $i (1..$N) {
	push @array1, sprintf( "%.0f", rand($range) );
 }

 for my $i (1..$M) {
	push @array2, sprintf( "%.0f", rand($range) );
 }

 print "\n \@array1 = ( ";
 for my $value (@array1) { printf("%4.0f ", $value); }
 print ")\n";

 print " \@array2 = ( ";
 for my $value (@array2) { printf("%4.0f ", $value); }
 print ")\n";
			
 for my $i ( 0 .. $#array1 ){
	my @weight_function;		   
	for my $j ( 0 .. $#array2 ){
		#my $weight = sprintf( "%.0f", rand($range) );
		my $weight = abs ($array1[$i] - $array2[$j]);		  
		push @weight_function, $weight;
	}
	push @input_matrix, \@weight_function;
 }

 print "\n The Nearest Neighbors and the Matrix of the weight function f(i,j) between each element of the two vectors \@array1 and \@array2.";	
 print "\n The weight function chosen can be the modulus of the difference between two real numbers: f(i,j) = abs (\$array1[i] - \$array2[j]). \n\n \@input_matrix = \n\n ";
 print " " x 7;			
 printf("%4.0f ", $_ ) for @array2;			   
 print "\n\n";			   
 for my $i ( 0 .. $#input_matrix ) {
	printf(" %4.0f [ ", $array1[$i] );
	for my $j ( 0 .. $#{$input_matrix[$i]} ) {