view release on metacpan or  search on metacpan

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

 	  
   } else {

      for my $i ( 0 .. $#matrix ) {
      for my $j ( 0 .. $#{$matrix[$i]} ) {   
	     
		$matrix[$i]->[$j] = $max_matrix_value - $matrix[$i]->[$j] ;
		 
		#$matrix[$i]->[$j] = 99 * ( $max_matrix_value - $matrix[$i]->[$j] ) / $range; # new scale: Min = 0 <---> Max = 99
      }}	  
   }
}

sub auctionRound {
	my ( $matrix_ref, $epsilon, $verbose ) = @_;
	my @matrix = @$matrix_ref;
	my ( %info, %choose_object, %count_object, %choose_person );
	my %this_person_can_choose_n_different_objects;
	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;