package Urb::Quad;
use strict;
use warnings;
use 5.010;

use lib 'lib';
use Urb::Boundary;
use Urb::Math qw /distance_2d angle_2d scale_2d subtract_2d triangle_area normalise_2d points_2line line_intersection is_between_2d/;
use Graph;
use Math::Trig;
use Digest::MD5 qw/ md5_hex /;
use YAML;
use YAML::Node;
use Storable qw/ dclone /;
use Scalar::Util qw/ weaken /;

our $PI = atan2 (0,-1);

=head1 NAME

Urb::Quad - Unit of architectural space

=head1 SYNOPSIS

A fundamental unit of architectural space, four sided with straight edges. Can
be subdivided into two, forming a binary tree.

=head1 DESCRIPTION

A quad has location in 2D space, it can be a child of another quad or be a root
of a binary tree, only leafnodes are actual spaces, branchnodes are containers.

A quad can have 0 or 2 children, it has type, rotation and division attributes
which define the geometry of children.

A Root quad can have another tree attached above or below.

Not to be confused with a 'quad tree', is related to a 'KD tree'.

=head1 USAGE

=over

=item new

Create a new Urb::Quad object:

  $quad = Urb::Quad->new;
  $child = Urb::Quad->new ($quad);

=cut

sub new
{
    my $class = shift;
    $class = ref $class || $class;
    my $self = {parent => undef,
                 above => undef,
                 below => undef,
                 child => [],
                  node => [undef,undef,undef,undef],
             perimeter => {},
                  type => undef,
             occlusion => undef,
            boundaries => undef,
              rotation => 0,
             elevation => 0.0,
                height => 3.0,
              division => []};
    weaken $self->{parent};
    weaken $self->{below};
    map {weaken $self->{node}->[$_]} 0 .. 3;
    my $parent = shift || undef;
    $self->{parent} = $parent if defined $parent;
    bless $self, $class;
    return $self;
}

=item DESTROY

Due to circular-references DESTROY() never gets called automatically.
Force destruction by calling DESTROY() explicitly:

  $quad->DESTROY;

=cut

sub DESTROY
{
    my $self = shift;
    undef $self->{parent};
    undef $self->{below};
    $self->{above}->DESTROY if defined $self->{above};
    $self->{child}->[0]->DESTROY if defined $self->{child}->[0];
    $self->{child}->[1]->DESTROY if defined $self->{child}->[1];
    delete $self->{child}->[0] if defined $self->{child}->[0];
    delete $self->{child}->[1] if defined $self->{child}->[1];
    delete $self->{above} if defined $self->{above};
    map {delete $self->{$_}} keys %{$self};
    return;
}

=item Serialise

Dereference and serialise a quad object suitable for transfer or persistent storage:

  @list = $quad->Serialise;

=cut

sub Serialise
{
    my $self = shift;
    my $item = YAML::Node->new({});
    $item->{node} = [@{$self->{node}}] unless ($self->Parent or $self->Below);
    $item->{perimeter} = $self->Perimeter unless ($self->Parent or $self->Below);
    $item->{type} = $self->Type if $self->Type and not $self->Divided;
    $item->{rotation} = $self->{rotation};
    $item->{division} = [@{$self->{division}}] if $self->Divided;
    $item->{height} = $self->Height unless $self->Parent;
    $item->{elevation} = $self->Elevation unless ($self->Below or $self->Parent);

    $self->_serialise ($item);

    $item->{l} = $self->Left->Serialise if $self->Divided;
    $item->{r} = $self->Right->Serialise if $self->Divided;
    $item->{above} = $self->Above->Serialise if ((!$self->Parent) and defined $self->Above);

    return $item;
}

# stub for serialising extra sub-classed attributes
sub _serialise
{
    my $self = shift;
    my $item = shift;
    # $item->{foo} = $self->Foo;
    return;
}

=item Hash Hash_Site

Get a unique 32 hex character hash of the object useful for writing filenames etc...

  my $hash = $quad->Hash;

e.g. fa79aad6da85e0c31fee9a6b303d

This changes with the slightest alteration of a wall position etc... To get a persistent
hash for this site location (i.e. the four corner cordinates), use Hash_Site():

  my $hash_site = $quad->Hash_Site;

=cut

sub Hash
{
    my $self = shift;
    return md5_hex (YAML::Dump ($self->Serialise));
}

sub Hash_Site
{
    my $self = shift;
    my @perimeter = map {@{$_}} @{$self->Root->Lowest->{node}};
    return md5_hex (join ':', map {sprintf ("%.3f", $_)} @perimeter);
}

=item Deserialise

Retrieve a serialised quad created with Serialise():

  $quad = Urb::Quad->new;
  $quad->Deserialise (@list);

=cut

sub Deserialise
{
    my ($self, @items) = @_;
    return $self->Deserialise_Deprecated(@items) if scalar @items > 1;
    $self->_deserialise_recursive($items[0]);
}

sub _deserialise_recursive
{
    my ($self, $item) = @_;
    @{$self->{node}} = @{$item->{node}} if defined $item->{node};
    $self->{perimeter} = $item->{perimeter} if defined $item->{perimeter};
    $self->{elevation} = $item->{elevation} if defined $item->{elevation};
    $self->{elevation} = undef if ($self->Parent or $self->Below);
    $self->{height} = $item->{height} if defined $item->{height};
    $self->{type} = $item->{type} if defined $item->{type};
    $self->Rotation($item->{rotation}) if defined $item->{rotation};

    $self->_deserialise($item, $self);

    if (defined $item->{division})
    {
        $self->Divide(@{$item->{division}});
        $self->L->_deserialise_recursive($item->{l});
        $self->R->_deserialise_recursive($item->{r});
    }
    if (defined $item->{above})
    {
        $self->Add_Above;
        $self->Above->_deserialise_recursive($item->{above});
    }
    return 1;
}

