package Urb::Dom::Mutate;

use strict;
use warnings;
use 5.010;

our $DEBUG = $ENV{DEBUG};

=head1 NAME

Urb::Dom::Mutate - Mutator for Urb::Dom objects

=head1 SYNOPSIS

A class that can be used as a mutator for domestic spaces.

=head1 DESCRIPTION

The eventual intention is to make this an Op for L<Algorithm::Evolutionary>

=head1 USAGE

=over

=item new

Create a new Urb::Dom::Mutate object:

  $mutator = new Urb::Dom::Mutate;

=cut

# FIXME need tests
sub new
{
    my $class = shift;
    $class = ref $class || $class;
    my $self = {};
    bless $self, $class;
    return $self;
}

=item apply

Mutate an L<Urb::Dom> object:

  $mutator->apply ($dom);

This applies a random mutation from the list below.

=cut

sub apply
{
    my $self = shift;
    my $dom_original = shift;
    my $dom = $dom_original->Clone;
    $dom->Clean_Cache;

    my @all = map {$_->Children} ($dom, $dom->Levels_Above);
    my $index = int rand (scalar @all);
    my $victim = $all[$index];
    debug ('mutation victim: '. $victim->Level .'/'. $victim->Id) if $DEBUG;
    if (!$victim->Parent)
    {
        debug ('  rootnode');
        my $case = int rand (8);
           if ($case == 0) {rotate ($victim)}
        elsif ($case == 1) {slide ($victim)}
        elsif ($case == 2) {swap ($victim)}
        elsif ($case == 3) {undivide ($victim)}
        elsif ($case == 4) {level_add ($victim)}
        #elsif ($case == 5) {level_add ($victim)}
        elsif ($case == 5) {level_delete ($victim)}
        elsif ($case == 6) {level_swap ($victim)}
        elsif ($case == 7) {height ($victim)}
    }
    elsif ($victim->Divided)
    {
        debug ('  branchnode');
        my $case = int rand (5);
           if ($case == 0) {rotate ($victim)}
        elsif ($case == 1) {slide ($victim)}
        elsif ($case == 2) {swap ($victim)}
        elsif ($case == 3) {undivide ($victim)}
        elsif ($case == 4) {height ($victim)}
    }
    else
    {
        debug ('  leafnode');
        my $case = int rand (3);
           if ($case == 0) {type ($victim)}
        elsif ($case == 1) {divide ($victim)}
        elsif ($case == 2) {height ($victim)}
    }

    for my $branch (reverse $dom->Branches)
        { $branch->Collapse (0.9)}

    $dom->Split_Undivided_Up;
    $dom->Highest->Split_Undivided_Down;

    return $dom;
}

sub apply_reallocate
{
    my $self = shift;
    my $dom_original = shift;
    my $dom = $dom_original->Clone;
    $dom->Clean_Cache;

    my @all = map {$_->Children} ($dom, $dom->Levels_Above);
    my $index = int rand (scalar @all);
    my $victim = $all[$index];
    debug ('mutation victim: '. $victim->Level .'/'. $victim->Id) if $DEBUG;
    type ($victim) unless $victim->Is_Outside();

    $dom->Split_Undivided_Up;
    $dom->Highest->Split_Undivided_Down;

    return $dom;
}

=item apply_rearrange

Mutate an L<Urb::Dom> object:

  $mutator->apply_rearrange ($dom);

This applies a random geometrical mutation from rotate(), slide(), swap() or height().

=cut

sub apply_rearrange
{
    my $self = shift;
    my $dom_original = shift;
    my $dom = $dom_original->Clone;
    $dom->Clean_Cache;

    my @all = map {$_->Branches} ($dom, $dom->Levels_Above);
    my $index = int rand (scalar @all);
    my $victim = $all[$index];
    debug ('mutation victim: '. $victim->Level .'/'. $victim->Id) if $DEBUG;
    my $case = int rand (4);
       if ($case == 0) {rotate ($victim)}
    elsif ($case == 1) {slide ($victim)}
    elsif ($case == 2) {swap ($victim)}
    elsif ($case == 3) {height ($victim)}

    $dom->Split_Undivided_Up;
    $dom->Highest->Split_Undivided_Down;

    return $dom;
}

=item apply_shuffle

Mutate an L<Urb::Dom> object:

  $mutator->apply_shuffle ($dom);

This applies a random height or slide() mutation.

=cut

sub apply_shuffle
{
    my $self = shift;
    my $dom_original = shift;
    my $dom = $dom_original->Clone;
    $dom->Clean_Cache;

    my @all = map {$_->Branches} ($dom, $dom->Levels_Above);
    my $index = int rand (scalar @all);
    my $victim = $all[$index];
    debug ('mutation victim: '. $victim->Level .'/'. $victim->Id) if $DEBUG;
    my $case = int rand (2);
       if ($case == 0) {height ($victim)}
    elsif ($case == 1) {slide ($victim)}

    $dom->Split_Undivided_Up;
    $dom->Highest->Split_Undivided_Down;

    return $dom;
}

