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