+++ /dev/null
-package Text::Tradition::Collation::Position;
-
-use Moose;
-
-has 'common' => (
- is => 'rw',
- isa => 'Int',
- required => 1,
- );
-
-has 'min' => (
- is => 'rw',
- isa => 'Int',
- required => 1,
- );
-
-has 'max' => (
- is => 'rw',
- isa => 'Int',
- required => 1,
- );
-
-# This gets set if we are tracking a more specifically-positioned
-# reading.
-has 'matched' => (
- is => 'rw',
- isa => 'Bool',
- );
-
-around BUILDARGS => sub {
- my $orig = shift;
- my $class = shift;
-
- # Two ways we can be called - with the arguments we expect, or with a
- # single argument to be parsed out into a position.
- my %args;
- if( @_ == 1 ) {
- my( $common, $min, $max ) = parse_reference( $_[0] );
- %args = ( 'common' => $common,
- 'min' => $min,
- 'max' => $max );
- } elsif ( 2 <= @_ && @_ <= 3 ) {
- my( $common, $min, $max ) = @_;
- $max = $min unless $max;
- %args = ( 'common' => $common,
- 'min' => $min,
- 'max' => $max );
- } else {
- %args = @_;
- }
-
- return $class->$orig( %args );
-};
-
-sub BUILD {
- my $self = shift;
- if( $self->min > $self->max ) {
- die "Position minimum cannot be higher than maximum";
- }
-}
-
-sub parse_reference {
- my( $ref ) = @_;
- if( $ref =~ /^(\d+),(\d+)(\-(\d+))?$/ ) {
- my( $common, $min, $max ) = ( $1, $2, $4 );
- $max = $min unless defined $max;
- return( $common, $min, $max );
- } else {
- warn "Bad argument $ref passed to Position constructor";
- return undef;
- }
-}
-
-# Instance method
-sub cmp_with {
- my( $self, $other ) = @_;
- return _cmp_bits( [ $self->common, $self->min, $self->max ],
- [ $other->common, $other->min, $other->max ] );
-}
-
-# Class method
-sub str_cmp {
- my( $a, $b ) = @_;
- my @abits = parse_reference( $a );
- my @bbits = parse_reference( $b );
- return _cmp_bits( \@abits, \@bbits );
-}
-
-sub _cmp_bits {
- my( $a, $b ) = @_;
- return $a->[0] <=> $b->[0]
- unless $a->[0] == $b->[0];
- return $a->[1] <=> $b->[1]
- unless $a->[1] == $b->[1];
- return $a->[2] <=> $b->[2];
-}
-
-sub minref {
- my $self = shift;
- return join(',', $self->common, $self->min );
-}
-
-sub maxref {
- my $self = shift;
- return join(',', $self->common, $self->max );
-}
-
-sub reference {
- my $self = shift;
- my $answer = join( ',', $self->common, $self->min );
- $answer .= '-'. $self->max unless $self->min == $self->max;
- return $answer;
-}
-
-sub fixed {
- my $self = shift;
- return $self->min == $self->max;
-}
-
-sub is_colocated {
- my( $self, $other, $strict ) = @_;
- if( $strict ) {
- return $self->common == $other->common
- && $self->min == $other->min
- && $self->max == $other->max;
- } else {
- return $self->common == $other->common
- && $self->min <= $other->max
- && $self->max >= $other->min;
- }
-}
-
-# Return all the possible fixed position refs.
-sub possible_positions {
- my $self = shift;
- my @possible = map { join( ',', $self->common, $_ ) } ( $self->min .. $self->max );
- return @possible;
-}
-
-no Moose;
-__PACKAGE__->meta->make_immutable;
use Moose;
use MooseX::NonMoose;
-use Text::Tradition::Collation::Position;
extends 'Graph::Easy::Node';
-has 'position' => (
- is => 'rw',
- isa => 'Text::Tradition::Collation::Position',
- predicate => 'has_position',
- );
-
has 'rank' => (
is => 'rw',
isa => 'Int',
}
};
-# Take constructor args as well as a Position argument.
-around position => sub {
- my $orig = shift;
- my $self = shift;
- return $self->$orig() unless @_;
-
- my @args = @_;
- unless( @_ == 1 && ref( $_[0] ) eq 'Text::Tradition::Collation::Position' ) {
- # We have constructor arguments; pass them to Position.
- @args = ( Text::Tradition::Collation::Position->new( @_ ) );
- }
- $self->$orig( @args );
-};
-
# A lacuna node is also a meta node.
before is_lacuna => sub {
my( $self, $arg ) = @_;
return $self->same_as->[0];
}
-sub is_at_position {
- my $self = shift;
- return undef unless $self->has_position;
- return $self->position->is_colocated( @_ );
-}
-
# Looks from the outside like an accessor for a Boolean, but really
# sets the node's class. Should apply to start, end, and lacunae.
+++ /dev/null
-package Text::Tradition::Collation::Segment;
-
-use Moose;
-use MooseX::NonMoose;
-use Text::Tradition::Collation::Position;
-
-extends 'Graph::Easy::Node';
-
-# A segment is a special 'invisible' node that is a set of Readings.
-# We should never display these, but it is useful to have them
-# available for many-to-many relationship mappings.
-
-has 'members' => (
- is => 'rw',
- isa => 'ArrayRef[Text::Tradition::Collation::Reading]',
- required => 1,
-);
-
-has 'position' => (
- is => 'rw',
- isa => 'Text::Tradition::Collation::Position',
- predicate => 'has_position',
-);
-
-sub FOREIGNBUILDARGS {
- my $class = shift;
- my %args = @_;
-
- # Name the segment after its member elements.
- my $nodename = join( ' ', map { $_->name } @{$args{'members'}} );
- return ( 'name', $nodename );
-}
-
-sub BUILD {
- my( $self, $args ) = @_;
- $self->set_attribute( 'class', 'segment' );
- my $ctr = 1;
- foreach my $r ( @{$args->{members}} ) {
- my $seg_edge = $r->parent->add_edge( $r, $self, $ctr++ );
- $seg_edge->set_attribute( 'class', 'segment' );
- }
- unless ( grep { !$_->has_position } @{$args->{members}} ) {
- $self->set_position;
- }
-}
-
-# We use our 'members' array for the initialization, but afterward we
-# go by graph edges. This ensures that merged nodes stay merged.
-around 'members' => sub {
- my $orig = shift;
- my $self = shift;
- my @members;
- foreach my $sl ( sort { $a->name <=> $b->name }
- grep { $_->sub_class eq 'segment' } $self->incoming ) {
- push( @members, $sl->from );
- }
- return \@members;
-};
-
-sub set_position {
- my $self = shift;
- my( $common, $min, $max );
- my $readings = $self->members;
- foreach my $r ( @{$self->members} ) {
- if( $r->has_position ) {
- if( $common && $common != $r->position->common ) {
- warn "Segment adding node with position skew";
- } elsif( !$common ) {
- $common = $r->position->common;
- }
- $min = $r->position->min unless $min && $min < $r->position->min;
- $max = $r->position->max unless $max && $max > $r->position->max;
- } else {
- warn "Called set_position on segment which has an unpositioned reading";
- }
- }
- $self->position( Text::Tradition::Collation::Position->new(
- common => $common, min => $min, max => $max
- ) );
-}
-sub neighbor_readings {
- my( $self, $direction ) = @_;
- $direction = 'both' unless $direction;
- my @answer;
- if( $direction !~ /^back/ ) {
- # We want forward readings.
- push( @answer, $self->members->[0]->neighbor_readings( 'forward' ) );
- }
- if( $direction ne 'forward' ) {
- # We want backward readings.
- push( @answer, $self->members->[0]->neighbor_readings( 'back' ) );
- }
- return @answer;
-}
-
-no Moose;
-__PACKAGE__->meta->make_immutable;
-
-1;
-
-######################################################
-## copied from Graph::Easy::Parser docs
-######################################################
-# when overriding nodes, we also need ::Anon
-
-package Text::Tradition::Collation::Segment::Anon;
-use Moose;
-use MooseX::NonMoose;
-extends 'Text::Tradition::Collation::Segment';
-extends 'Graph::Easy::Node::Anon';
-no Moose;
-__PACKAGE__->meta->make_immutable;
-
-1;
-# use base qw/Text::Tradition::Collation::Segment/;
-# use base qw/Graph::Easy::Node::Anon/;
-
-######################################################
-# and :::Empty
-
-package Text::Tradition::Collation::Segment::Empty;
-use Moose;
-use MooseX::NonMoose;
-extends 'Graph::Easy::Node::Empty';
-no Moose;
-__PACKAGE__->meta->make_immutable;
-
-1;
-# use base qw/Text::Tradition::Collation::Segment/;
-
-######################################################
projects / scpubgit/stemmatology.git / commitdiff