sub Deserialise_Deprecated
{
    my ($self, @items) = @_;
    for my $item (@items)
    {
       my $id = $item->{id};
       my $level = 0;
       $level = $item->{level} if defined $item->{level};
       $self->Root->By_Level ($level-1) if $level > 0;
       $self->Root->By_Level ($level-1)->Add_Above if $level > 0;

       my $quad = $self->By_Level ($level)->By_Relative_Id ($id) || next;
       @{$quad->{node}} = @{$item->{node}} if (defined $item->{node} and defined $item->{node}->[0]);
       $quad->{type} = $item->{type} if $item->{type};
       $quad->Rotation ($item->{rotation}) if defined $item->{rotation};
       $quad->{perimeter} = $item->{perimeter} if defined $item->{perimeter};
       $quad->Divide (@{$item->{division}}) if defined $item->{division};
       $quad->{height} = $item->{height} if defined $item->{height};
       $quad->{elevation} = $item->{elevation} if defined $item->{elevation};
       $quad->{elevation} = undef if ($quad->Parent or $quad->Below);

       $self->_deserialise($item, $quad);
    }
    return 1;
}

# stub for deserialising extra sub-classed attributes
sub _deserialise
{
    my $self = shift;
    my ($item, $quad) = @_;
    # $quad->{foo} = $item->{foo};
    return;
}

=item Clean_Cache

Recursively clear the coordinate cache of this quad and any children:

  $quad->Clean_Cache;

=cut

#TODO test level data

sub Clean_Cache
{
    my $self = shift;
    @{$self->{node}} = (undef,undef,undef,undef) if $self->Parent;
    @{$self->{node}} = (undef,undef,undef,undef) if $self->Below;
    $self->{perimeter} = {} if $self->Parent;
    $self->{perimeter} = {} if $self->Below;
    $self->{elevation} = undef if $self->Parent;
    $self->{elevation} = undef if $self->Below;

    delete $self->{id_cache};
    $self->Above->Clean_Cache if ((!$self->Parent) and $self->Above);
    return 1 unless $self->Divided;
    $self->Left->Clean_Cache;
    $self->Right->Clean_Cache;

    # enforce data structure
    undef $self->{above} if ($self->Parent and $self->Above);
    return 1;
}

=back

=head2 Methods that modify this quad

=over

=item Divide

Divide a leafnode or change the position of a branchnode division.  Parameters
are each a ratio between 0.0 and 1.0:

  $quad->Divide (0.5, 0.6);

=item Undivide

Remove a division from a quad (if any), the resulting quad will be a leafnode,
but may not have a Type() attribute.

  $quad->Undivide;

=cut

sub Divide
{
    my ($self, @ratios) = @_;
    if (scalar @ratios) { $self->{division} = [@ratios] } else { $self->{division} = [0.5, 0.5] }
    $self->Clean_Cache;
    return if defined $self->Left;
    $self->{child}->[0] = Urb::Quad->new ($self);
    $self->{child}->[1] = Urb::Quad->new ($self);
    bless $self->{child}->[0], ref ($self);
    bless $self->{child}->[1], ref ($self);
    return 1;
}

sub Undivide
{
    my $self = shift;
    return 0 unless $self->Divided;
    $self->Left->Undivide;
    $self->Right->Undivide;
    $self->Above->Divide (@{$self->{division}}) if defined $self->Above and $self->Above->Divided;
    $self->{division} = [];
    $self->{child}->[0]->DESTROY;
    $self->{child}->[1]->DESTROY;
    delete $self->{child}->[0];
    delete $self->{child}->[1];
    return 1;
}

=item Add_Above

Add a level above, has to be top level:

  $quad->Add_Above;

=item Del_Above

Delete a level above and all levels above that:

  $quad->Del_Above;

=cut

sub Add_Above
{
    my $self = shift;
    return 0 if defined $self->Root->Above;
    $self->Root->{above} = Urb::Quad->new ();
    $self->Root->Above->{below} = $self->Root;
    bless $self->Root->{above}, ref ($self);
    return 1;
}

sub Del_Above
{
    my $self = shift;
    return 0 unless $self->Root->Above;
    $self->Root->Above->Del_Above;
    $self->Root->Above->Undivide;
    $self->Root->Above->DESTROY;
    undef $self->Root->{above};
    return 1;
}

=item Clone_Above

Add a level above, as an exact copy of current level, levels already above are
shifted up further to make space:

  $quad->Clone_Above;

=cut

sub Clone_Above
{
    my $self = shift;
    my $root = $self->Root;
    my $clone = $root->Clone;
    $root->Del_Above;
    $root->{above} = $clone;
    $root->Above->{below} = $root;
    $root->Clean_Cache;
    return 1;
}

=item Swap_Above

Swap level with level above, levels below and above this pair are retained:

  $quad->Swap_Above;

=cut

sub Swap_Above
{
    my $root = shift;
    return if $root->Parent;
    return 0 unless $root->Above;

    my $a = $root->Clone;
    $a->Del_Above;

    my $b = $root->Above->Clone;
    $b->Del_Above;

    my $c = undef;
    $c = $root->Above->Above->Clone if $root->Above->Above;

    $a->{above} = $c if defined $c;
    $a->{below} = $b;
    $b->{above} = $a;
    $b->{below} = $root->Below if $root->Below;
    $c->{below} = $a if defined $c;

    my @keys = grep {!/^(?:below|node|perimeter|occlusion|elevation|style|wall_inner|wall_outer)$/x} keys %{$root};
    $root->Undivide;
    $root->Del_Above;
    map {$root->{$_} = $b->{$_}} @keys;
    $root->Above->{below} = $root;
    $root->Below->{above} = $root if $root->Below;
    $root->Left->{parent} = $root if $root->Divided;
    $root->Right->{parent} = $root if $root->Divided;

    undef $b->{child};
    undef $b->{parent};
    undef $b->{above};
    undef $b->{below};

    $root->Clean_Cache;
    return 1;
}

=item Collapse

Remove any narrow child quad if any, parameter is minimum width.  Result is
that the other child moves up the binary tree and replaces the current quad.

  $success = $quad->Collapse (0.5);

=cut

