source: liacs/ccs/op4/merit.pl@ 4

#!/usr/bin/env perl

use strict;

our $debug = 0;
our %taken;

our $length = 0;
our $round_size = 100;
our $maxstack =  150;
our $working_mfactor = 0;
our $best_mfactor = 0;
our $best_vector;
our $refill = 0;
our $maxrounds = 20;
our @winners;
our $winnercompare = 10;

our $total = 0;

sub message {
    our $debug;
    my $level = shift;
    my $message = shift;
    if ( $level => $debug ) {
        print "DEBUG [$level]: $message\n";
    }
}

sub merit {
    my $y = shift;
    our $length;
    my $e = 0;
    my $f;
    my $t;

    foreach my $k (1 .. ($length - 1)) {
        $t = 0;
        for my $i (0 .. ($length - 1 - $k)) {
            $t += $$y[$i] * $$y[$i+$k];
        }
        $e += $t ** 2;
        }
    
    $f = ($length ** 2) / ( 2 * $e);
    printer('DEBUG merit', $f, $y) if $debug > 5;
    return($f);
}

sub randarray {
    our $debug;
    my @output = ();
    my ($i,$v);
    message(1,"New randarray of length $length");
    foreach $i ( 0 .. ($length - 1)) {
        $v = int(rand() + 0.5);
        $output[$i] = ( $v ) ? 1 : -1;
    }
    return(\@output);
}

sub flip {
  my $rref = shift;
  my $number = shift;
  my $v = $$rref[$number];
  $v = ($v == 1) ? -1 : 1;
  $$rref[$number] = $v;
}

sub try_merit {
    our @stack;
    our %taken;
    our $best_mfactor;
    our $best_vector;
    our $working_mfactor;

    my $try_array = shift;
    my $new_mfactor;
    my $result = 0;
    my $array2string = join('',@{$try_array});

    if ( not exists ($taken{$array2string}) ) {
        $new_mfactor = merit($try_array);
        $taken{$array2string} = $new_mfactor;

        if ($new_mfactor > $best_mfactor) {
           $best_mfactor = $new_mfactor;
           $best_vector = $try_array;
           $result = 1;
           unshift(@stack,$try_array);
        }
    }
    if ( $debug == 5 ) {
        print "==== " . scalar(@stack) . "====\n";
        print join("\n",@stack) . "\n";
    }
    return($result);
}

sub combine {
    our $length;
    our $debug;
    message(1,"Working on combine");

    my $result = 0;
    my $loop;
    my $input = shift;
    my $input2 = shift;
    my @result_l;
    my @result_r;


    my $middle = int($length / 2);
    @result_l = (@{$input}[0 .. $middle],
                 @{$input2}[ $middle + 1 ..  ($length-1) ]);
    @result_r = (@{$input2}[0 .. $middle],
                 @{$input}[ $middle + 1 ..  ($length-1) ]);

    if ($debug > 3) {
        print "Orig l: ";
        print @{$input};
        print "\n";
        print "Orig 2: ";
        print @{$input2};
        print "\n";
        print "Combine l: ";
        print @result_l;
        print "\n";
        print "Combine r: ";
        print @result_r;
        print "\n";
    }
    message(1,"DEBUG: Done on combine");
    return(\@result_l,\@result_r);
}

sub crossover {
    my $input = shift;
    my $rev_array = shift;
    my $result = 0;
    my ($try_array_l,$try_array_r)  = combine($input,$rev_array);

    if ( try_merit($try_array_l) ) {
        $result = 1;
    }

    if ( try_merit($try_array_r) ) {
        $result = 1;
    }
    return($result);
}


sub mutations {
    our $length;

    my @try_array;
    my $result = 0;
    my @test_array = @_;

    message(1,"Working on mutations");

    foreach my $i ( 0 .. ($length - 1) ) {
        my @try_array = ();
        @try_array = @test_array;
        flip(\@try_array, $i);
        
        if ( try_merit(\@try_array) ) {
            $result = 1;
        }
    }
    message(1,"Done on mutations");
    return($result) ;
}


