Algorithm-Bertsekas
view release on metacpan or search on metacpan
lib/Algorithm/Bertsekas.pm view on Meta::CPAN
package Algorithm::Bertsekas;
use strict;
use warnings FATAL => 'all';
use diagnostics;
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw( auction );
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;
$target = 'auction-' . $array1_size . 'x' . $array2_size . '-output.txt' ;
if ( $args{verbose} >= 8 ){
print "\n verbose = $args{verbose} ---> print the verbose messages to <$target> file \n";
if ( open ( $output, '>', $target ) ) {
print "\n *** Open <$target> for writing. *** \n";
} else {
$args{verbose} = 7;
warn "\n *** Could not open <$target> for writing: $! *** \n";
}
}
$maximize_total_benefit = $args{maximize_total_benefit};
my $optimal_benefit = 0;
my %assignment_hash; # assignment: a hash representing edges in the mapping, as in the Algorithm::Kuhn::Munkres.
my @output_index; # output_index: an array giving the number of the value assigned, as in the Algorithm::Munkres.
my @matrix;
my @matrix_index;
foreach ( @matrix_input ){ # copy the orginal matrix N x M
push @matrix, [ @$_ ];
}
if ( $max_size <= 1 ){ # matrix_input 1 x 1
$assignment_hash{0} = 0;
$output_index[0] = 0;
$matrix_index[0] = 0;
$optimal_benefit = $matrix_input[0]->[0];
}
$need_transpose = 1 if ( $array1_size > $array2_size ); # will always be chosen N <= M
if ( $need_transpose ){
my $transposed = transpose(\@matrix);
@matrix = @$transposed;
}
get_matrix_info( \@matrix, $args{verbose} );
delete_multiple_columns( \@matrix, $args{verbose} ) if ( $min_size >= 2 and $min_size != $max_size );
# epsilon is the stepsize and auction algorithm terminates with a feasible assignment if the problem data are integer and epsilon < 1/min(N,M).
# There is a trade-off between runtime and the chosen stepsize. Using the largest possible increment accelerates the algorithm.
$inicial_price = $args{inicial_price};
$price_object{$_} = $inicial_price for ( 0 .. $max_size - 1 );
#$price_object{$_} = sprintf( "%.0f", rand($max_matrix_value) ) for ( 0 .. $max_size - 1 ); # random values for initial prices
lib/Algorithm/Bertsekas.pm view on Meta::CPAN
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;
lib/Algorithm/Bertsekas.pm view on Meta::CPAN
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.
( run in 1.176 second using v1.01-cache-2.11-cpan-483215c6ad5 )