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 | |
4cdd82f1 |
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 | |
45456358 |
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 ) { |
910a0a6d |
38 | my( $common, $min, $max ) = parse_reference( $_[0] ); |
39 | %args = ( 'common' => $common, |
40 | 'min' => $min, |
41 | 'max' => $max ); |
45456358 |
42 | } elsif ( 2 <= @_ && @_ <= 3 ) { |
910a0a6d |
43 | my( $common, $min, $max ) = @_; |
44 | $max = $min unless $max; |
45 | %args = ( 'common' => $common, |
46 | 'min' => $min, |
47 | 'max' => $max ); |
45456358 |
48 | } else { |
910a0a6d |
49 | %args = @_; |
45456358 |
50 | } |
51 | |
52 | return $class->$orig( %args ); |
53 | }; |
54 | |
55 | sub BUILD { |
56 | my $self = shift; |
57 | if( $self->min > $self->max ) { |
910a0a6d |
58 | die "Position minimum cannot be higher than maximum"; |
45456358 |
59 | } |
60 | } |
61 | |
62 | sub parse_reference { |
63 | my( $ref ) = @_; |
64 | if( $ref =~ /^(\d+),(\d+)(\-(\d+))?$/ ) { |
910a0a6d |
65 | my( $common, $min, $max ) = ( $1, $2, $4 ); |
66 | $max = $min unless defined $max; |
67 | return( $common, $min, $max ); |
45456358 |
68 | } else { |
910a0a6d |
69 | warn "Bad argument $ref passed to Position constructor"; |
70 | return undef; |
45456358 |
71 | } |
72 | } |
73 | |
74 | # Instance method |
75 | sub cmp_with { |
76 | my( $self, $other ) = @_; |
77 | return _cmp_bits( [ $self->common, $self->min, $self->max ], |
910a0a6d |
78 | [ $other->common, $other->min, $other->max ] ); |
45456358 |
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] |
910a0a6d |
92 | unless $a->[0] == $b->[0]; |
45456358 |
93 | return $a->[1] <=> $b->[1] |
910a0a6d |
94 | unless $a->[1] == $b->[1]; |
45456358 |
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 ) { |
910a0a6d |
123 | return $self->common == $other->common |
124 | && $self->min == $other->min |
125 | && $self->max == $other->max; |
45456358 |
126 | } else { |
910a0a6d |
127 | return $self->common == $other->common |
128 | && $self->min <= $other->max |
129 | && $self->max >= $other->min; |
45456358 |
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; |