lib/Text/Tradition/Collation/Reading.pm

   1 package Text::Tradition::Collation::Reading;
   2
   3 use Moose;
   4 use Moose::Util::TypeConstraints;
   5 use MooseX::NonMoose;
   6
   7 extends 'Graph::Easy::Node';
   8
   9 subtype 'Position'
  10     => as 'Str',
  11     => where { $_ =~ /^\d+\,\d+$/ },
  12     message { 'Position must be of the form x,y' };
  13
  14 has 'position' => (
  15     is => 'rw',
  16     isa => 'Position',
  17     predicate => 'has_position',
  18     );
  19
  20 # This contains an array of reading objects; the array is a pool,
  21 # shared by the reading objects inside the pool.  When a reading is
  22 # added to the pool, all the same_as attributes should be updated.
  23 has 'same_as' => (
  24     is => 'rw',
  25     isa => 'ArrayRef[Text::Tradition::Collation::Reading]',
  26     );
  27
  28 # # This is a hash mapping of 'relationship => reading'.
  29 # # TODO we should validate the relationships sometime.
  30 has 'relationships' => (
  31     is => 'ro',
  32     isa => 'HashRef[Text::Tradition::Collation::Reading]',
  33     default => sub { {} },
  34     );
  35
  36 # Deal with the non-arg option for Graph::Easy's constructor.
  37 around BUILDARGS => sub {
  38     my $orig = shift;
  39     my $class = shift;
  40
  41     my %args;
  42     if( @_ == 1 && ref( $_[0] ) ne 'HASH' ) {
  43         return $class->$orig( 'name' => $_[0] );
  44     } else {
  45         return $class->$orig( @_ );
  46     }
  47 };
  48
  49 # Initialize the identity pool.
  50 sub BUILD {
  51     my( $self, $args ) = @_;
  52     $self->same_as( [ $self ] );
  53 }
  54
  55 sub text {
  56     # Wrapper function around 'label' attribute.
  57     my $self = shift;
  58     if( @_ ) {
  59         $self->set_attribute( 'label', $_[0] );
  60     }
  61     return $self->get_attribute( 'label' );
  62 }
  63
  64 sub merge_from {
  65     my( $self, $merged_node ) = @_;
  66     # Adopt the identity pool of the other node.
  67     my @now_identical = grep { $_ ne $merged_node } @{$merged_node->same_as};
  68     my $new_pool = _merge_array_pool( \@now_identical, $self->same_as )
  69         if @now_identical;
  70
  71     # Adopt the relationship attributes of the other node.
  72     my $now_rel = $merged_node->relationships;
  73     foreach my $key ( %$now_rel ) {
  74         if( $self->has_relationship( $key ) ) {
  75             my $related = $self->get_relationship( $key );
  76             if( $now_rel->{$key} ne $related ) {
  77                 warn( sprintf( "Merged reading %s has relationship %s to reading %s instead of %s; skipping",
  78                                $merged_node->name, $key,
  79                                $now_rel->{$key},
  80                                $related) );
  81             } # else no action needed
  82         } else {
  83             $self->set_relationship( $key, $now_rel->{$key} );
  84         }
  85     }
  86 }
  87
  88 sub set_identical {
  89     my( $self, $other_node ) = @_;
  90     my $enlarged_pool = _merge_array_pool( $self->same_as,
  91                                            $other_node->same_as );
  92
  93     # ...and set this node to point to the enlarged pool.
  94     $self->same_as( $enlarged_pool );
  95 }
  96
  97 sub identical_readings {
  98     my $self = shift;
  99     my @same = grep { $_ ne $self } @{$self->same_as};
 100     return @same;
 101 }
 102
 103 sub _merge_array_pool {
 104     my( $pool, $main_pool ) = @_;
 105     my %poolhash;
 106     foreach ( @$main_pool ) {
 107         # Note which nodes are already in the main pool so that we
 108         # don't re-add them.
 109         $poolhash{$_->name} = 1;
 110     }
 111
 112     foreach( @$pool ) {
 113         # Add the remaining nodes to the main pool...
 114         push( @$main_pool, $_ ) unless $poolhash{$_->name};
 115     }
 116     return $main_pool;
 117 }
 118
 119 sub has_primary {
 120     my $self = shift;
 121     my $pool = $self->same_as;
 122     return $pool->[0]->name eq $self->name;
 123 }
 124
 125 sub primary {
 126     my $self = shift;
 127     return $self->same_as->[0];
 128 }
 129
 130 # Much easier to do this with a hash than with an array of Relationship objects,
 131 # which would be the proper OO method.
 132
 133 sub has_relationship {
 134     my( $self, $rel ) = @_;
 135     return exists( $self->relationships->{ $rel } );
 136 }
 137
 138 sub get_relationship {
 139     my( $self, $rel ) = @_;
 140     if( $self->has_relationship( $rel ) ) {
 141         return $self->relationships->{ $rel };
 142     }
 143     return undef;
 144 }
 145
 146 sub set_relationship {
 147     my( $self, $rel, $value ) = @_;
 148     $self->relationships->{ $rel } = $value;
 149 }
 150
 151 sub is_common {
 152     my( $self ) = shift;
 153     return $self->get_attribute( 'class' ) eq 'common';
 154 }
 155
 156 sub make_common {
 157     my( $self ) = shift;
 158     $self->set_attribute( 'class', 'common' );
 159 }
 160
 161 sub make_variant {
 162     my( $self ) = shift;
 163     $self->set_attribute( 'class', 'variant' );
 164 }
 165
 166 no Moose;
 167 __PACKAGE__->meta->make_immutable;
 168
 169 1;
 170
 171 ######################################################
 172 ## copied from Graph::Easy::Parser docs
 173 ######################################################
 174 # when overriding nodes, we also need ::Anon
 175
 176 package Text::Tradition::Collation::Reading::Anon;
 177 use Moose;
 178 use MooseX::NonMoose;
 179 extends 'Text::Tradition::Collation::Reading';
 180 extends 'Graph::Easy::Node::Anon';
 181 no Moose;
 182 __PACKAGE__->meta->make_immutable;
 183
 184 1;
 185 # use base qw/Text::Tradition::Collation::Reading/;
 186 # use base qw/Graph::Easy::Node::Anon/;
 187
 188 ######################################################
 189 # and :::Empty
 190
 191 package Text::Tradition::Collation::Reading::Empty;
 192 use Moose;
 193 use MooseX::NonMoose;
 194 extends 'Graph::Easy::Node::Empty';
 195 no Moose;
 196 __PACKAGE__->meta->make_immutable;
 197
 198 1;
 199 # use base qw/Text::Tradition::Collation::Reading/;
 200
 201 ######################################################