Commit | Line | Data |
784877d9 |
1 | package Text::Tradition::Collation::Reading; |
2 | |
8e1394aa |
3 | use Moose; |
784877d9 |
4 | use MooseX::NonMoose; |
4cdd82f1 |
5 | use Text::Tradition::Collation::Position; |
784877d9 |
6 | |
7 | extends 'Graph::Easy::Node'; |
8 | |
784877d9 |
9 | has 'position' => ( |
d047cd52 |
10 | is => 'rw', |
4cdd82f1 |
11 | isa => 'Text::Tradition::Collation::Position', |
4a8828f0 |
12 | predicate => 'has_position', |
d047cd52 |
13 | ); |
784877d9 |
14 | |
15 | # This contains an array of reading objects; the array is a pool, |
16 | # shared by the reading objects inside the pool. When a reading is |
17 | # added to the pool, all the same_as attributes should be updated. |
18 | has 'same_as' => ( |
d047cd52 |
19 | is => 'rw', |
20 | isa => 'ArrayRef[Text::Tradition::Collation::Reading]', |
21 | ); |
784877d9 |
22 | |
8e1394aa |
23 | # Deal with the non-arg option for Graph::Easy's constructor. |
24 | around BUILDARGS => sub { |
25 | my $orig = shift; |
26 | my $class = shift; |
27 | |
28 | my %args; |
29 | if( @_ == 1 && ref( $_[0] ) ne 'HASH' ) { |
30 | return $class->$orig( 'name' => $_[0] ); |
31 | } else { |
32 | return $class->$orig( @_ ); |
33 | } |
34 | }; |
35 | |
4cdd82f1 |
36 | # Take constructor args as well as a Position argument. |
37 | around position => sub { |
38 | my $orig = shift; |
39 | my $self = shift; |
40 | return $self->$orig() unless @_; |
41 | |
42 | my @args = @_; |
43 | unless( @_ == 1 && ref( $_[0] ) eq 'Text::Tradition::Collation::Position' ) { |
44 | # We have constructor arguments; pass them to Position. |
45 | @args = ( Text::Tradition::Collation::Position->new( @_ ) ); |
46 | } |
47 | $self->$orig( @args ); |
48 | }; |
49 | |
d047cd52 |
50 | # Initialize the identity pool. |
51 | sub BUILD { |
52 | my( $self, $args ) = @_; |
8e1394aa |
53 | $self->same_as( [ $self ] ); |
d047cd52 |
54 | } |
784877d9 |
55 | |
e2902068 |
56 | sub text { |
57 | # Wrapper function around 'label' attribute. |
58 | my $self = shift; |
59 | if( @_ ) { |
60 | $self->set_attribute( 'label', $_[0] ); |
61 | } |
9463b0bf |
62 | return $self->label; |
e2902068 |
63 | } |
64 | |
784877d9 |
65 | sub merge_from { |
66 | my( $self, $merged_node ) = @_; |
67 | # Adopt the identity pool of the other node. |
68 | my @now_identical = grep { $_ ne $merged_node } @{$merged_node->same_as}; |
69 | my $new_pool = _merge_array_pool( \@now_identical, $self->same_as ) |
70 | if @now_identical; |
71 | |
3265b0ce |
72 | # TODO Adopt the relationship attributes of the other node. |
784877d9 |
73 | } |
74 | |
3265b0ce |
75 | ## Dealing with transposed readings. These methods are only really |
76 | ## applicable if we have a linear collation graph. |
77 | |
784877d9 |
78 | sub set_identical { |
79 | my( $self, $other_node ) = @_; |
80 | my $enlarged_pool = _merge_array_pool( $self->same_as, |
81 | $other_node->same_as ); |
82 | |
83 | # ...and set this node to point to the enlarged pool. |
8e1394aa |
84 | $self->same_as( $enlarged_pool ); |
784877d9 |
85 | } |
86 | |
de51424a |
87 | sub identical_readings { |
88 | my $self = shift; |
89 | my @same = grep { $_ ne $self } @{$self->same_as}; |
90 | return @same; |
91 | } |
92 | |
784877d9 |
93 | sub _merge_array_pool { |
94 | my( $pool, $main_pool ) = @_; |
95 | my %poolhash; |
96 | foreach ( @$main_pool ) { |
97 | # Note which nodes are already in the main pool so that we |
98 | # don't re-add them. |
99 | $poolhash{$_->name} = 1; |
100 | } |
101 | |
102 | foreach( @$pool ) { |
103 | # Add the remaining nodes to the main pool... |
104 | push( @$main_pool, $_ ) unless $poolhash{$_->name}; |
105 | } |
106 | return $main_pool; |
107 | } |
d047cd52 |
108 | |
8e1394aa |
109 | sub has_primary { |
110 | my $self = shift; |
111 | my $pool = $self->same_as; |
df6d9812 |
112 | return $pool->[0]->name ne $self->name; |
8e1394aa |
113 | } |
114 | |
115 | sub primary { |
116 | my $self = shift; |
117 | return $self->same_as->[0]; |
118 | } |
119 | |
4cdd82f1 |
120 | sub is_at_position { |
121 | my $self = shift; |
122 | return undef unless $self->has_position; |
123 | return $self->position->is_colocated( @_ ); |
124 | } |
125 | |
126 | # Returns all readings that adjoin this one on any path. |
127 | sub neighbor_readings { |
128 | my( $self, $direction ) = @_; |
129 | $direction = 'both' unless $direction; |
130 | my @paths = grep { $_->isa( 'Text::Tradition::Collation::Path' ) } $self->edges; |
131 | my %connected; |
132 | foreach my $p ( @paths ) { |
133 | if( $p->to eq $self ) { |
134 | next if $direction eq 'forward'; |
135 | $connected{$p->from->name} = $p->from; |
136 | } else { # $p->from eq $self |
137 | next if $direction =~ /^back/; |
138 | $connected{$p->to->name} = $p->to; |
139 | } |
140 | } |
141 | return values( %connected ); |
142 | } |
143 | |
144 | sub adjust_neighbor_position { |
145 | my $self = shift; |
146 | return unless $self->position->fixed; |
147 | |
148 | # TODO This is a naive and repetitive implementation and |
149 | # I don't like it. |
150 | foreach my $neighbor ( $self->neighbor_readings('forward') ) { |
151 | next unless !$neighbor->is_common && |
152 | $neighbor->position->common == $self->position->common; |
153 | if( $neighbor->position->fixed && |
154 | $neighbor->position->min == $self->position->min ) { |
155 | warn sprintf( "Readings %s and %s are at the same position!", |
156 | $neighbor->name, $self->name ); |
157 | } |
158 | next if $neighbor->position->fixed || $neighbor->position->matched; |
159 | $neighbor->position->min( $self->position->min + 1 ); |
160 | # Recurse if necessary. |
161 | $neighbor->adjust_neighbor_position() |
162 | unless $neighbor->position->fixed; |
163 | } |
164 | foreach my $neighbor ( $self->neighbor_readings('back') ) { |
165 | next unless !$neighbor->is_common && |
166 | $neighbor->position->common == $self->position->common; |
167 | if( $neighbor->position->fixed && |
168 | $neighbor->position->min == $self->position->min ) { |
169 | warn sprintf( "Readings %s and %s are at the same position!", |
170 | $neighbor->name, $self->name ); |
171 | } |
172 | next if $neighbor->position->fixed || $neighbor->position->matched; |
173 | $neighbor->position->max( $self->position->max - 1 ); |
174 | # Recurse if necessary. |
175 | $neighbor->adjust_neighbor_position() |
176 | unless $neighbor->position->fixed; |
177 | } |
178 | return; |
179 | } |
180 | |
181 | sub match_position { |
182 | my( $self, $other ) = @_; |
4cdd82f1 |
183 | # Adjust the position of both these nodes to be as restrictive as possible. |
184 | unless( $self->position->is_colocated( $other->position ) ) { |
185 | warn "Cannot match positions of non-colocated readings"; |
186 | return; |
187 | } |
188 | my $sp = $self->position; |
189 | my $op = $other->position; |
190 | my $newmin = $sp->min > $op->min ? $sp->min : $op->min; |
191 | my $newmax = $sp->max < $op->max ? $sp->max : $op->max; |
192 | my $newpos = Text::Tradition::Collation::Position->new( |
193 | 'common' => $sp->common, |
194 | 'min' => $newmin, |
195 | 'max' => $newmax, |
196 | 'matched' => 1, |
197 | ); |
198 | # We are setting the positions to be the same object. I don't |
199 | # think that actually matters. We may eventually want unique |
200 | # objects for each position. |
201 | $self->position( $newpos ); |
202 | $other->position( $newpos ); |
203 | $self->adjust_neighbor_position(); |
204 | $other->adjust_neighbor_position(); |
205 | } |
206 | |
3265b0ce |
207 | ## Keep track of which readings are unchanged across witnesses. |
d047cd52 |
208 | |
4a8828f0 |
209 | sub is_common { |
210 | my( $self ) = shift; |
211 | return $self->get_attribute( 'class' ) eq 'common'; |
212 | } |
213 | |
214 | sub make_common { |
215 | my( $self ) = shift; |
216 | $self->set_attribute( 'class', 'common' ); |
217 | } |
218 | |
219 | sub make_variant { |
220 | my( $self ) = shift; |
221 | $self->set_attribute( 'class', 'variant' ); |
222 | } |
223 | |
d047cd52 |
224 | no Moose; |
225 | __PACKAGE__->meta->make_immutable; |
226 | |
227 | 1; |
228 | |
229 | ###################################################### |
230 | ## copied from Graph::Easy::Parser docs |
231 | ###################################################### |
232 | # when overriding nodes, we also need ::Anon |
233 | |
234 | package Text::Tradition::Collation::Reading::Anon; |
021bdbac |
235 | use Moose; |
236 | use MooseX::NonMoose; |
237 | extends 'Text::Tradition::Collation::Reading'; |
238 | extends 'Graph::Easy::Node::Anon'; |
239 | no Moose; |
240 | __PACKAGE__->meta->make_immutable; |
d047cd52 |
241 | |
021bdbac |
242 | 1; |
243 | # use base qw/Text::Tradition::Collation::Reading/; |
244 | # use base qw/Graph::Easy::Node::Anon/; |
d047cd52 |
245 | |
246 | ###################################################### |
247 | # and :::Empty |
248 | |
249 | package Text::Tradition::Collation::Reading::Empty; |
021bdbac |
250 | use Moose; |
251 | use MooseX::NonMoose; |
252 | extends 'Graph::Easy::Node::Empty'; |
253 | no Moose; |
254 | __PACKAGE__->meta->make_immutable; |
d047cd52 |
255 | |
021bdbac |
256 | 1; |
257 | # use base qw/Text::Tradition::Collation::Reading/; |
d047cd52 |
258 | |
259 | ###################################################### |