Commit | Line | Data |
45456358 |
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; |