# FIXME test needed
sub Collapse
{
    my $self = shift;
    my $width = shift;
    return 0 unless $self->Divided;
    if ($self->Left->Length_Narrowest < $width)
    {
        my $tmp = $self->Right->Clone;
        $self->Undivide;
        $self->Crossover ($tmp);
        $tmp->DESTROY;
        $self->Straighten_Recursive;
        return 1;
    }
    if ($self->Right->Length_Narrowest < $width)
    {
        my $tmp = $self->Left->Clone;
        $self->Undivide;
        $self->Crossover ($tmp);
        $tmp->DESTROY;
        $self->Straighten_Recursive;
        return 1;
    }
    return 0;
}

=item Rotate

Rotate the quad anti-clockwise by a quarter turn, all children are moved along
with it:

  $quad->Rotate;

=item Unrotate

Similarly, rotate the quad clockwise:

  $quad->Unrotate;

=cut

sub Rotate
{
    my $self = shift;
    $self->Rotation ($self->Rotation +1);
    $self->Rotation ($self->Rotation -4) while $self->Rotation > 3;
    $self->Clean_Cache;
    return 1;
}

sub Unrotate
{
    my $self = shift;
    $self->Rotation ($self->Rotation -1);
    $self->Rotation ($self->Rotation +4) while $self->Rotation < 0;
    $self->Clean_Cache;
    return 1;
}

=item Swap

Exchange the left and right children of this quad (if any):

  $success = $quad->Swap;

=cut

sub Swap
{
    my $self = shift;
    return 0 unless $self->Divided;
    $self->{child} = [$self->Right, $self->Left];
    $self->Clean_Cache;
    return 1;
}

=item Crossover

Swap everything except any parent and coordinates between any two quad objects:

  $quad->Crossover ($quad_other);

=cut

sub Crossover
{
    my $self = shift;
    my $alien = shift || return 0;

    # can't do anything if one quad is a descendant of another
    for ($alien->Parents) {return 0 if ($_ == $self)};
    for ($self->Parents) {return 0 if ($_ == $alien)};

    my $in = $alien->Clone;
    my $out = $self->Clone;

    my @keys = grep {!/^(?:below|parent|node|perimeter|occlusion|elevation)$/x} keys %{$self};

    $self->Undivide;
    $self->Del_Above unless $self->Parent;
    map {$self->{$_} = $in->{$_}} @keys;
    $self->Left->{parent} = $self if $self->Divided;
    $self->Right->{parent} = $self if $self->Divided;
    $self->Below->{above} = $self if (!$self->Parent) and $self->Below;
    $self->Above->{below} = $self if (!$self->Parent) and $self->Above;

    $alien->Undivide;
    $alien->Del_Above unless $alien->Parent;
    map {$alien->{$_} = $out->{$_}} @keys;
    $alien->Left->{parent} = $alien if $alien->Divided;
    $alien->Right->{parent} = $alien if $alien->Divided;
    $alien->Below->{above} = $alien if (!$alien->Parent) and $alien->Below;
    $alien->Above->{below} = $alien if (!$alien->Parent) and $alien->Above;

    undef $in->{child};
    undef $in->{above};
    undef $out->{child};
    undef $out->{above};

    $self->Clean_Cache;
    $alien->Clean_Cache;
    return 1;
}

=item Straighten

Align the division line of the current quad with the division line of the
parent.  Depending on rotation this will be either parallel or perpendicular to
the parent division line:

  $quad->Straighten;

=cut

sub Straighten
{
    my $self = shift;
    return 0 unless $self->Parent;
    return 0 unless $self->Divided;

    my $orientation;
    if ($self->Rotation == 0 or $self->Rotation == 2)
    { $orientation = $self->Parent->Orientation }
    else
    { $orientation = $self->Parent->Orientation_Perpendicular }

    my $line1 = points_2line ($self->Coordinate_a,
                          subtract_2d ($self->Coordinate_a, $orientation));
    my $line2 = points_2line ($self->Coordinate (2), $self->Coordinate (3));
    return 0 if ($line1->{a} == $line2->{a}); # lines are parallel
    my $intersection = line_intersection ($line1, $line2);
    my $full = subtract_2d ($self->Coordinate (2), $self->Coordinate (3));
    my $partial = subtract_2d ($intersection, $self->Coordinate (3));

    my $division;
    if (abs ($full->[0]) < abs ($full->[1]))
    { $division = ($partial->[1] / $full->[1]) }
    else
    { $division = ($partial->[0] / $full->[0]) }
    return 0 if $division <= 0;
    return 0 if $division >= 1;
    $self->{division}->[1] = $division;
    $self->Clean_Cache;
    return 1;
}

=item Straighten_Recursive

Apply Straighten() or Straighten_Root() to the current quad and all children:

  $quad->Straighten_Recursive ($reference);

The parameter is '0, 1, 2 or 3' indicating which edge you would like the
division of a root quad to use for alignment.

Note if you want to guarantee to straighten the entire binary tree then you need to
apply this to the Root() object:

  $quad->Root->Straighten_Recursive ($reference);

=cut

sub Straighten_Recursive
{
    my $self = shift;
    my $reference = shift || 0;
    for ($self->Children)
    {
        if (defined $_->Parent)
        {
            $_->Straighten;
        }
        else
        {
            $_->Straighten_Root ($reference);
            $_->Above->Straighten_Recursive ($reference) if defined $_->Above;
        }
    }
    return 1;
}

=item Straighten_Root

Align the division line of a root quad to one of the four outside edges:

  $quad->Straighten_Root ($reference);

The parameter is '0, 1, 2 or 3' indicating which edge you would like the to use
for alignment.  Note that depending on rotation this will be either parallel or
perpendicular to the specified edge.

=cut

