1 package Text::Tradition::Collation::Reading;
6 use KiokuDB::Util qw/ weak_set /;
8 extends 'Graph::Easy::Node';
13 predicate => 'has_rank',
21 # This contains an array of reading objects; the array is a pool,
22 # shared by the reading objects inside the pool. When a reading is
23 # added to the pool, all the same_as attributes should be updated.
25 does => 'KiokuDB::Set',
35 # Deal with the non-arg option for Graph::Easy's constructor.
36 around BUILDARGS => sub {
41 if( @_ == 1 && ref( $_[0] ) ne 'HASH' ) {
42 return $class->$orig( 'name' => $_[0] );
44 return $class->$orig( @_ );
48 # A lacuna node is also a meta node.
49 before is_lacuna => sub {
50 my( $self, $arg ) = @_;
56 # Initialize the identity pool.
58 my( $self, $args ) = @_;
59 my $pool = weak_set( $self );
60 $self->same_as( $pool );
64 # Wrapper function around 'label' attribute.
68 $self->set_attribute( 'label', $_[0] );
70 $self->del_attribute( 'label' );
77 my( $self, $sigil, $backup ) = @_;
78 my @wits = $self->witnesses;
79 return 1 if grep { $_ eq $sigil } @wits;
81 return 1 if grep { $_ eq $backup } @wits;
88 my @paths = grep { $_->get_attribute( 'class' ) eq 'path' } $self->outgoing;
89 push( @paths, grep { $_->get_attribute( 'class' ) eq 'path' } $self->incoming );
91 foreach my $p ( @paths ) {
92 if( $p->has_hidden_witnesses ) {
93 foreach ( @{$p->hidden_witnesses} ) {
104 my( $self, $merged_node ) = @_;
105 if( $self eq $merged_node ) {
106 warn "Trying to merge a reading into itself";
109 # Adopt the identity pool of the other node.
110 my @now_identical = grep { $_ ne $merged_node && $_ ne $self }
111 $merged_node->same_as->members;
112 if( @now_identical ) {
113 _merge_array_pool( $self->same_as, @now_identical );
117 ## Dealing with transposed readings. These methods are only really
118 ## applicable if we have a linear collation graph.
121 my( $self, $other_node ) = @_;
122 if( $self eq $other_node ) {
123 warn "Trying to set a reading identical to itself";
126 # We are no longer primary; turn that off first.
127 my @new_members = grep { $_ ne $other_node } $self->same_as->members;
128 _merge_array_pool( $other_node->same_as, @new_members );
131 sub identical_readings {
133 my @same = grep { $_ ne $self } $self->same_as->members;
138 sub _merge_array_pool {
139 my( $pool, @new_members ) = @_;
140 $pool->insert( @new_members );
141 foreach my $n ( @new_members ) {
143 $n->same_as( $pool );
149 return !$self->is_primary;
154 my @p = grep { $_->is_primary } $self->same_as->members;
155 warn "Identity pool for " . $self->name . " has more than one primary"
157 warn "Identity pool for " . $self->name . " has no primary" unless @p;
161 # Looks from the outside like an accessor for a Boolean, but really
162 # sets the node's class. Should apply to start, end, and lacunae.
167 if( defined $arg && $arg ) {
168 $self->set_attribute( 'class', 'meta' );
169 } elsif ( defined $arg ) {
170 $self->del_attribute( 'class' );
172 return $self->sub_class eq 'meta';
175 # Returns all readings that adjoin this one on any path.
176 sub neighbor_readings {
177 my( $self, $direction ) = @_;
178 $direction = 'both' unless $direction;
179 my @paths = grep { $_->isa( 'Text::Tradition::Collation::Path' ) } $self->edges;
181 foreach my $p ( @paths ) {
182 if( $p->to eq $self ) {
183 next if $direction eq 'forward';
184 $connected{$p->from->name} = $p->from;
185 } else { # $p->from eq $self
186 next if $direction =~ /^back/;
187 $connected{$p->to->name} = $p->to;
190 return values( %connected );
193 # Returns all readings related to the one we've got.
194 sub related_readings {
195 my( $self, $colocated, $queried ) = @_;
196 $queried = { $self->name => 1 } unless $queried;
198 # Get the nodes directly related to this one
199 foreach my $e ( $self->edges ) {
200 next unless $e->isa( 'Text::Tradition::Collation::Relationship' );
201 next if $colocated && $e->type eq 'repetition';
202 my $n = $e->from eq $self ? $e->to : $e->from;
203 next if $queried->{$n->name};
204 push( @related, $n );
206 # Now query those nodes for their relations, recursively
207 map { $queried->{$_->name} = 1 } @related;
209 foreach ( @related ) {
210 push( @also_related, $_->related_readings( $colocated, $queried ) );
212 push( @related, @also_related );
216 ## Keep track of which readings are unchanged across witnesses.
219 return $self->get_attribute( 'class' ) eq 'common';
222 ## TODO Rationalize make_common, is_meta, etc.
225 $self->set_attribute( 'class', 'common' );
230 $self->set_attribute( 'class', 'variant' );
234 __PACKAGE__->meta->make_immutable;
238 ######################################################
239 ## copied from Graph::Easy::Parser docs
240 ######################################################
241 # when overriding nodes, we also need ::Anon
243 package Text::Tradition::Collation::Reading::Anon;
245 use MooseX::NonMoose;
246 extends 'Text::Tradition::Collation::Reading';
247 extends 'Graph::Easy::Node::Anon';
249 __PACKAGE__->meta->make_immutable;
252 # use base qw/Text::Tradition::Collation::Reading/;
253 # use base qw/Graph::Easy::Node::Anon/;
255 ######################################################
258 package Text::Tradition::Collation::Reading::Empty;
260 use MooseX::NonMoose;
261 extends 'Graph::Easy::Node::Empty';
263 __PACKAGE__->meta->make_immutable;
266 # use base qw/Text::Tradition::Collation::Reading/;
268 ######################################################