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 merge_from {
  56     my( $self, $merged_node ) = @_;
  57     # Adopt the identity pool of the other node.
  58     my @now_identical = grep { $_ ne $merged_node } @{$merged_node->same_as};
  59     my $new_pool = _merge_array_pool( \@now_identical, $self->same_as )
  60         if @now_identical;
  61
  62     # Adopt the relationship attributes of the other node.
  63     my $now_rel = $merged_node->relationships;
  64     foreach my $key ( %$now_rel ) {
  65         if( $self->has_relationship( $key ) ) {
  66             my $related = $self->get_relationship( $key );
  67             if( $now_rel->{$key} ne $related ) {
  68                 warn( sprintf( "Merged reading %s has relationship %s to reading %s instead of %s; skipping",
  69                                $merged_node->name, $key,
  70                                $now_rel->{$key},
  71                                $related) );
  72             } # else no action needed
  73         } else {
  74             $self->set_relationship( $key, $now_rel->{$key} );
  75         }
  76     }
  77 }
  78
  79 sub set_identical {
  80     my( $self, $other_node ) = @_;
  81     my $enlarged_pool = _merge_array_pool( $self->same_as,
  82                                            $other_node->same_as );
  83
  84     # ...and set this node to point to the enlarged pool.
  85     $self->same_as( $enlarged_pool );
  86 }
  87
  88 sub _merge_array_pool {
  89     my( $pool, $main_pool ) = @_;
  90     my %poolhash;
  91     foreach ( @$main_pool ) {
  92         # Note which nodes are already in the main pool so that we
  93         # don't re-add them.
  94         $poolhash{$_->name} = 1;
  95     }
  96
  97     foreach( @$pool ) {
  98         # Add the remaining nodes to the main pool...
  99         push( @$main_pool, $_ ) unless $poolhash{$_->name};
 100     }
 101     return $main_pool;
 102 }
 103
 104 sub has_primary {
 105     my $self = shift;
 106     my $pool = $self->same_as;
 107     return $pool->[0]->name eq $self->name;
 108 }
 109
 110 sub primary {
 111     my $self = shift;
 112     return $self->same_as->[0];
 113 }
 114
 115 # Much easier to do this with a hash than with an array of Relationship objects,
 116 # which would be the proper OO method.
 117
 118 sub has_relationship {
 119     my( $self, $rel ) = @_;
 120     return exists( $self->relationships->{ $rel } );
 121 }
 122
 123 sub get_relationship {
 124     my( $self, $rel ) = @_;
 125     if( $self->has_relationship( $rel ) ) {
 126         return $self->relationships->{ $rel };
 127     }
 128     return undef;
 129 }
 130
 131 sub set_relationship {
 132     my( $self, $rel, $value ) = @_;
 133     $self->relationships->{ $rel } = $value;
 134 }
 135
 136 sub is_common {
 137     my( $self ) = shift;
 138     return $self->get_attribute( 'class' ) eq 'common';
 139 }
 140
 141 sub make_common {
 142     my( $self ) = shift;
 143     $self->set_attribute( 'class', 'common' );
 144 }
 145
 146 sub make_variant {
 147     my( $self ) = shift;
 148     $self->set_attribute( 'class', 'variant' );
 149 }
 150
 151 no Moose;
 152 __PACKAGE__->meta->make_immutable;
 153
 154 1;
 155
 156 ######################################################
 157 ## copied from Graph::Easy::Parser docs
 158 ######################################################
 159 # when overriding nodes, we also need ::Anon
 160
 161 package Text::Tradition::Collation::Reading::Anon;
 162 use Moose;
 163 use MooseX::NonMoose;
 164 extends 'Text::Tradition::Collation::Reading';
 165 extends 'Graph::Easy::Node::Anon';
 166 no Moose;
 167 __PACKAGE__->meta->make_immutable;
 168
 169 1;
 170 # use base qw/Text::Tradition::Collation::Reading/;
 171 # use base qw/Graph::Easy::Node::Anon/;
 172
 173 ######################################################
 174 # and :::Empty
 175
 176 package Text::Tradition::Collation::Reading::Empty;
 177 use Moose;
 178 use MooseX::NonMoose;
 179 extends 'Graph::Easy::Node::Empty';
 180 no Moose;
 181 __PACKAGE__->meta->make_immutable;
 182
 183 1;
 184 # use base qw/Text::Tradition::Collation::Reading/;
 185
 186 ######################################################