sub Straighten_Root
{
    my $self = shift;
    my $reference = shift || 0;
    return 0 unless $self->Divided;
    return 0 if $self->Parent;
    my $orientation = subtract_2d ($self->Coordinate (0 + $reference), $self->Coordinate (1 + $reference));
    normalise_2d ($orientation);
    $orientation = [0-$orientation->[1], $orientation->[0]] if ($reference == 0 or $reference == 2);

    my $line1 = points_2line ($self->Coordinate_a,
                          subtract_2d ($self->Coordinate_a, $orientation));
    my $line2 = points_2line ($self->Coordinate (2), $self->Coordinate (3));
    return 0 if ($line1->{a} == $line2->{a}); # lines are parallel
    my $intersection = line_intersection ($line1, $line2);
    my $full = subtract_2d ($self->Coordinate (2), $self->Coordinate (3));
    my $partial = subtract_2d ($intersection, $self->Coordinate (3));
    my $division;
    if ($full->[0] == 0)
    { $division = ($partial->[1] / $full->[1]) }
    else
    { $division = ($partial->[0] / $full->[0]) }
    return 0 if $division <= 0;
    return 0 if $division >= 1;
    $self->{division}->[1] = $division;
    $self->Clean_Cache;
    return 1;
}

=item Shift

Shift the position of a quad by X, Y (and optionally Z)

  $quad->Shift (3.0, 4.0);

=cut

sub Shift
{
    my ($self, $x, $y, $z) = @_;
    my $root = $self->Root->Lowest;
    for my $id (0 .. 3)
    {
        $root->{node}->[$id]->[0] += $x;
        $root->{node}->[$id]->[1] += $y;
    }
    $root->{elevation} = $root->Elevation + $z if defined $z;
    $root->Clean_Cache;
    return 1;
}

=back

=head2 Methods that return an Urb::Quad object

=over

=item Clone

Create a duplicate of any quad creating a new binary tree, if this is not a root node
then the quad is converted into a root.

  $clone = $quad->Clone;

=cut

sub Clone
{
    my $self = shift;
    my @coor = map {$self->Coordinate ($_)} (0 .. 3);
    my $new = dclone ($self);
    unless (defined $new->{node}->[0]->[0])
    {
        @{$new->{node}} = @coor;
        $new->Rotation (0);
    }
    if ($new->Parent)
    {
        my $parent = $new->Parent;
        if ($new == $parent->Left)
        {
            $parent->Right->Undivide;
            $parent->Right->DESTROY;
        }
        if ($new == $parent->Right)
        {
            $parent->Left->Undivide;
            $parent->Left->DESTROY;
        }
        $parent->{child} = [];
        my $lowest = $parent->Root->Lowest;
        $lowest->Del_Above;
        $lowest->Undivide;
        $lowest->DESTROY;
    }
    elsif ($new->Below)
    {
        my $below = $new->Below;
        $below->{above} = undef;
        my $lowest = $below->Root->Lowest;
        $lowest->Del_Above;
        $lowest->Undivide;
        $lowest->DESTROY;
    }

    $new->{parent} = undef;
    $new->{below} = undef;
    return $new;
}

=item Left L Right R

Access the immediate children:

  $child = $quad->Left;
  $child = $quad->L;

  $child = $quad->Right;
  $child = $quad->R;

L() and R() are aliases for Left() and Right()

=cut

sub Left
{
    my $self = shift;
    return $self->{child}->[0] if $self->Divided;
    return;
}

sub L
{
    my $self = shift;
    return $self->Left;
}

sub Right
{
    my $self = shift;
    return $self->{child}->[1] if $self->Divided;
    return;
}

sub R
{
    my $self = shift;
    return $self->Right;
}

=item Above Below Lowest Highest

Returns the quad directly above or below current

  $above = $quad->Above;
  $below = $quad->Below;
  $lowest = $quad->Lowest;
  $highest = $quad->Highest;

  $groundfloor = $quad->Lowest->Root;
  $groundfloor = $quad->Root->Lowest;
  $topfloor = $quad->Root->Highest;

=cut

sub Above
{
    my $self = shift;
    return $self->{above} if (defined $self->{above} and (!$self->Parent));
    return unless defined $self->Root->{above};
    return $self->Root->Above->By_Id ($self->Id) if defined $self->Root->Above->By_Id ($self->Id);
    return;
}

sub Below
{
    my $self = shift;
    return $self->{below} if (defined $self->{below} and (!$self->Parent));
    return unless defined $self->Root->{below};
    return $self->Root->Below->By_Id ($self->Id) if defined $self->Root->Below->By_Id ($self->Id);
    return;
}

sub Lowest
{
    my $self = shift;
    return $self unless defined $self->Below;
    return $self->Below->Lowest;
}

sub Highest
{
    my $self = shift;
    return $self unless defined $self->Above;
    return $self->Above->Highest;
}

=item Below_More Above_More

There may not be a matching quad above or below, so retrieve the quad above or
below the parent if necessary:

=cut

sub Below_More
{
    my $self = shift;
    return () unless scalar $self->Root->Levels_Below;
    return $self->Below if defined $self->Below;
    return $self->Parent->Below_More;
}

sub Above_More
{
    my $self = shift;
    return () unless scalar $self->Root->Levels_Above;
    return $self->Above if defined $self->Above;
    return $self->Parent->Above_More;
}

=item Below_Leafs Above_Leafs

Get a list of all leafs below or above this one, note that a single leaf may be
same size or larger than the current quad:

  @quad = $quad->Below_Leafs;

  @quad = $quad->Above_Leafs;

=cut

sub Below_Leafs
{
    my $self = shift;
    return map {$_->Leafs} $self->Below_More;
}

sub Above_Leafs
{
    my $self = shift;
    return map {$_->Leafs} $self->Above_More;
}

=item Below_Children Above_Children

Get a list of all children below or above this one, note that a single child may be
same size or larger than the current quad:

  @quad = $quad->Below_Children;

  @quad = $quad->Above_Children;

=cut

sub Below_Children
{
    my $self = shift;
    return map {$_->Children} $self->Below_More;
}

sub Above_Children
{
    my $self = shift;
    return map {$_->Children} $self->Above_More;
}


=item Vertical_Connection

Get the floor area that connects two quads (not necessarily leafs).  Returns
0.0 if quads are not on adjacent levels, or if quads don't overlap vertically.

  $area = $quad_a->Vertical_Connection ($quad_b);

=cut

sub Vertical_Connection
{
    my $self = shift;
    my $other = shift || return;
    return 0.0 unless abs ($self->Level - $other->Level) == 1;
    my @overlappers = ($self->Below_Children, $self->Above_Children);
    return 0.0 unless grep {$other} @overlappers;
    my @areas = ($self->Area, $other->Area);
    @areas = sort {$a <=> $b} @areas;
    return shift @areas;
}

