view release on metacpan or  search on metacpan

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

our $VERSION = '0.87';

#Variables global to the package	
my $maximize_total_benefit;
my $matrix_spaces;     # used to print messages on the screen
my $decimals;          # the number of digits after the decimal point
my ( $array1_size, $array2_size, $min_size, $max_size, $original_max_size );
my ( $need_transpose, $inicial_price, $iter_count_global, $iter_count_local );
my ( $epsilon_scaling, $max_epsilon_scaling, $max_matrix_value, $target, $output );
my ( %index_correlation, %assignned_object, %assignned_person, %price_object );
my ( %objects_desired_by_this, %locked_list, %seen_person, %seen_assignned_objects );

sub auction { #						=> default values
	my %args = ( matrix_ref				=> undef,     # reference to array: matrix N x M			                                     
				maximize_total_benefit  => 0,         # 0: minimize_total_benefit ; 1: maximize_total_benefit
				inicial_stepsize        => undef,     # auction algorithm terminates with a feasible assignment if the problem data are integer and stepsize < 1/min(N,M)				
				inicial_price           => 0,
				verbose                 => 3,         # level of verbosity, 0: quiet; 1, 2, 3, 4, 5, 8, 9, 10: debug information.
				@_,                                   # argument pair list goes here
				);
       
	$max_matrix_value = 0;
	$iter_count_global = 0;
	$epsilon_scaling = 0;
	$need_transpose = 0;
	%index_correlation = ();
	%assignned_object = ();
	%assignned_person = ();
	%price_object = ();
	%objects_desired_by_this = ();
	%locked_list = ();
	%seen_person = ();
	
	my @matrix_input = @{$args{matrix_ref}};          # Input: Reference to the input matrix (NxM) = $min_size x $max_size
   
	$array1_size = $#matrix_input + 1;
	$array2_size = $#{$matrix_input[0]} + 1;
 
	$min_size = $array1_size < $array2_size ? $array1_size : $array2_size ; # square matrix --> $min_size = $max_size and $array1_size = $array2_size
	$max_size = $array1_size < $array2_size ? $array2_size : $array1_size ;
	$original_max_size = $max_size;

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

				
				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>
					{

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

			{			
				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...
			}
		}