434412 -REPN=10 -LOCN=30 -S
#prog people loc'tns (srand(1) for testing)
####
[ 12 85] 127.723 [ [ 42: 80][ 74: 10] ]
[ 31 82] 156.39 [ [ 27: 27][ 57: 36][ 45: 94][ 58: 69] ]
[ 34 60] 158.432 [ [ 48: 20][ 86: 20][ 83: 72] ]
[ 47 47] 162.078 [ [ 78: 80][ 5: 60][ 53: 14][ 37: 9] ]
[ 36 30] 173.694 [ [ 67: 5][ 87: 72][ 77: 84] ]
[ 2 98] 173.723 [ [ 73: 60][ 95: 92] ]
[ 0 53] 178.987 [ [ 15: 22][ 99: 99][ 26: 29] ]
[ 5 0] 183.089 [ [ 45: 35][ 74: 46][ 46: 23] ]
[ 0 36] 183.654 [ [ 16: 66][ 59: 38][ 84: 2] ]
[ 0 19] 188.368 [ [ 61: 39][ 0: 91][ 51: 30] ]
000170 (000113) 1493.7 1686.14
#Cur'nt(Best ) Best Current
#Iters (iters) score score
####
#! 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;
####
[ 0 19] 41.3038 [ [ 5: 60] ]
[ 0 36] 45.0111 [ [ 45: 35] ]
[ 47 47] 47.1699 [ [ 87: 72] ]
[ 34 60] 49.7695 [ [ 53: 14] ]
[ 0 53] 54.9181 [ [ 46: 23] ]
[ 5 0] 66.9104 [ [ 16: 66] ]
[ 12 85] 67.424 [ [ 51: 30] ]
[ 2 98] 78.1025 [ [ 78: 80] ]
[ 31 82] 82.8794 [ [ 86: 20] ]
[ 36 30] 85.5862 [ [ 95: 92] ]
037234 (021726) 435.401 619.075
Best restored
[ 0 53] 54.9181 [ [ 46: 23] ]
[ 36 30] 15 [ [ 51: 30] ]
[ 12 85] 83.2947 [ [ 95: 92] ]
[ 0 36] 45.0111 [ [ 45: 35] ]
[ 47 47] 47.1699 [ [ 87: 72] ]
[ 0 19] 41.3038 [ [ 5: 60] ]
[ 34 60] 49.7695 [ [ 53: 14] ]
[ 31 82] 82.8794 [ [ 86: 20] ]
[ 2 98] 78.1025 [ [ 78: 80] ]
[ 5 0] 66.9104 [ [ 16: 66] ]
Total: 435 after 21726 tries
Enter to see a frequendy plot of the solutions found
435 => 3
441 => 3
442 => 2
443 => 1
447 => 1
448 => 1
450 => 3
453 => 4
454 => 3
455 => 1
456 => 1
457 => 3
459 => 3
461 => 2
462 => 1
463 => 3
464 => 4
465 => 3
466 => 4
467 => 9
468 => 6
469 => 8
470 => 6
471 => 6
472 => 7
473 => 12
474 => 4
475 => 8
476 => 12
477 => 10
478 => 10
479 => 15
480 => 13
481 => 12
482 => 13
483 => 9
484 => 20
485 => 8
486 => 17
487 => 22
488 => 21
489 => 22
490 => 21
491 => 29
492 => 30
493 => 23
494 => 27
495 => 40
496 => 34
497 => 39
498 => 34
499 => 42
500 => 31
501 => 43
502 => 64
503 => 49
504 => 53
505 => 44
506 => 55
507 => 72
508 => 63
509 => 72
510 => 58
511 => 59
512 => 60
513 => 84
514 => 63
515 => 59
516 => 78
517 => 83
518 => 77
519 => 105
520 => 94
521 => 83
522 => 91
523 => 110
524 => 107
525 => 101
526 => 134
527 => 125
528 => 119
529 => 110
530 => 134
531 => 122
532 => 113
533 => 125
534 => 152
535 => 157
536 => 170
537 => 153
538 => 173
539 => 153
540 => 194
541 => 181
542 => 149
543 => 179
544 => 188
545 => 172
546 => 192
547 => 210
548 => 207
549 => 213
550 => 204
551 => 212
552 => 235
553 => 254
554 => 248
555 => 185
556 => 268
557 => 242
558 => 256
559 => 247
560 => 258
561 => 258
562 => 241
563 => 290
564 => 281
565 => 288
566 => 318
567 => 306
568 => 268
569 => 306
570 => 275
571 => 281
572 => 268
573 => 307
574 => 307
575 => 299
576 => 254
577 => 293
578 => 324
579 => 284
580 => 299
581 => 304
582 => 303
583 => 322
584 => 333
585 => 342
586 => 323
587 => 329
588 => 333
589 => 312
590 => 331
591 => 274
592 => 314
593 => 349
594 => 318
595 => 303
596 => 290
597 => 318
598 => 323
599 => 288
600 => 272
601 => 329
602 => 331
603 => 335
604 => 304
605 => 312
606 => 328
607 => 311
608 => 315
609 => 290
610 => 280
611 => 320
612 => 272
613 => 267
614 => 298
615 => 307
616 => 260
617 => 280
618 => 283
619 => 346
620 => 299
621 => 253
622 => 262
623 => 264
624 => 251
625 => 230
626 => 226
627 => 254
628 => 239
629 => 260
630 => 231
631 => 245
632 => 226
633 => 217
634 => 244
635 => 206
636 => 221
637 => 226
638 => 180
639 => 176
640 => 206
641 => 175
642 => 180
643 => 161
644 => 166
645 => 203
646 => 167
647 => 179
648 => 163
649 => 155
650 => 125
651 => 146
652 => 128
653 => 130
654 => 121
655 => 137
656 => 127
657 => 121
658 => 122
659 => 120
660 => 100
661 => 115
662 => 93
663 => 119
664 => 102
665 => 109
666 => 107
667 => 90
668 => 87
669 => 88
670 => 90
671 => 63
672 => 69
673 => 74
674 => 69
675 => 45
676 => 57
677 => 61
678 => 53
679 => 49
680 => 62
681 => 54
682 => 53
683 => 41
684 => 50
685 => 49
686 => 50
687 => 41
688 => 31
689 => 44
690 => 30
691 => 37
692 => 36
693 => 36
694 => 42
695 => 39
696 => 29
697 => 19
698 => 26
699 => 28
700 => 28
701 => 30
702 => 24
703 => 22
704 => 22
705 => 16
706 => 20
707 => 15
708 => 13
709 => 13
710 => 13
711 => 14
712 => 9
713 => 8
714 => 3
715 => 8
716 => 4
717 => 1
718 => 2
719 => 9
720 => 3
721 => 5
722 => 3
723 => 3
724 => 9
725 => 3
727 => 4
728 => 1
729 => 2
730 => 3
732 => 4
733 => 4
734 => 2
735 => 1
736 => 1
739 => 2
740 => 2
741 => 1
742 => 3
743 => 1
744 => 1
746 => 1
Enter to see record of best discovery points.
Best score: 587.754090215359 after 1 iterations.
Best score: 585.739406140003 after 2 iterations.
Best score: 574.349845629305 after 7 iterations.
Best score: 539.378581196848 after 9 iterations.
Best score: 515.579334272599 after 25 iterations.
Best score: 503.180579975418 after 26 iterations.
Best score: 482.804864664163 after 98 iterations.
Best score: 481.914466880709 after 99 iterations.
Best score: 469.204365706502 after 623 iterations.
Best score: 468.414887089937 after 1607 iterations.
Best score: 454.855761343826 after 1846 iterations.
Best score: 442.160363943557 after 2281 iterations.
Best score: 442.160363943557 after 2282 iterations.
Best score: 441.218607935927 after 2283 iterations.
Best score: 435.401484875951 after 21726 iterations.