=item Parent

Access the parent of the current quad:

  $parent = $quad->Parent;

=item Root

Access the root quad of this binary tree:

  $quad_root = $quad->Root;

=cut

sub Parent
{
    my $self = shift;
    return $self->{parent} if defined $self->{parent};
    return;
}

sub Root
{
    my $self = shift;
    return $self unless defined $self->Parent;
    return $self->Parent->Root;
}

=item By_Relative_Id

Access a descendant quad by name:

  $quad_a = $quad->By_Relative_Id ('rlrrrl');

This is relative, so 'l' is a child of $quad not the root-level quad with id = 'l'

This is equivalent to this:

  $quad_a = $quad->R->L->R->R->R->L;

=cut

sub By_Relative_Id
{
    my $self = shift;
    my $id = shift || '';
    return if ((!$self->Divided) and $id =~ /^[lr]+$/x);
    return $self->Left if $id eq 'l';
    return $self->Right if $id eq 'r';
    return $self unless $id =~ /^[lr]+$/x;
    my @split = $id =~ /^([lr])([lr]+)$/x;
    return $self->Left->By_Relative_Id ($split[1]) if $split[0] eq 'l';
    return $self->Right->By_Relative_Id ($split[1]) if $split[0] eq 'r';
    return;
}

=item By_Relative_Level

Access a level by name:

   $quad_a = $quad->By_Relative_Level (-1);

=cut

sub By_Relative_Level
{
    my $self = shift;
    my $id = shift || return $self;
    if ($id < 0)
    {
        return $self->Below->By_Relative_Level ($id +1);
    }
    else
    {
        return $self->Above->By_Relative_Level ($id -1);
    }
}

=item By_Id

Access another quad in the binary tree by name:

  $quad_a = $quad->By_Id ('rlrrrl');

This is absolute, so '' is root level $quad

This is equivalent to:

  $quad_a = $quad->Root->R->L->R->R->R->L;

=cut

sub By_Id
{
    my $self = shift;
    my $id = shift;
    return $self->Root->By_Relative_Id ($id);
}

=item By_Level

Access a level by absolute name:

  $quad_a = $quad->By_Level (2);

=cut

sub By_Level
{
    my $self = shift;
    my $id = shift;
    return $self->Lowest->By_Relative_Level ($id);
}

=back

=head2 Methods that return lists of Urb::Quad objects

=over

=item Parents

Get a list of parent quads, starting with the current parent all the way up to the root.

  @quad = $quad->Parents;

=cut

sub Parents
{
    my ($self, @parents) = @_;
    return @parents unless defined $self->Parent;
    push @parents, $self->Parent;
    return $self->Parent->Parents (@parents);
}

=item Levels_Below Levels_Above

Get a list of quads below or above this one:

  @levels_below = $quad->Levels_Below;
  @levels_above = $quad->Levels_Above;

=cut

sub Levels_Below
{
    my ($self, @levels_below) = @_;
    return @levels_below unless defined $self->Root->Below;
    push @levels_below, $self->Root->Below;
    return $self->Root->Below->Levels_Below (@levels_below);
}

sub Levels_Above
{
    my ($self, @levels_above) = @_;
    return @levels_above unless defined $self->Above;
    push @levels_above, $self->Above;
    return $self->Above->Levels_Above (@levels_above);
}

=item Leafs

Get a list of all leafnode quads, including self if necessary, i.e. not
branches:

  @quad = $quad->Leafs;

=item Branches

Get a list of all branchnode quads, including self if necessary, i.e. not
leafs:

  @quad = $quad->Branches;

=item Children

Get a list of all child quads, both leafnode and branchnode, including self if
necessary:

  @quad = $quad->Children;

=cut

sub Leafs
{
    my $self = shift;
    return $self unless $self->Divided;
    return ($self->Left->Leafs, $self->Right->Leafs);
}

sub Branches
{
    my $self = shift;
    return $self if ((!defined $self->Parent) and (!$self->Divided));
    return () unless $self->Divided;
    return ($self, $self->Left->Branches, $self->Right->Branches);
}

sub Children
{
    my $self = shift;
    return $self unless $self->Divided;
    return ($self, $self->Left->Children, $self->Right->Children);
}

=back

=head2 Methods for accessing a list of messages

=over

=item Fail_Reset

Remove all messages:

  $quad->Root->Fail_Reset;

=item Fail

Add a new message:

  $quad->Root->Fail ('All the colours are wrong!');

=item Failures

Retrieve a list of all messages:

  @failures = $quad->Root->Failures;

=cut

sub Fail_Reset
{
    my $self = shift;
    $self->{fail} = [];
    return;
}

sub Fail
{
    my $self = shift;
    my $message = shift;
    push @{$self->{fail}}, $message;
    return;
}

sub Failures
{
    my $self = shift;
    return @{$self->{fail}};
}

=back

=head2 Methods for querying the quad

=over

=item Type

What is the 'type' of the quad (a string not a class name):

  $string = $quad->Type;

=cut

sub Type
{
    my $self = shift;
    my $type = shift || undef;
    $self->{type} = $type if defined $type;
    return $self->{type} if defined $self->{type};
    return '';
}

=item Level

What is the level (0, 1, 2, ...)

  $level = $quad->Level;

=cut

sub Level
{
    my $self = shift;
    return scalar $self->Root->Levels_Below;
}

=item Perimeter

Access the Perimeter definition, this is stored in the lowest root, generally
read-only:

  my $hash = $quad->Perimeter;

=cut

sub Perimeter
{
    my $self = shift;
    return $self->Root->{perimeter} unless $self->Root->Below;
    return $self->Root->Below->Perimeter;
}

=item Divided

Does the quad have children:

  $bool = $quad->Divided;

=cut

sub Divided
{
    my $self = shift;
    return 0 unless defined $self->{division}->[0];
    return 0 unless defined $self->{child}->[0];
    return 0 unless defined $self->{child}->[1];
    return 1;
}

