Bio::Map::PositionHandler - A Position Handler Implementation

    # This is used by modules when they want to implement being a
    # Position or being something that has Positions (when they are
    # a L<Bio::Map::EntityI>)

    # Make a PositionHandler that knows about you
    my $ph = Bio::Map::PositionHandler->new($self);

    # Register with it so that it handles your Position-related needs
    $ph->register;

    # If you are a position, get/set the map you are on and the marker you are
    # for
    $ph->map($map);
    $ph->element($marker);
    my $map = $ph->map;
    my $marker = $ph->element;

    # If you are a marker, add a new position to yourself
    $ph->add_positions($pos);

    # And then get all your positions on a particular map
    foreach my $pos ($ph->get_positions($map)) {
        # do something with this Bio::Map::PositionI
    }

    # Or find out what maps you exist on
    my @maps = $ph->get_other_entities;

    # The same applies if you were a map

  bioperl-l@bioperl.org                  - General discussion
  http://bioperl.org/wiki/Mailing_lists  - About the mailing lists

  https://redmine.open-bio.org/projects/bioperl/

 Title   : new
 Usage   : my $position_handler = Bio::Map::PositionHandler->new(-self => $self);
 Function: Get a Bio::Map::PositionHandler that knows who you are.
 Returns : Bio::Map::PositionHandler object
 Args    : -self => Bio::Map::EntityI that is you

 Title   : register
 Usage   : $position_handler->register();
 Function: Ask this Position Handler to look after your entity relationships.
 Returns : n/a
 Args    : none

 Title   : index
 Usage   : my $index = $position_handler->index();
 Function: Get the unique registry index for yourself, generated during the
           resistration process.
 Returns : int
 Args    : none

 Title   : get_entity
 Usage   : my $entity = $position_handler->get_entity($index);
 Function: Get the entity that corresponds to the supplied registry index.
 Returns : Bio::Map::EntityI object
 Args    : int

 Title   : map
 Usage   : my $map = $position_handler->map();
           $position_handler->map($map);
 Function: Get/Set the map you are on. You must be a Position.
 Returns : L<Bio::Map::MapI>
 Args    : none to get, OR
           new L<Bio::Map::MapI> to set

 Title   : element
 Usage   : my $element = $position_handler->element();
           $position_handler->element($element);
 Function: Get/Set the map element you are for. You must be a Position.
 Returns : L<Bio::Map::MappableI>
 Args    : none to get, OR
           new L<Bio::Map::MappableI> to set

 Title   : add_positions
 Usage   : $position_handler->add_positions($pos1, $pos2, ...);
 Function: Add some positions to yourself. You can't be a position.
 Returns : n/a
 Args    : Array of Bio::Map::PositionI objects

 Title   : get_positions
 Usage   : my @positions = $position_handler->get_positions();
 Function: Get all your positions. You can't be a Position.
 Returns : Array of Bio::Map::PositionI objects
 Args    : none for all, OR
           Bio::Map::EntityI object to limit the Positions to those that
           are shared by you and this other entity.

 Title   : purge_positions
 Usage   : $position_handler->purge_positions();
 Function: Remove all positions from yourself. You can't be a Position.
 Returns : n/a
 Args    : none to remove all, OR
           Bio::Map::PositionI object to remove only that entity, OR
           Bio::Map::EntityI object to limit the removal to those Positions that
           are shared by you and this other entity.

 Title   : get_other_entities
 Usage   : my @entities = $position_handler->get_other_entities();
 Function: Get all the entities that share your Positions. You can't be a
           Position.
 Returns : Array of Bio::Map::EntityI objects
 Args    : none

#
# BioPerl module for Bio::Map::PositionHandler
#
# Please direct questions and support issues to <bioperl-l@bioperl.org> 
#
# Cared for by Sendu Bala <bix@sendu.me.uk>
#
# Copyright Sendu Bala
#
# You may distribute this module under the same terms as perl itself

# POD documentation - main docs before the code

# Let the code begin...

package Bio::Map::PositionHandler;
use strict;

use base qw(Bio::Root::Root Bio::Map::PositionHandlerI);

# globally accessible hash, via private instance methods
my $RELATIONS = {};

sub new {
    my ($class, @args) = @_;
    my $self = $class->SUPER::new(@args);
    
    my ($you) = $self->_rearrange([qw(SELF)], @args);
    
    $self->throw('Must supply -self') unless $you;
    $self->throw('-self must be a reference (object)') unless ref($you);
    $self->throw('This is [$you], not a Bio::Map::EntityI object') unless $you->isa('Bio::Map::EntityI');
    $self->{_who} = $you;
    $self->{_rel} = $RELATIONS;
    return $self;
}

sub register {
    my $self = shift;
    my $you = $self->{_who};
    
    $self->throw("Trying to re-register [$you], which could be bad") if $you->get_position_handler->index;
    
    $self->{_index} = ++$self->{_rel}->{assigned_indices};
    $self->{_rel}->{registered}->{$self->{_index}} = $you;
}

sub index {
    my $self = shift;
    return $self->{_index};
}

sub get_entity {
    my ($self, $index) = @_;
    return $self->{_rel}->{registered}->{$index} || $self->throw("Requested registy index '$index' but that index isn't in the registry");
}

sub map {
    my ($self, $entity) = @_;
    return $self->_pos_get_set($entity, 'position_maps', 'Bio::Map::MapI');
}

sub element {
    my ($self, $entity) = @_;
    return $self->_pos_get_set($entity, 'position_elements', 'Bio::Map::MappableI');
}

