#! perl -slw use strict; use Term::ReadKey; use Clone qw[ clone ]; use List::Util qw[ min reduce sum ]; $a=$b; $| = 1; use constant { X => 0, Y => 1, }; use constant { REP => 0, LOCNS => 1, SCORE => 2 }; our $GRID ||= '100:100'; ## X:Y of grid our @GRID = split ':', $GRID; our $REPN ||= 10; ## Number of representatives our $LOCN ||= $REPN * 3; ## Number of locations our $EVO ||= 1000; ## Evolution backtrack count our $S and srand( 1 ); ## allows comparison between runs. print "Reps: $REPN Locations:$LOCN"; die "LOCN must be >= $REPN" unless $LOCN >= $REPN; sub show { ## Format sets for display system 'cls' if @_ > 1; for( @{ $_[ 0 ] } ) { printf "[%7s] %7g [ %s ]\n", "@{ $_->[REP] }", $_->[SCORE]||0.0, join '', map{ sprintf "[%3d:%3d]", @$_ } @{ $_->[LOCNS] }; } } sub pythagoras { ## calc distance between to points. my( $v1, $v2 ) = @_; my $dx = abs( $v1->[X] ) - abs( $v2->[X] ); my $dy = abs( $v1->[Y] ) - abs( $v2->[Y] ); return sqrt( $dx**2 + $dy**2 ); } ## Simple scoring. of individual sets ## Sum of distances of locations from rep location. sub score { my( $set ) = @_; return sum map { pythagoras( $set->[ 0 ], $_ ); } @{ $set->[ 1 ] } } my @reps = map { [ int rand rand $GRID[X], int rand $GRID[Y] ] } 1 .. $REPN; my @locations = map { [ int rand $GRID[X], int rand $GRID[Y] ] } 1 .. $LOCN; my @sets = map { [ $_, [ pop @locations ] ] } @reps; push @{ $sets[ rand @sets ][1] }, pop @locations while @locations; show( \@sets, 1 ); ; my( $tries, $c ) = ( 0, 's' ); my $best = [ 9e99, [], 9 ]; my $evolution = 0; my( %scores, %best ); my( $delay, $display, $stop ) = ( -1, 1, 0 ); ReadMode 2; while( 1 ) { ## Caclulate the total score for the current sets. ## Sum of individual totals. my $totalScore = sum map { $_->[SCORE] = score $_ } @sets; ## Records frequencies of (integerised) solutions found $scores{ int $totalScore }++; ## Keep track of iterations $tries++; ## Commands to monitor progress and quit. $c = ReadKey( $delay )||''; $stop = 1 if $c eq 'q'; ## Quit $delay += 1 if $c eq 's'; ## speed (0=pause) (n>0 sleep n) $delay = -1 if $c eq 'c'; ## Continue fullspeed $display = !$display if $c eq 'd'; ## Toggle display if( $best->[ 0 ] > $totalScore ) { ## If we found a better solution $best = [ $totalScore, clone( \@sets ), $tries ]; ## save it $evolution = $EVO; ## but allow bad solution to evolve for a while ## Keep a record of when we found improvements ## to allow estimates of "good enough" iterations; $best{ $tries } = $totalScore; } elsif( $stop or not --$evolution ) { ## if no better evolution after $EVO attempts @sets = @{ $best->[1] }; ## Restore the best yet and try again print 'Best restored'; Win32::Sleep 1000; } last if $stop; ## stop here after ensuring the best is restored. ## Sort them by individual scores @sets = sort{ $a->[SCORE] <=> $b->[SCORE] } @sets; ## Display them show \@sets, 1 if $display; printf "%06d (%06d) %g %g\n", $tries, $best->[ 2 ], $best->[ 0 ], $totalScore; ## If the worst set has more than 1, given one to the best push @{ $sets[ 0 ][LOCNS] }, shift @{ $sets[ -1 ][LOCNS] } if @{ $sets[ -1 ][LOCNS] } > 1; ## pick two set/location pairs at random my( $a, $b ) = map{ int rand @sets } 1 .. 2; my( $sa, $sb ) = ( int rand $#{ $sets[ $a ][LOCNS] }, int rand $#{ $sets[ $b ][LOCNS] } ); ## and swap them my $temp = $sets[ $a ][LOCNS][ $sa ]||die "A:$a:$sa"; $sets[ $a ][LOCNS][ $sa ] = $sets[ $b ][LOCNS][ $sb ]||die "B:$b:$sb"; $sets[ $b ][LOCNS][ $sb ] = $temp; } show \@sets; ## display best solution printf "Total: %d after %d tries\n", $best->[ 0 ], $best->[ 2 ]; printf 'Enter to see a frequendy plot of the solutions found'; ; print "$_ => $scores{ $_ }" for sort{ $a <=> $b } keys %scores; printf 'Enter to see record of best discovery points.'; ; print "Best score: $best{ $_ } after $_ iterations." for sort{ $a <=> $b } keys %best;