=item Aspect

What is the aspect ratio of the quad:

  $ratio = $quad->Aspect;

This is always greater than 1.0, 1.0 is equivalent to a 1:1 aspect ratio, 2.0
is equal to 2:1 etc...

=cut

sub Aspect
{
    my $self = shift;
    my $aspect = ($self->Length (0) + $self->Length (2)) /
                 ($self->Length (1) + $self->Length (3));
    $aspect = 1 / $aspect if ($aspect < 1 and $aspect > 0);
    return $aspect;
}

=item Rotation

Query the rotation of the quad

=cut

#TODO tests

sub Rotation
{
    my $self = shift;
    my $rotation = shift || undef;
    if (defined $rotation)
    {
        $self->{rotation} = $rotation;
        $self->Clean_Cache;
    }
    $self->{rotation} += 4 while $self->{rotation} < 0;
    $self->{rotation} -= 4 while $self->{rotation} > 3;
    return $self->Below->Rotation if defined $self->Below;
    return $self->{rotation};
}

=item Height Elevation

Query the height or elevation of this level:

  my $floor_to_floor = $quad->Height;
  my $floor_level = $quad->Elevation;

=cut

sub Height
{
    my $self = shift;
    return $self->Root->{height} if defined $self->Root->{height};
    return 3.0;
}

sub Elevation
{
    my $self = shift;
    my $root = $self->Root;
    unless ($root->Below)
    {
        return $root->{elevation} if defined $root->{elevation};
        return 0.0;
    }
    return $root->Below->Elevation + $root->Below->Height;
}

=item Area

Query the area of a quad:

  $area = $quad->Area;

=cut

sub Area
{
    my $self = shift;
    return triangle_area ($self->Coordinate (0), $self->Coordinate (1), $self->Coordinate (2)) +
           triangle_area ($self->Coordinate (0), $self->Coordinate (2), $self->Coordinate (3));
}

=item Position

Query the position of the current quad (i.e. is it the left or right child):

  $id = $quad->Position;

Answer is always 'l' or 'r', or '' for the root quad;

=item Id

Query the address of the current quad relative to the root:

  $string = $quad->Id;

The root level quad is '', children of this are 'l' and 'r', children of 'r'
are 'rl' and 'rr' etc...

This string is usable as the parameter for By_Id().

=cut

sub Position
{
    my $self = shift;
    return '' unless defined $self->Parent;
    return 'l' if ($self == $self->Parent->Left);
    return 'r' if ($self == $self->Parent->Right);
    return;
}

sub Id
{
    my $self = shift;
    return '' unless defined $self->Parent;
    $self->{id_cache} = $self->Parent->Id . $self->Position unless defined $self->{id_cache};
    return $self->{id_cache};
}

=item Corners_In_Use

Given a list of neighbours, return the smallest set of corner ids that coincide
with these neighbours, i.e. where we can't put a stair:

  @ids = $quad->Corners_In_Use ($graph, @neighbours);

Note ids are always consecutive, but may be > 3

=cut

sub Corners_In_Use
{
    my ($self, $graph, @neighbours) = @_;

    my @walls = map {$graph->get_edge_attribute ($self, $_, 'coordinates')} @neighbours;
    my @corners = map {$self->Coordinate ($_)} (0 .. 3);

    # try single corners
    for my $id (0 .. 3)
    {
        my $ok = 1;
        for my $wall (@walls)
        {
            next if is_between_2d ($corners[$id], @{$wall});
            $ok = 0;
        }
        return ($id) if $ok;
    }

    # try pairs of corners
    for my $id (0 .. 3)
    {
        my $ok = 1;
        for my $wall (@walls)
        {
            next if is_between_2d ($corners[$id], @{$wall});
            next if is_between_2d ($corners[$id+1], @{$wall});
            next if is_between_2d ($wall->[0], $corners[$id], $corners[$id+1]);
            next if is_between_2d ($wall->[1], $corners[$id], $corners[$id+1]);
            $ok = 0;
        }
        return ($id, $id+1) if $ok;
    }

    # try three corners
    for my $id (0 .. 3)
    {
        my $ok = 1;
        for my $wall (@walls)
        {
            next if is_between_2d ($corners[$id], @{$wall});
            next if is_between_2d ($corners[$id+1], @{$wall});
            next if is_between_2d ($corners[$id+2], @{$wall});
            next if is_between_2d ($wall->[0], $corners[$id], $corners[$id+1]);
            next if is_between_2d ($wall->[1], $corners[$id], $corners[$id+1]);
            next if is_between_2d ($wall->[0], $corners[$id+1], $corners[$id+2]);
            next if is_between_2d ($wall->[1], $corners[$id+1], $corners[$id+2]);
            $ok = 0;
        }
        return ($id, $id+1, $id+2) if $ok;
    }

    # then it must be all four corners
    return (0, 1, 2, 3);
}

=back

=head2 Methods for querying points of a quad

=over

=item Coordinate

Corner coordinates, number increments anti-clockwise. Number changes with
rotation:

  $coor = $quad->Coordinate (0);
  $coor = $quad->Coordinate (1);
  $coor = $quad->Coordinate (2);
  $coor = $quad->Coordinate (3);

=cut

#TODO test levels

sub Coordinate
{
    my $self = shift;
    my $id = shift;
    return $self->Below->Coordinate ($id) if (defined $self->Below);
    $id += $self->Rotation;
    $id -= 4 while $id > 3;
    $id += 4 while $id < 0;
    return [@{$self->{node}->[$id]}] if defined $self->{node}->[$id];

    # just return rotated coordinates if this is the root-level quad
    return [@{$self->{node}->[$id]}] unless defined $self->Parent;

    my $result;
    # it isn't root level so get coordinates from parent
    if ($self->Position eq 'l')
    {
        $result = $self->Parent->Coordinate (0) if $id == 0;
        $result = $self->Parent->Coordinate_a if $id == 1;
        $result = $self->Parent->Coordinate_b if $id == 2;
        $result = $self->Parent->Coordinate (3) if $id == 3;
    }
    if ($self->Position eq 'r')
    {
        $result = $self->Parent->Coordinate_a if $id == 0;
        $result = $self->Parent->Coordinate (1) if $id == 1;
        $result = $self->Parent->Coordinate (2) if $id == 2;
        $result = $self->Parent->Coordinate_b if $id == 3;
    }
    $self->{node}->[$id] = $result;
    return $result;
}

