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;

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

 my @input_matrix = ( 
 [  84,  94,  75,  56,  66,  95,  39,  53,  73,   4 ],
 [  76,  71,  56,  49,  29,   1,  40,  40,  72,  72 ],
 [  85, 100,  71,  23,  47,  18,  82,  70,  30,  71 ],
 [   2,  95,  71,  89,  73,  73,  48,  52,  90,  51 ],
 [  65,  28,  77,  73,  24,  28,  75,  48,   8,  81 ],
 [  25,  27,  35,  89,  98,  10,  99,   3,  27,   4 ],
 [  58,  15,  99,  37,  92,  55,  52,  82,  73,  96 ],
 [  11,  75,   2,   1,  88,  43,   8,  28,  98,  20 ],
 [  52,  95,  10,  38,  41,  64,  20,  75,   1,  47 ],
 [  50,  80,  31,  90,  10,  83,  51,  55,  57,  40 ]
 );

 my ( $optimal, $assignment_ref, $output_index_ref ) = auction( matrix_ref => \@input_matrix, maximize_total_benefit => 1, verbose => 3 );

 Objective: to Maximize the total benefit
 Number of left nodes: 10
 Number of right nodes: 10
 Number of edges: 100

 Solution:
 Optimal assignment: sum of values = 893
 Feasible assignment condition: stepsize = 0.09091 < 1/10 = 0.1
 Number of iterations: 27

 row index    = [  0   1   2   3   4   5   6   7   8   9 ]
 column index = [  5   0   1   8   9   6   2   4   7   3 ]
 matrix value = [ 95  76 100  90  81  99  99  88  75  90 ]

 original matrix 10 x 10 with solution:
 [  84    94    75    56    66    95**  39    53    73     4  ]
 [  76**  71    56    49    29     1    40    40    72    72  ]
 [  85   100**  71    23    47    18    82    70    30    71  ]
 [   2    95    71    89    73    73    48    52    90**  51  ]
 [  65    28    77    73    24    28    75    48     8    81**]
 [  25    27    35    89    98    10    99**   3    27     4  ]
 [  58    15    99**  37    92    55    52    82    73    96  ]
 [  11    75     2     1    88**  43     8    28    98    20  ]
 [  52    95    10    38    41    64    20    75**   1    47  ]
 [  50    80    31    90**  10    83    51    55    57    40  ]

 Pairs (in ascending order of matrix values):
   indexes (  8,  7 ), matrix value =  75 ; sum of values =  75
   indexes (  1,  0 ), matrix value =  76 ; sum of values = 151
   indexes (  4,  9 ), matrix value =  81 ; sum of values = 232
   indexes (  7,  4 ), matrix value =  88 ; sum of values = 320
   indexes (  3,  8 ), matrix value =  90 ; sum of values = 410
   indexes (  9,  3 ), matrix value =  90 ; sum of values = 500
   indexes (  0,  5 ), matrix value =  95 ; sum of values = 595
   indexes (  5,  6 ), matrix value =  99 ; sum of values = 694
   indexes (  6,  2 ), matrix value =  99 ; sum of values = 793
   indexes (  2,  1 ), matrix value = 100 ; sum of values = 893
 
=head1 OPTIONS
 
 matrix_ref => \@input_matrix,   reference to array: matrix N x M.
 maximize_total_benefit => 0,    0: minimize the total benefit ; 1: maximize the total benefit.
 inicial_stepsize       => 1,    auction algorithm terminates with a feasible assignment if the problem data are integer and stepsize < 1/min(N,M).
 inicial_price          => 0,			
 verbose                => 3,    print messages on the screen, level of verbosity, 0: quiet; 1, 2, 3, 4, 5, 8, 9, 10: debug information.

=head1 EXPORT

    "auction" function by default.

=head1 INPUT

    The input matrix should be in a two dimensional array (array of array) 
	and the 'auction' subroutine expects a reference to this array.

=head1 OUTPUT

    The $output_index_ref is the reference to the output_index array.
	The $assignment_ref  is the reference to the assignment hash.
	The $optimal is the total benefit which can be a minimum or maximum value.
	

=head1 SEE ALSO
  
	1. Network Optimization: Continuous and Discrete Models (1998).
	   Dimitri P. Bertsekas
	   http://web.mit.edu/dimitrib/www/netbook_Full_Book.pdf
	   
	2. Towards auction algorithms for large dense assignment problems (2008).
	   Libor Bus and Pavel Tvrdik
	   https://pdfs.semanticscholar.org/b759/b8fb205df73c810b483b5be2b1ded62309b4.pdf
	
	3. https://github.com/EvanOman/AuctionAlgorithmCPP/blob/master/auction.cpp
	   This Perl algorithm started from this C++ implementation.
	      
	4. https://en.wikipedia.org/wiki/Assignment_problem
	
	5. https://en.wikipedia.org/wiki/Auction_algorithm


=head1 AUTHOR

    Claudio Fernandes de Souza Rodrigues
	May 21, 2018
	Sao Paulo, Brasil
	claudiofsr@yahoo.com
	
=head1 COPYRIGHT AND LICENSE

 Copyright (c) 2018 Claudio Fernandes de Souza Rodrigues.  All rights reserved.

 This program is free software; you can redistribute it and/or modify
 it under the same terms as Perl itself.

=cut