sub add_positions {
    my $self = shift;
    $self->throw('Must supply at least one Bio::Map::EntityI') unless @_ > 0;
    my $you_index = $self->_get_you_index(0);
    my $kind = $self->_get_kind;
    
    foreach my $pos (@_) {
        $self->_check_object($pos, 'Bio::Map::PositionI');
        my $pos_index = $self->_get_other_index($pos);
        
        $self->_pos_set($pos_index, $you_index, $kind);
    }
}

sub get_positions {
    my ($self, $entity) = @_;
    my $you_index = $self->_get_you_index(0);
    
    my @positions = keys %{$self->{_rel}->{has}->{$you_index}};
    
    if ($entity) {
        my $entity_index = $self->_get_other_index($entity);
        my $pos_ref = $self->{_rel}->{has}->{$entity_index};
        @positions = grep { $pos_ref->{$_} } @positions;
    }
    
    return map { $self->get_entity($_) } @positions;
}

sub purge_positions {
    my ($self, $thing) = @_;
    my $you_index = $self->_get_you_index(0);
    my $kind = $self->_get_kind;
    
    my @pos_indices;
    if ($thing) {
        $self->throw("Must supply an object") unless ref($thing);
        if ($thing->isa("Bio::Map::PositionI")) {
            @pos_indices = ($self->_get_other_index($thing));
        }
        else {
            my $entity_index = $self->_get_other_index($thing);
            my $pos_ref = $self->{_rel}->{has}->{$entity_index};
            @pos_indices = grep { $pos_ref->{$_} } keys %{$self->{_rel}->{has}->{$you_index}};
        }
    }
    else {
        @pos_indices = keys %{$self->{_rel}->{has}->{$you_index}};
    }
    
    foreach my $pos_index (@pos_indices) {
        $self->_purge_pos_entity($pos_index, $you_index, $kind);
    }
}

sub get_other_entities {
    my $self = shift;
    my $you_index = $self->_get_you_index(0);
    my $kind = $self->_get_kind;
    my $want = $kind eq 'position_elements' ? 'position_maps' : 'position_elements';
    
    my %entities;
    while (my ($pos_index) = each %{$self->{_rel}->{has}->{$you_index}}) {
        my $entity_index = $self->{_rel}->{$want}->{$pos_index};
        $entities{$entity_index} = 1 if $entity_index;
    }
    
    return map { $self->get_entity($_) } keys %entities;
}

# do basic check on an object, make sure it is the right type
sub _check_object {
    my ($self, $object, $interface) = @_;
    $self->throw("Must supply an arguement") unless $object;
    $self->throw("This is [$object], not an object") unless ref($object);
    $self->throw("This is [$object], not a $interface") unless $object->isa($interface);
}

# get the object we are the handler of, its index, and throw depending on if
# we're a Position
sub _get_you_index {
    my ($self, $should_be_pos) = @_;
    my $you = $self->{_who};
    if ($should_be_pos) {
        $self->throw("This is not a Position, method invalid") unless $you->isa('Bio::Map::PositionI');
    }
    else {
        $self->throw("This is a Position, method invalid") if $you->isa('Bio::Map::PositionI');
    }
    return $self->index;
}

# check an entity is registered and get its index
sub _get_other_index {
    my ($self, $entity) = @_;
    $self->throw("Must supply an object") unless ref($entity);
    my $index = $entity->get_position_handler->index;
    $self->throw("Entity doesn't seem like it's been registered") unless $index;
    $self->throw("Entity may have been registered with a different PositionHandler, can't deal with it") unless $entity eq $self->get_entity($index);
    return $index;
}

# which of the position hashes should we be recorded under?
sub _get_kind {
    my $self = shift;
    my $you = $self->{_who};
    return $you->isa('Bio::Map::MapI') ? 'position_maps' : $you->isa('Bio::Map::MappableI') ? 'position_elements' : $self->throw("This is [$you] which is an unsupported kind of entity");
}

# get/set position entity
sub _pos_get_set {
    my ($self, $entity, $kind, $interface) = @_;
    my $you_index = $self->_get_you_index(1);
    
    my $entity_index;
    if ($entity) {
        $self->_check_object($entity, $interface);
        my $new_entity_index = $self->_get_other_index($entity);
        $entity_index = $self->_pos_set($you_index, $new_entity_index, $kind);
    }
    
    $entity_index ||= $self->{_rel}->{$kind}->{$you_index} || 0;
    if ($entity_index) {
        return $self->get_entity($entity_index);
    }
    return;
}

# set position entity
sub _pos_set {
    my ($self, $pos_index, $new_entity_index, $kind) = @_;
    my $current_entity_index = $self->{_rel}->{$kind}->{$pos_index} || 0;
    
    if ($current_entity_index) {
        if ($current_entity_index == $new_entity_index) {
            return $current_entity_index;
        }
        
        $self->_purge_pos_entity($pos_index, $current_entity_index, $kind);
    }
    
    $self->{_rel}->{has}->{$new_entity_index}->{$pos_index} = 1;
    $self->{_rel}->{$kind}->{$pos_index} = $new_entity_index;
    return $new_entity_index;
}

# disassociate position from one of its current entities
sub _purge_pos_entity {
    my ($self, $pos_index, $entity_index, $kind) = @_;
    delete $self->{_rel}->{has}->{$entity_index}->{$pos_index};
    delete $self->{_rel}->{$kind}->{$pos_index};
}

1;