=item Coordinate_Offset

The same, but offset by specified distance, positive is outside, negative is inside:

  $coor = $quad->Coordinate (2, $distance);

When used without an offset, behaviour is identical to Coordinate():

  is_deeply ($quad->Coordinate (2), $quad->Coordinate_Offset (2));

=cut

sub Coordinate_Offset
{
    my $self = shift;
    my $id = shift;
    my $offset = shift || return $self->Coordinate ($id);

    my $b_coor = $self->Coordinate ($id);
    my $c_coor = $self->Coordinate ($id +1);

    my $theta2 = $self->Angle ($id) /2;
    my $angle_new = angle_2d ($b_coor, $c_coor) + $theta2;
    my $vector = scale_2d ($offset / sin ($theta2), [cos ($angle_new), sin ($angle_new)]);
    return subtract_2d ($b_coor, $vector);
}

=item Min Max

Query bounding box:

  $coor = $quad->Min;
  $coor = $quad->Max;

Used for determining bounding box for drawing operations, coordinate may be
outside quad.

=cut

sub Min
{
    my $self = shift;
    my $coor_min = [@{$self->Coordinate (0)}];
    for my $coor (map {$self->Coordinate ($_)} (1 .. 3))
    {
        $coor_min->[0] = $coor->[0] if ($coor->[0] < $coor_min->[0]);
        $coor_min->[1] = $coor->[1] if ($coor->[1] < $coor_min->[1]);
    }
    return $coor_min;
}

sub Max
{
    my $self = shift;
    my $coor_max = [@{$self->Coordinate (0)}];
    for my $coor (map {$self->Coordinate ($_)} (1 .. 3))
    {
        $coor_max->[0] = $coor->[0] if ($coor->[0] > $coor_max->[0]);
        $coor_max->[1] = $coor->[1] if ($coor->[1] > $coor_max->[1]);
    }
    return $coor_max;
}

=item Coordinate_a Coordinate_b

Query cooridinates of the ends of the division

  $coor = $quad->Coordinate_a;
  $coor = $quad->Coordinate_b;

=cut

sub Coordinate_a
{
    my $self = shift;
    return unless $self->Divided;
    return $self->Below->Coordinate_a if (defined $self->Below and $self->Below->Divided);
    my $temp = $self->{division}->[0];
    my $x = ($self->Coordinate (0)->[0] * (1-$temp))
          + ($self->Coordinate (1)->[0] * $temp);
    my $y = ($self->Coordinate (0)->[1] * (1-$temp))
          + ($self->Coordinate (1)->[1] * $temp);
    return [$x, $y];
}

sub Coordinate_b
{
    my $self = shift;
    return unless $self->Divided;
    return $self->Below->Coordinate_b if (defined $self->Below and $self->Below->Divided);
    my $temp = $self->{division}->[1];
    my $x = ($self->Coordinate (3)->[0] * (1-$temp))
          + ($self->Coordinate (2)->[0] * $temp);
    my $y = ($self->Coordinate (3)->[1] * (1-$temp))
          + ($self->Coordinate (2)->[1] * $temp);
    return [$x, $y];
}

=item Centroid

Query the centroid of the quad:

  $coor = $quad->Centroid;

=cut

sub Centroid
{
    my $self = shift;
    my $p0 = $self->Coordinate (0);
    my $p1 = $self->Coordinate (1);
    my $p2 = $self->Coordinate (2);
    my $p3 = $self->Coordinate (3);

    return [($p0->[0] + $p1->[0] + $p2->[0] + $p3->[0])/4,
            ($p0->[1] + $p1->[1] + $p2->[1] + $p3->[1])/4];
}

=item Orientation

Get a normalised vector parallel to the current division:

  $vector_normalised = $quad->Orientation;

=item Orientation_Perpendicular

..or perpendicular:

  $vector_normalised = $quad->Orientation_Perpendicular;

=cut

sub Orientation
{
    my $self = shift;
    my $vector = subtract_2d ($self->Coordinate_b, $self->Coordinate_a);
    return normalise_2d ($vector);
}

sub Orientation_Perpendicular
{
    my $self = shift;
    my $orientation = $self->Orientation;
    return [0-$orientation->[1], $orientation->[0]];
}

=back

=head2 Methods for querying edges of a quad

=over

=item Angle

Query the corner angles of the quad, angles are radians:

  $radians = $quad->Angle (0);
  $radians = $quad->Angle (1);
  $radians = $quad->Angle (2);
  $radians = $quad->Angle (3);

=cut

sub Angle
{
    my $self = shift;
    my $id = shift;
    my $a = $self->Length ($id);
    my $b = $self->Length ($id -1);
    my $c = distance_2d ($self->Coordinate ($id +1), $self->Coordinate ($id -1));
    # cosine rule
    return acos (($a**2 + $b**2 - $c**2) / (2 * $a * $b));
}

=item Bearing

Query the bearing in radians perpendicular to an edge, i.e. 0.0 is due east 1.57 is due north.

  $radians = $quad->Bearing ($id);

=cut

sub Bearing
{
    my $self = shift;
    my $id = shift;
    my $vector = subtract_2d ($self->Coordinate ($id +1), $self->Coordinate ($id));
    my $bearing = atan2 ($vector->[1], $vector->[0]);
    $bearing -= $PI/2;
    $bearing += 2*$PI while ($bearing < 0.0);
    $bearing -= 2*$PI while ($bearing > 2*$PI);
    return $bearing;
}

=item Middle

Query the mid point of an edge half way up:

  $coor = $quad->Middle ($id);

=cut

sub Middle
{
    my $self = shift;
    my $id = shift;
    my $coor_a = $self->Coordinate ($id);
    my $coor_b = $self->Coordinate ($id +1);
    return [($coor_a->[0] + $coor_b->[0])/2, ($coor_a->[1] + $coor_b->[1])/2, $self->Elevation + ($self->Height/2)];
}

