package PiratePort;
use strict;
use utf8;
1;

sub run {
    my($interface) = @_;
    my $universe;
    if ($interface->canLoad()) {
        my $data = $interface->loadData();
        my $currentShips = [];
        my $bestShips = [];
        foreach my $ship (@{$data->{currentShips}}) {
            push(@$currentShips, Ship->new($interface, @$ship));
        }
        foreach my $ship (@{$data->{bestShips}}) {
            push(@$bestShips, Ship->new($interface, @$ship));
        }
        $universe = Universe->new($interface, $currentShips, $bestShips);
    } else {
        $universe = Universe->random($interface);
    }
    my $quit = 0;
    local $SIG{INT} = sub {
        $quit = 1;
        warn "Aborting...\n";
    };
    my $running = 1 * 24 * 60 / 3;
    while (not $quit and $running) {
        $universe->tick();
        $interface->sleep();
        $running -= 1;
    }
    $interface->saveData($universe->dump()) if $quit;
}


package Interface;
use strict;
use utf8;

sub new {
    my($class) = @_;
    return bless { }, $class;
}

# number of ships to use for breeding
sub getFamilySize {
    return 2;
}

# number of _bytes_ in DNA
sub getDNASize {
    return 1024;
}

# number of bits to mutate when spawning a new ship
sub getMutationRate {
    return 32;
}

# maximum number of instructions to run per ship per tick
sub getInstructionsPerTick {
    return 128;
}

# maximum number of bits to copy in a row before taking another parent
sub getMaxChromosomeLength {
    return 32;
}

# number of instructions to jump for JMP
sub getJumpDistance {
    return 20;
}

sub canUniverseSustainMoreShips {
    my($self, $count) = @_;
    return $count < 20;
}

# override this
sub canLoad {
    return 0;
}

# override this
sub loadData {
    die;
}

# override this
sub saveData { }

# override this
sub spawnShip {
    return (0, 0, 0);
}

# override this
sub reapShip { }

# override this
sub nukeShip { }

# override this
sub reportShipObituary { }

# override this
sub isShipDead {
    return 1;
}

# override this
sub getShipFuel {
    return 0;
}

# override this
sub getShipHealth {
    return 0;
}

# override this
sub getShipPosition {
    return (0, 0);
}

# override this
sub getShipExperience {
    return 0;
}

# override these
sub isEmptySpace { return 0; }
sub isStar { return 0; }
sub isNeutralPlanet { return 0; }
sub isEvilPlanet { return 0; }
sub isEvilStation { return 0; }
sub isEvilFleet { return 0; }
sub isAlliedFleet { return 0; }

# override these
sub moveShip { }
sub doShipAction { }

# override this
sub sleep { }


package Universe;
use strict;
use utf8;

sub new {
    my($class, $interface, $currentShips, $bestShips) = @_;
    my $self = {
        interface => $interface,
        currentShips => $currentShips,
        bestShips => $bestShips,
    };
    bless $self, $class;
    return $self;
}

sub dump {
    my($self) = @_;
    my $currentShips = [];
    foreach my $ship (@{$self->{currentShips}}) {
        push(@$currentShips, $ship->dump());
    }
    my $bestShips = [];
    foreach my $ship (@{$self->{bestShips}}) {
        push(@$bestShips, $ship->dump());
    }
    return {
        currentShips => $currentShips,
        bestShips => $bestShips,
    };
}

sub random {
    my($class, $interface) = @_;
    return $class->new($interface, [], $class->createRandomShips($interface));
}

sub createRandomShips {
    my($self, $interface) = @_;
    my $ships = [];
    foreach (1..$interface->getFamilySize()) {
        push(@$ships, Ship->random($interface));
    }
    return $ships;
}

sub spawnNewShips {
    my($self) = @_;
    if ($self->{interface}->canUniverseSustainMoreShips(scalar @{$self->{currentShips}})) {
        push(@{$self->{currentShips}}, Ship->spawn($self->{interface}, @{$self->{bestShips}}));
    }
}

sub tick {
    my($self) = @_;
    my $activeShips = [];
    foreach my $ship (@{$self->{currentShips}}) {
        if ($ship->active()) {
            $ship->update();
            $ship->execute();
            push(@$activeShips, $ship);
        } else {
            $self->reapShip($ship);
        }
    }
    $self->{currentShips} = $activeShips;
    $self->spawnNewShips();
}

