lib/Text/Tradition/Collation/Position.pm

   1 package Text::Tradition::Collation::Position;
   2
   3 use Moose;
   4
   5 has 'common' => (
   6     is => 'rw',
   7     isa => 'Int',
   8     required => 1,
   9     );
  10
  11 has 'min' => (
  12     is => 'rw',
  13     isa => 'Int',
  14     required => 1,
  15     );
  16
  17 has 'max' => (
  18     is => 'rw',
  19     isa => 'Int',
  20     required => 1,
  21     );
  22
  23 around BUILDARGS => sub {
  24     my $orig = shift;
  25     my $class = shift;
  26
  27     # Two ways we can be called - with the arguments we expect, or with a
  28     # single argument to be parsed out into a position.
  29     my %args;
  30     if( @_ == 1 ) {
  31         my( $common, $min, $max ) = parse_reference( $_[0] );
  32         %args = ( 'common' => $common,
  33                   'min' => $min,
  34                   'max' => $max );
  35     } elsif ( 2 <= @_ && @_ <= 3 ) {
  36         my( $common, $min, $max ) = @_;
  37         $max = $min unless $max;
  38         %args = ( 'common' => $common,
  39                   'min' => $min,
  40                   'max' => $max );
  41     } else {
  42         %args = @_;
  43     }
  44
  45     return $class->$orig( %args );
  46 };
  47
  48 sub BUILD {
  49     my $self = shift;
  50     if( $self->min > $self->max ) {
  51         die "Position minimum cannot be higher than maximum";
  52     }
  53 }
  54
  55 sub parse_reference {
  56     my( $ref ) = @_;
  57     if( $ref =~ /^(\d+),(\d+)(\-(\d+))?$/ ) {
  58         my( $common, $min, $max ) = ( $1, $2, $4 );
  59         $max = $min unless defined $max;
  60         return( $common, $min, $max );
  61     } else {
  62         warn "Bad argument $ref passed to Position constructor";
  63         return undef;
  64     }
  65 }
  66
  67 # Instance method
  68 sub cmp_with {
  69     my( $self, $other ) = @_;
  70     return _cmp_bits( [ $self->common, $self->min, $self->max ],
  71                       [ $other->common, $other->min, $other->max ] );
  72 }
  73
  74 # Class method
  75 sub str_cmp {
  76     my( $a, $b ) = @_;
  77     my @abits = parse_reference( $a );
  78     my @bbits = parse_reference( $b );
  79     return _cmp_bits( \@abits, \@bbits );
  80 }
  81
  82 sub _cmp_bits {
  83     my( $a, $b ) = @_;
  84     return $a->[0] <=> $b->[0]
  85         unless $a->[0] == $b->[0];
  86     return $a->[1] <=> $b->[1]
  87         unless $a->[1] == $b->[1];
  88     return $a->[2] <=> $b->[2];
  89 }
  90
  91 sub minref {
  92     my $self = shift;
  93     return join(',', $self->common, $self->min );
  94 }
  95
  96 sub maxref {
  97     my $self = shift;
  98     return join(',', $self->common, $self->max );
  99 }
 100
 101 sub reference {
 102     my $self = shift;
 103     my $answer = join( ',', $self->common, $self->min );
 104     $answer .= '-'. $self->max unless $self->min == $self->max;
 105     return $answer;
 106 }
 107
 108 sub fixed {
 109     my $self = shift;
 110     return $self->min == $self->max;
 111 }
 112
 113 sub is_colocated {
 114     my( $self, $other, $strict ) = @_;
 115     if( $strict ) {
 116         return $self->common == $other->common
 117             && $self->min == $other->min
 118             && $self->max == $other->max;
 119     } else {
 120         return $self->common == $other->common
 121             && $self->min <= $other->max
 122             && $self->max >= $other->min;
 123     }
 124 }
 125
 126 # Return all the possible fixed position refs.
 127 sub possible_positions {
 128     my $self = shift;
 129     my @possible = map { join( ',', $self->common, $_ ) } ( $self->min .. $self->max );
 130     return @possible;
 131 }
 132
 133 no Moose;
 134 __PACKAGE__->meta->make_immutable;