lib/Text/Tradition/Collation/Reading.pm

   1 package Text::Tradition::Collation::Reading;
   2
   3 use Moose;
   4 use MooseX::NonMoose;
   5
   6 extends 'Graph::Easy::Node';
   7
   8 subtype 'Position'
   9     => as 'Str',
  10     => where { $_ =~ /^\d+\,\d+$/ },
  11     message { 'Position must be of the form x,y' };
  12
  13 has 'position' => (
  14                    is => 'rw',
  15                    isa => 'Position',
  16                    );
  17
  18 # This contains an array of reading objects; the array is a pool,
  19 # shared by the reading objects inside the pool.  When a reading is
  20 # added to the pool, all the same_as attributes should be updated.
  21 has 'same_as' => (
  22                   is => 'rw',
  23                   isa => 'ArrayRef[Text::Tradition::Collation::Reading]',
  24                   default => [ $self ],
  25                   );
  26
  27 # This is a hash mapping of 'relationship => reading'.
  28 # TODO we should validate the relationships sometime.
  29 has 'equivalence' => (
  30                       is => 'ro',
  31                       isa => 'HashRef[Text::Tradition::Collation::Reading]',
  32                       default => {},
  33                       );
  34
  35 sub merge_from {
  36     my( $self, $merged_node ) = @_;
  37     # Adopt the identity pool of the other node.
  38     my @now_identical = grep { $_ ne $merged_node } @{$merged_node->same_as};
  39     my $new_pool = _merge_array_pool( \@now_identical, $self->same_as )
  40         if @now_identical;
  41
  42     # Adopt the equivalence attributes of the other node.
  43     my $now_equiv = $merged_node->equivalence;
  44     foreach my $key ( %$now_equiv ) {
  45         if( $self->has_relationship( $key ) ) {
  46             my $related = $self->get_relationship( $key );
  47             if( $now_equiv->{$key} ne $related ) {
  48                 warn( sprintf( "Merged reading %s has relationship %s to reading %s instead of %s; skipping",
  49                                $merged_node->name, $key,
  50                                $now_equiv->{$key},
  51                                $related) );
  52             } # else no action needed
  53         } else {
  54             $self->set_relationship( $key, $now_equiv->{$key} );
  55         }
  56     }
  57 }
  58
  59 sub set_identical {
  60     my( $self, $other_node ) = @_;
  61     my $enlarged_pool = _merge_array_pool( $self->same_as,
  62                                            $other_node->same_as );
  63
  64     # ...and set this node to point to the enlarged pool.
  65     $self->set_same_as( $enlarged_pool );
  66 }
  67
  68 sub _merge_array_pool {
  69     my( $pool, $main_pool ) = @_;
  70     my %poolhash;
  71     foreach ( @$main_pool ) {
  72         # Note which nodes are already in the main pool so that we
  73         # don't re-add them.
  74         $poolhash{$_->name} = 1;
  75     }
  76
  77     foreach( @$pool ) {
  78         # Add the remaining nodes to the main pool...
  79         push( @$main_pool, $_ ) unless $poolhash{$_->name};
  80     }
  81     return $main_pool;
  82 }