sub reapShip {
    my($self, $ship) = @_;
    # score ship
    my $score = $ship->score();
    # put ship in bestShips list if necessary
    # in theory this works as follows:
    # -start at the end of the best ships array
    # -for each ship in the array, if the late ship's
    #  score is lower than the old ship, then insert the
    #  late ship just after that ship in the list
    # -otherwise, if you get to the front of the array,
    #  add it at the front
    # we do this by putting an undef as a placeholder at
    # the start of the array, and walking it backwards
    my $index = scalar @{$self->{bestShips}}; # the index of the position to insert into
    foreach my $bestShip (reverse undef, @{$self->{bestShips}}) {
        if (defined $bestShip) {
            my $bestShipScore = $bestShip->score();
        }
        if (not defined $bestShip or $score <= $bestShip->score()) {
            splice(@{$self->{bestShips}}, $index, 0, $ship);
            last;
        }
        $index -= 1; # counts down to 0, which coincides with the "undef" value
    }
    pop(@{$self->{bestShips}});

    # tell the ship its score
    $ship->reap($index);

    print "High Score Table:\n";
    $index = 1;
    foreach my $bestShip (@{$self->{bestShips}}) {
        my $bestShipScore = $bestShip->score();
        print " #$index: $bestShipScore\n";
        $index += 1; # counts down to 0, which coincides with the "undef" value
    }
    print "End.\n";
}


package Ship;
use strict;
use utf8;
require bytes;

sub new {
    my($class, $interface, $dna, $ip, $age, $distance, $xp, $fuel, $health, $bonus, $id, $x, $y, $startX, $startY) = @_;
    my $self = {
        interface => $interface,
        dna => $dna,
        ip => $ip, # instruction pointer
        age => $age,
        distance => $distance,
        xp => $xp,
        fuel => $fuel,
        health => $health,
        bonus => $bonus, # bonus score
        id => $id,
        x => $x,
        y => $y,
        startX => defined $startX ? $startX : $x,
        startY => defined $startY ? $startY : $y,
    };
    bless $self, $class;
    return $self;
}

sub dump {
    my($self) = @_;
    return [$self->{dna}, $self->{ip}, $self->{age}, $self->{distance}, $self->{xp}, $self->{fuel}, $self->{health}, $self->{bonus}, $self->{id}, $self->{x}, $self->{y}, $self->{startX}, $self->{startY}];
}

# doesn't generate a workable ship -- this ship never gets spawned in the interface
sub random {
    use bytes; # XXX on perl 5.8, use bytes::chr instead
    my($class, $interface) = @_;
    my $dna = '';
    foreach (1..$interface->getDNASize()) {
        $dna .= chr(int(rand(0x100)));
    }
    return $class->new($interface, $dna, 0, 0, 0, 0, 0, 0, 0, undef, 0, 0);
}

sub spawn {
    use bytes; # XXX on perl 5.8, use bytes::length instead
    my($class, $interface, @ships) = @_;
    # XXX assumes all ships have same DNA length (or that best ship has shortest DNA)
    my $dna = '';
    my $dnaLength = length($ships[0]->{dna}) * 8;
    my $maxChromosomeLength = $interface->getMaxChromosomeLength();
    my $bit = 0;
    while ($bit < $dnaLength) {
        my $source = $ships[int(rand(@ships))]->{dna};
        my $strandSize = int(rand($maxChromosomeLength));
        if ($bit + $strandSize > $dnaLength) {
            $strandSize = $dnaLength - $bit;
        }
        foreach (0..$strandSize) {
            # XXX there's gotta be a faster way of doing this
            vec($dna, $bit, 1) = vec($source, $bit, 1);
            $bit += 1;
        }
    }
    foreach (1..$interface->getMutationRate()) {
        vec($dna, int(rand($dnaLength)), 1) = int(rand(2));
    }
    return $class->new($interface, $dna, 0, 0, 0, 0, 0, 0, 0, $interface->spawnShip());
}

sub active {
    my($self) = @_;
    return $self->{interface}->isShipActive($self->{id});
}

sub update {
    my($self) = @_;
    my($newX, $newY) = $self->{interface}->getShipPosition($self->{id});
    my($dx, $dy) = ($self->{x} - $newX, $self->{y} - $newY);
    $self->{distance} += sqrt($dx * $dx + $dy * $dy);
    $self->{x} = $newX;
    $self->{y} = $newY;
    $self->{xp} = $self->{interface}->getShipExperience($self->{id});
    $self->{fuel} = $self->{interface}->getShipFuel($self->{id});
    $self->{health} = $self->{interface}->getShipHealth($self->{id});
    $self->{age} += 1;
    # XXX update bonus
}

sub execute {
    my($self) = @_;
    #print "SHIP $self->{id}:\n";
    foreach (0..$self->{interface}->getInstructionsPerTick()) {
        return if $self->executeInstruction();
    }
    # reap the ship, it's doing nothing
    $self->{interface}->nukeShip($self->{id});
}