=item Length

Query the edge lengths of a quad:

  $scalar = $quad->Length (0);
  $scalar = $quad->Length (1);
  $scalar = $quad->Length (2);
  $scalar = $quad->Length (3);

=cut

sub Length
{
    my $self = shift;
    my $id = shift || 0;
    return distance_2d ($self->Coordinate ($id), $self->Coordinate ($id + 1));
}

=item Length_Narrowest

Get the shortest of the four lengths:

  $scalar = $quad->Length_Narrowest;

=cut

# FIXME test needed
sub Length_Narrowest
{
    my $self = shift;
    my @ids = $self->By_Length;
    return $self->Length ($ids[0]);
}

=item By_Length

Get all four lengths, shortest first:

  @id_edges = $quad->By_Length;

=cut

sub By_Length
{
    my $self = shift;
    my @id_edges = sort {$self->Length ($a) <=> $self->Length ($b)} (0,1,2,3);
    return @id_edges;
}

=item Boundary_Id

Query the boundary id of the four edges:

  $string = $quad->Boundary_Id (0);
  $string = $quad->Boundary_Id (1);
  $string = $quad->Boundary_Id (2);
  $string = $quad->Boundary_Id (3);

Note that this is equivalent to the Id of whichever quad provides the division
that forms this boundary. If boundary is an outside boundary of the root quad
then 'a, b, c or d' is returned.

=cut

sub Boundary_Id
{
    my $self = shift;
    my $id = shift || 0;
    $id += $self->Rotation;
    $id -= 4 while $id > 3;
    $id += 4 while $id < 0;
    # return abcd if this is the root-level quad
    unless (defined $self->Parent)
    {
        return 'a' if $id == 0;
        return 'b' if $id == 1;
        return 'c' if $id == 2;
        return 'd' if $id == 3;
    }
    # it isn't root level so get boundary id from parent
    if ($self->Position eq 'l')
    {
        return $self->Parent->Boundary_Id (0) if $id == 0;
        return $self->Parent->Id if $id == 1;
        return $self->Parent->Boundary_Id (2) if $id == 2;
        return $self->Parent->Boundary_Id (3) if $id == 3;
    }
    if ($self->Position eq 'r')
    {
        return $self->Parent->Boundary_Id (0) if $id == 0;
        return $self->Parent->Boundary_Id (1) if $id == 1;
        return $self->Parent->Boundary_Id (2) if $id == 2;
        return $self->Parent->Id if $id == 3;
    }
    return;
}

=back

=head2 Methods that return other structures

=over

=item By_Area

Get a list of quads sorted by area nearest to a specified value, e.g. quads
with an area most similar to 10.0:

  @list = $quad->By_Area (10.0);

Each entry is [$ratio, $quad_ref];

=cut

sub By_Area
{
    my $self = shift;
    my $area_ref = shift || 0.0001;
    my @list;
    for my $quad (map {$_->Children} $self->Root, $self->Root->Levels_Above)
    {
        my $area = $quad->Area;
        my $ratio = $area / $area_ref;
        $ratio = 1 / $ratio if $ratio < 1;
        push @list, [$ratio, $quad];
    }
    return [sort {$a->[0] <=> $b->[0]} @list];
}

=item Calc_Boundaries

Figure out all the boundaries:

  $hash = $quad->Calc_Boundaries;

Returns a hash of L<Urb::Boundary> objects, keys are boundary Ids

=cut

sub Calc_Boundaries
{
    my $self = shift;
    my $boundaries = {};

    $boundaries->{$_->Id} = Urb::Boundary->new for ($self->Branches);
    $boundaries->{$_} = Urb::Boundary->new for (qw/a b c d/);

    for my $quad ($self->Leafs)
    {
        for my $edge (0 .. 3)
        {
            $boundaries->{$quad->Boundary_Id ($edge)}->Add_Edge ($quad, $edge);
        }
    }

    $self->{boundaries} = $boundaries;
    return $boundaries;
}

=item Graph

Figure out topology of connections between quads, this is an undirected graph
and completely different to the binary tree of the structure:

  $threshold = 1.25;
  $graph = $quad->Graph ($threshold);

Returns a L<Graph> object representing the adjacentness of leafs.

Note that this is currently very slow.

=cut

sub Graph
{
    my $self = shift;
    my $threshold = shift || 0.001;
    my $boundaries = $self->Calc_Boundaries;
    my $graph = Graph::->new (undirected => 1, refvertexed => 1);
    for my $boundary_id (keys %{$boundaries})
    {
        my $boundary = $boundaries->{$boundary_id};
        for my $pair (@{$boundary->Pairs})
        {
            my $overlap = $boundary->Overlap (@{$pair});
            next if $overlap < $threshold;
            $graph->add_weighted_edge (@{$pair}, distance_2d (map {$_->Centroid} @{$pair}));
            $graph->set_edge_attribute (@{$pair}, 'coordinates', [$boundary->Coordinates (@{$pair})]);
            $graph->set_edge_attribute (@{$pair}, 'width', $overlap);
        }
    }
    $graph->add_vertex ($self) unless scalar ($graph->vertices);
    return $graph;
}

sub Graph::clone
{
    my $graph_in = shift;
    my $graph_out = Graph::->new (undirected => 1, refvertexed => 1);
    for my $pair ($graph_in->edges)
    {
        $graph_out->add_weighted_edge (@{$pair}, $graph_in->get_edge_weight (@{$pair}));
        $graph_out->set_edge_attributes (@{$pair}, $graph_in->get_edge_attributes (@{$pair}));
    }
    return $graph_out;
}

# get a list of all quads sorted by average path length to all other quads

sub Graph::sorted_apl
{
    my $graph = shift;
    my @sorted = sort {($graph->average_path_length ($a, undef) || 0)
                   <=> ($graph->average_path_length ($b, undef) || 0)} ($graph->vertices);
    return @sorted;
}

=back

=head1 COPYRIGHT

Copyright (c) 2004-2011 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/>.

=cut

1;

