#!/usr/bin/perl

use strict;
use warnings;
use Carp;

my $MAX_POP = $ENV{MAX_POP} || 64;

my @file_score = glob ('*.dom.score');

my $lookup = {};
my $seen = {};
my $fails = {};

# read all dom.score files, delete any with duplicate values build a lookup table for the rest
for my $file_score (@file_score)
{
    my $stub = $file_score;
    $stub =~ s/\.score$//x;
    open my $FILE, '<', $file_score or croak "$!";
    my @lines = <$FILE>;
    close $FILE;
    my $score = shift @lines;

    open my $FAILS, '<', "$stub.fails" or croak "$!";
    my @fails = <$FAILS>;
    close $FAILS;

    if (defined $seen->{$score})
    {
        unlink $stub;
        unlink $stub .'.score';
        unlink $stub .'.fails';
        unlink $stub .'.svg';
        unlink $stub .'.png';
        unlink $stub .'.net.dot.png';
        unlink $stub .'.tree.dot.png';
        unlink $stub .'.net.dot.svg';
        unlink $stub .'.tree.dot.svg';
        print 'Removed duplicate: '. $stub ."\n";
    }
    else
    {
        $lookup->{$stub} = $score;
        $fails->{scalar @fails}->{$stub} = $score;
        $seen->{$score} = 1;
    }
}
print "Initial population: ". scalar @file_score . "\n";
print "After duplicate removal: ". scalar keys (%{$lookup}) . "\n";

my ($A, $B, $C, $D) = sort {$a <=> $b} keys %{$fails};
# build lists of the best candidates from the first four levels of failure
my @A = sort {$fails->{$A}->{$b} <=> $fails->{$A}->{$a}} keys %{$fails->{$A}};
my @B = sort {$fails->{$B}->{$b} <=> $fails->{$B}->{$a}} keys %{$fails->{$B}};
my @C = sort {$fails->{$C}->{$b} <=> $fails->{$C}->{$a}} keys %{$fails->{$C}};
my @D = sort {$fails->{$D}->{$b} <=> $fails->{$D}->{$a}} keys %{$fails->{$D}};

# up to 1/4 reprieved population can be from second level of failure
@B = splice (@B, 0, int ($MAX_POP/4));
# up to 1/8 of reprieved population can be from third level of failure
@C = splice (@C, 0, int ($MAX_POP/8));
# up to 1/8 of reprieved population can be from fourth level of failure
@D = splice (@D, 0, int ($MAX_POP/8));

# make up rest of reprieved population from first level of failure
@A = splice (@A, 0, $MAX_POP - (scalar @B) - (scalar @C) - (scalar @D));

print "To keep: ". scalar (@A) .'+'. scalar (@B) .'+'. scalar (@C) .'+'. scalar (@D). "\n";
for my $stub (keys %{$lookup})
{
    if (grep {/^$stub$/x} @A, @B, @C, @D)
    {
        print 'Kept:    '. $stub .' '. $lookup->{$stub};
        next;
    }
    unlink $stub;
    unlink $stub .'.score';
    unlink $stub .'.fails';
    unlink $stub .'.svg';
    unlink $stub .'.png';
    unlink $stub .'.net.dot.png';
    unlink $stub .'.tree.dot.png';
    unlink $stub .'.net.dot.svg';
    unlink $stub .'.tree.dot.svg';
    print 'Croaked: '. $stub .' '. $lookup->{$stub};
}

exit 0;

__END__

=head1 NAME

urb-reap - eliminate members of a population

=head1 SYNOPSIS

urb-reap.pl

=head1 DESCRIPTION

B<urb-reap> takes all the L<Urb::Dom> objects that have been scored in the
current folder, decides which will survive for the next generation and deletes
all the rest.  Will also delete any supplementary files related to each chosen
object.

Defaults to keeping a maximum of 64 individuals, override this number with the
MAX_POP environment variable.

=head1 COPYRIGHT

Copyright (c) 2004-2013 Bruno Postle <bruno@postle.net>.

This file is part of Urb.

Urb is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

Urb is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with Urb.  If not, see <http://www.gnu.org/licenses/>.

=head1 SEE ALSO

L<Urb>

=cut