# see README for more details on the instruction format
# returns 0 if no action was taken or if the action didn't affect the universe
sub executeInstruction {
    use bytes; # XXX on perl 5.8, use bytes::length instead
    my($self) = @_;
    # normalise instruction pointer (with wraparound)
    while ($self->{ip} < 0) {
        $self->{ip} += length($self->{dna});
    }
    while ($self->{ip} >= length($self->{dna})) {
        $self->{ip} -= length($self->{dna})
    }
    my $instruction = int(vec($self->{dna}, $self->{ip}, 8));
    #printf " %5d %08b  IF ", $self->{ip}, $instruction;
    $self->{ip} += 1;
    my $negate = $instruction & 0b1000_0000; # xored against condition results (reverses result if set)
    #print "NOT " if $negate;
    if ($instruction & 0b0100_0000) {
        # examine stat
        my $stat;
        if ($instruction & 0b0010_0000) {
            # fuel
            #print "FUEL ";
            $stat = $self->{fuel};
        } else {
            # health
            #print "HEALTH ";
            $stat = $self->{health};
        }
        my $cutoff = 0;
        $cutoff += 25 if $instruction & 0b0000_1000;
        $cutoff += 50 if $instruction & 0b0001_0000;
        #print "GREATER THAN $cutoff\% ";
        if ($stat <= $cutoff xor $negate) {
            #print "(false, skip)\n";
            return 0; # condition failed, no action
        }
    } else {
        my $searchFor = $instruction & 0b0011_1000 >> 3;
        #print "$searchFor VISIBLE ";
        my $found;
        if ($searchFor == 0) {
            $found = ($self->{interface}->isEmptySpace($self->{x}, $self->{y}));
        } elsif ($searchFor == 1) {
            $found = ($self->{interface}->isStar($self->{x}, $self->{y}));
        } elsif ($searchFor == 2) {
            $found = ($self->{interface}->isNeutralPlanet($self->{x}, $self->{y}));
        } elsif ($searchFor == 3) {
            $found = ($self->{interface}->isEvilPlanet($self->{x}, $self->{y}) or $self->{interface}->isEvilStation($self->{x}, $self->{y}));
        } elsif ($searchFor == 4) {
            $found = (not $self->{interface}->isEvilFleet($self->{x}, $self->{y}) and not $self->{interface}->isAlliedFleet($self->{x}, $self->{y}));
        } elsif ($searchFor == 5) {
            $found = (not $self->{interface}->isEvilFleet($self->{x}, $self->{y}) and $self->{interface}->isAlliedFleet($self->{x}, $self->{y}));
        } elsif ($searchFor == 6) {
            $found = ($self->{interface}->isEvilFleet($self->{x}, $self->{y}));
        } else {
            $found = ($self->{interface}->isEvilFleet($self->{x}, $self->{y}) > 1);
        }
        if (not $found xor $negate) {
            #print "(false, skip)\n";
            return 0; # no action
        }
    }
    # perform action
    if ($instruction & 0b0000_0100) {
        # move ship
        my $direction = $instruction & 0b0000_0011;
        #print "MOVE $direction\n";
        my $dx;
        my $dy;
        if ($direction == 0) {
            $dx = 0;
            $dy = -1;
        } elsif ($direction == 1) {
            $dx = -1;
            $dy = 0;
        } elsif ($direction == 2) {
            $dx = 1;
            $dy = 0;
        } else {
            $dx = 0;
            $dy = 1;
        }
        $self->{interface}->moveShip($self->{id}, $dx, $dy);
    } elsif ($instruction & 0b0000_0010) {
        # move instruction pointer
        $self->{ip} += ($instruction & 0b0000_0001) ? +$self->{interface}->getJumpDistance() : -$self->{interface}->getJumpDistance();
        #print "JUMP TO $self->{ip}\n";
        return 0; # doesn't count as an action
    } elsif ($instruction & 0b0000_0001) {
        # make ship do its special action (bombard, colonise, build, etc)
        #print "ACT\n";
        $self->{interface}->doShipAction($self->{id});
    } else {
        #print "IDLE\n";
    }
    return 1;
}

sub score {
    my($self) = @_;
    my($dx, $dy) = ($self->{startX} - $self->{x}, $self->{startY} - $self->{y});
    my $totalDistance += sqrt($dx * $dx + $dy * $dy);
    return $totalDistance * $totalDistance + $self->{bonus} + $self->{xp};
}

sub reap {
    my($self, $index) = @_;
    $self->{interface}->reportShipObituary($self->{id}, $self->score(), $self->{age}, $index);
    $self->{interface}->reapShip($self->{id});
    $self->{id} = undef;
}

# sub printStats {
#     use bytes; # XXX
#     my($dna) = @_;
#     my $stats = {};
#     foreach (0..length($dna)) {
#         my $data = ord(substr($dna, $_, 1));
#         $stats->{$data} += 1;
#         printf "%08b ", $data;
#     }
#     print "\n";
#     foreach (sort keys %$stats) {
#         print "$_: $stats->{$_}\n";
#     }
#     print "\n";
# }