=back

=head2 mutation functions for branchnodes

=over

=item rotate

Randomise the 'rotation' attribute:

  rotate ($dom);

=cut

sub rotate
{
    my $branchnode = shift;
    debug ('    rotate');
    my $case = int rand (3);
       if ($case == 0) {$branchnode->Rotate}
    elsif ($case == 1) {$branchnode->Unrotate}
    elsif ($case == 2) {$branchnode->Rotate; $branchnode->Rotate}
    $branchnode->Straighten_Recursive (int rand (4));
    return 1;
}

=item slide

Randomise the position of a division of a branchnode dom object:

  slide ($dom);

=cut

sub slide
{
    my $branchnode = shift;
    debug ('    slide division');
    # try and place new division location not near the ends
    my $length = $branchnode->Length ($branchnode->Rotation);
    return unless $length;
    my $offset = 1.25 / $length;
    my $division = $offset + ((1 - $offset - $offset) * rand);

    $branchnode->Divide ($division, $division);
    $branchnode->Straighten_Recursive (int rand (4));
    return 1;
}

=item height

Increase or decrease floor to floor height for whole level:

  height ($dom);

=cut

sub height
{
    my $branchnode = shift;
    debug ('    height');
    my $rootnode = $branchnode->Root;
    my $case = int rand (2);
       if ($case == 0) {$rootnode->{height} = $rootnode->Height + 0.15}
    elsif ($case == 1) {$rootnode->{height} = $rootnode->Height - 0.15}
    # some arbitrary limits on min/max FTF height
    $rootnode->{height} = 3.6 if ($rootnode->{height} > 3.6);
    $rootnode->{height} = 2.7 if ($rootnode->{height} < 2.7);
    return 1;
}

=item swap

Exchange the left and right children of a branchnode

  swap ($dom);

=cut

sub swap
{
    my $branchnode = shift;
    debug ('    swap');
    $branchnode->Swap;
    $branchnode->Straighten_Recursive (int rand (4));
    return 1;
}

=item undivide

Remove all children of a branchnode and assign a random type:

  undivide ($dom);

=cut

sub undivide
{
    my $branchnode = shift;
    debug ('    undivide');
    $branchnode->Undivide;
    type ($branchnode);
    return 1;
}

=item level_add level_delete level_swap

Add a duplicate level above this, other levels are shifted up.

  level_add ($dom);

Delete all levels above this:

  level_delete ($dom);

Swap this level with the level above, or below if none, or clone if single storey:

  level_swap ($dom);

=cut

sub level_add
{
    my $rootnode = shift;
    debug ('    level_add');
    $rootnode->Clone_Above;
    # we just added a top floor
    if (scalar $rootnode->Levels_Above == 1)
    {
        for my $child ($rootnode->Above->Children)
        {
            next if $child->Is_Circulation;
            $child->Type ('S') if $child->Is_Usable;
        }
    }
    return 1;
}

sub level_delete
{
    my $rootnode = shift;
    debug ('    level_delete');
    return unless defined $rootnode->Below;
    $rootnode->Below->Del_Above;
    return 1;
}

sub level_swap
{
    my $rootnode = shift;
    if (defined $rootnode->Above)
    {
        debug ('    level_swap above');
        $rootnode->Swap_Above;
    }
    elsif (defined $rootnode->Below)
    {
        debug ('    level_swap below');
        $rootnode->Below->Swap_Above;
    }
    else
    {
        debug ('    level_swap clone');
        $rootnode->Clone_Above;
    }
    return 1;
}

=back

=head2 mutation functions for leafnodes

=over

=item type

Assign a random type to a leafnode:

  type ($dom);

=cut

sub type
{
    my $leafnode = shift;
    debug ('    type');
    my @types = qw/S T C K L B O/;
    $leafnode->Type ($types[int rand (scalar @types)]);
    return 1;
}

=item divide

Split a leafnode and turn into a branchnode, assign current type to one child
and a random type to the other:

  divide ($dom);

=cut

sub divide
{
    my $leafnode = shift;
    debug ('    divide');
    slide ($leafnode);
    rotate ($leafnode);
    $leafnode->Left->Type ($leafnode->Type);
    type ($leafnode->Right);
    $leafnode->Straighten_Recursive (int rand (4));
    return 1;
}

=item debug

Any text sent to debug() gets printed to STDERR if $ENV{DEBUG} is set

=back

=cut

sub debug
{
    my @text = @_;
    return unless $DEBUG;
    say STDERR join ' ', @text;
    return 1;
}

1;