sub crossovers {
    our $length;

    my @try_array;
    my $result = 0;
    my @test_array = @_;

    my $i;
    my $j;

    message(1,"Working on crossovers");
    foreach $i ( 0 .. ($length - 1) ) {
        my @try_array = ();
        @try_array = @test_array;
        foreach $j ( $i .. ($length - 1) ) {
            flip(\@try_array, $j);
        }

        if ( try_merit(\@try_array) ) {
            $result = 1;
        }
    }
    message(1,"Done on crossovers");
    return($result);
}




sub randmutate {
    our $length;
    my $switchtimes = shift;
    my $switchnumbers = shift;
    my @test_array = @_;
    my $result = 0;
    my @try_array;
    my $i;
    my $j;
    my $n;
    my @flipped;

    message(1,"Working on randmutate");

    foreach $i ( 0 .. $switchtimes ) {
        my @try_array = ();
        @try_array = @test_array;
        @flipped = ();
        foreach $j ( 0 .. $switchnumbers ) {
            $n = int(rand($length - 1));
            if ( not exists $flipped[$n] ) {
                flip(\@try_array,$n);
                $flipped[$n] = 1;
            }
        }

        if ( try_merit(\@try_array) ) {
            $result = 1;
        }
    }
    return($result);
}

sub printer {
    my $message = shift;
    my $mfactor = shift;
    my $input = shift;
    return("Message : $message \n" .
           "Vector  : " . join(',',array2string($input) . "\n" .
           "mfactor : $mfactor \n" .
           "--\n");
}



our @stack = ();
our $best_mfactor = 0;
our $best_vector;

sub array2string {
    my $input = shift;
    my @result = ();
    my $n = 1;
    foreach my $i (1 .. $#$input) {
        if ($$input[$i] != $$input[$i - 1]) {
            push(@result,$n);
            $n = 1;
        }
        else {
            $n++;
        }
    }
    push(@result,$n);
    return(@result);
}

sub string2array {
    my @output = ();
    my $input = shift;
    $input = split(//,$input);
    my $c = 0;
    my $v = 1;

    my ($n,$i);

    for $n ( 0 .. length($input) - 1) {
        for $i ( 1 .. @{$input}[$n] ) {
            $output[$c] = $v;
            $c++;
        }
        $v = ( $v == 1) ? -1 : 1;
    }

    return(@output);
}


#
# Vul de stack met een random arrays
sub init {
    our $length = shift;
    our @stack;
    our $best_mfactor;

    my ($n,$y);

    @stack = ();
    $best_mfactor = 0;

    foreach $n ( 1 .. 75 ) {
        $y = randarray();
        push(@stack,$y);
    }

}

sub reinit {
    our $refill;
    our $winnercompare;
    our $length;
    our @winners;
    our %taken;
    our @stack;
    our $best_vector;
    our $best_mfactor;
    
    my $maxwinners = 5;

    my ($result_l,$result_r);
    my ($i,$j);
    my ($n,$y);
    my ($r);

    %taken = ();
    @stack = ();

    $refill++;
    #push best array on good place
    $i = merit($best_vector);
    print printer("Round best vector",$i,$best_vector);
    my $ws = $#winners - 1;
    my $done = 0;
    foreach $n ( 0 .. $ws )  {
        $j = merit($winners[$n]);
        if ( $i > $j ) {
            foreach $r ($ws .. ($n + 1)) {
                $winners[$r] = $winners[$r-1];
            }
            $winners[$n] = $best_vector;
            $done = 1;
            last;
        }
    }
    if ( ($done == 0) && ($ws < $maxwinners) ) {
        push(@winners,$best_vector);
    }
    print printer("Current best vector",merit($winners[0]),$winners[0]);

    if ( $refill == $winnercompare ) {
        push(@stack,@winners);
        $refill = 0;
        $r = scalar(@stack) - 1;
        foreach $i ( 0 .. ($r - 1)) {
            foreach $j ( ($i) .. $r ) {
                ($result_l,$result_r) = combine($stack[$i],$stack[$j]);
                push(@stack,$result_l);
                push(@stack,$result_r);
            }
        }
        $best_mfactor = merit($winners[0]);
    }
    else {
        foreach $n ( 1 .. 75 ) {
            $y = randarray();
            push(@stack,$y);
        }
        $best_mfactor = 0;
    }
}

sub main {
    our $working_mfactor;
    our $round_number;
    our $maxstack;
    our $maxrounds;

    my $rounds = 0;
    my $number = 0;
    my $improvement = 0;
    my $result;
    my $stacksize;
    my ($i,$j,$r,$y);

    while ( 'true' )
    {
        $total++;
    
        $number = ($improvement) ? 0 : $number + 1;
        print "Number: $number\n" if $debug;
    
        $working_mfactor = merit(@stack[$number]);
        if ( $debug > 1 ) {
            message(1,
            printer("Working vector",$working_mfactor,@stack[$number]));
        }

        message(1,"\n" . $number . " of " . $stacksize );
        $improvement = 0;

        $result = try_merit(@stack[$number]);
        if ($result > 0 ) {
            message(1,
            printer("better array", $best_mfactor,@stack[$number]));
            $improvement = 1;
        }

        my @rev = reverse(@{$stack[$number]});
        $result = crossover($stack[$number],\@rev);
        if ($result > 0 ) {
            message(1,
            printer("better combine", $best_mfactor,@stack[$number]));
            $improvement = 1;
        }
    
        $result = mutations(@{$stack[$number]});
        if ($result > 0 ) {
            message(1,
            printer("better mutation", $best_mfactor,@stack[$number]));
            $improvement = 1;
        }

# Experimental 'crossover make'
        $result = crossovers(@{$stack[$number]});
        if ($result > 0 ) {
            message(1,
            printer("better crossovers", $best_mfactor,@stack[$number]));
            $improvement = 1;
        }

# Not very usefull, not value added
#        $result = randmutate($length, $length / 3,@{$stack[0]});
#        if ($result > 0 ) {
#            printer("better randmutate", $best_mfactor,@stack[0]);
#            next;
#        }
    
        if ( $improvement ) {
            print "Stack size: " . scalar(@stack) . "\n";
            print "best max mfactor " . $best_mfactor . "\n";
            print "total done " . $total . "\n";
            print "round " . $rounds;
            print "\n---\n";
        }
    
        if ( ($total % $round_size) == 0 ) {
            print "===============================\n";
            print "=== Completed Round $rounds ===\n";
            print "===============================\n";
            $rounds++;
            reinit();
            if ( $rounds == $maxrounds ) {
                last;
            }
            $r = <> if $debug > 3;
            $improvement = 1;
            print "===============================\n";
            print "=== New       Round $rounds ===\n";
            print "===============================\n";
            next;
        }
    
        $stacksize = scalar(@stack);
        if ( $stacksize > $maxstack ) {
            while ( scalar(@stack) >= 5 ) {
                pop(@stack);
            }
        }
        message(1,"$number of " . scalar(@stack) . "\n");;
        $stacksize = scalar(@stack);
        if ( (($number +2) > $stacksize) ) {
            message(1,"Start EVOLVING");
            $number = 0;
            while ( scalar(@stack) > 5 ) {
                pop(@stack);
            }
    
            foreach ( 5 .. 9 ) {
                $y = randarray();
                push(@stack,$y);
            }
    
            foreach $i ( 0 .. 4) {
                foreach $j ( 5 .. 9 ) {
                    my ($result_l,$result_r) = combine($stack[$i],$stack[$j]);
                    push(@stack,$result_l);
                    push(@stack,$result_r);
                }
            }
            message(1,"Done EVOLVING");
        }

        #pause during debugging
        $r = <> if $debug > 4;
    }
}

$debug = 0;
$round_size = 100;
$maxstack = 150;
$maxrounds = 20;
$winnercompare = 5;
init($ARGV[0]);
main();

print "\n\n\n";

print "===============================\n";
print "=== Results                 ===\n";
print "===============================\n";

$best_vector = $winners[0];
$best_mfactor = merit($best_vector);
print printer("Final", $best_mfactor,$best_vector);
print "Total parents : $total\n";
print "Total rounds  : $maxrounds\n";
print "Round parents : $round_size\n";
print "Winner compare: $winnercompare\n";
print "Max stack     : $winnercompare\n";
print "Vector size   : $length\n";