lib/Text/Tradition/Collation/Reading.pm

   1 package Text::Tradition::Collation::Reading;
   2
   3 use Moose::Util::TypeConstraints;
   4 use MooseX::NonMoose;
   5 use Moose;
   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     );
  18
  19 # This contains an array of reading objects; the array is a pool,
  20 # shared by the reading objects inside the pool.  When a reading is
  21 # added to the pool, all the same_as attributes should be updated.
  22 has 'same_as' => (
  23     is => 'rw',
  24     isa => 'ArrayRef[Text::Tradition::Collation::Reading]',
  25     );
  26
  27 # This is a hash mapping of 'relationship => reading'.
  28 # TODO we should validate the relationships sometime.
  29 has 'relationships' => (
  30     is => 'ro',
  31     isa => 'HashRef[Text::Tradition::Collation::Reading]',
  32     default => sub { {} },
  33     );
  34
  35 # Initialize the identity pool.
  36 sub BUILD {
  37     my( $self, $args ) = @_;
  38 #    $self->same_as( [ $self ] );
  39 }
  40
  41 sub merge_from {
  42     my( $self, $merged_node ) = @_;
  43     # Adopt the identity pool of the other node.
  44     my @now_identical = grep { $_ ne $merged_node } @{$merged_node->same_as};
  45     my $new_pool = _merge_array_pool( \@now_identical, $self->same_as )
  46         if @now_identical;
  47
  48     # Adopt the relationship attributes of the other node.
  49     my $now_rel = $merged_node->relationships;
  50     foreach my $key ( %$now_rel ) {
  51         if( $self->has_relationship( $key ) ) {
  52             my $related = $self->get_relationship( $key );
  53             if( $now_rel->{$key} ne $related ) {
  54                 warn( sprintf( "Merged reading %s has relationship %s to reading %s instead of %s; skipping",
  55                                $merged_node->name, $key,
  56                                $now_rel->{$key},
  57                                $related) );
  58             } # else no action needed
  59         } else {
  60             $self->set_relationship( $key, $now_rel->{$key} );
  61         }
  62     }
  63 }
  64
  65 sub set_identical {
  66     my( $self, $other_node ) = @_;
  67     my $enlarged_pool = _merge_array_pool( $self->same_as,
  68                                            $other_node->same_as );
  69
  70     # ...and set this node to point to the enlarged pool.
  71     $self->set_same_as( $enlarged_pool );
  72 }
  73
  74 sub _merge_array_pool {
  75     my( $pool, $main_pool ) = @_;
  76     my %poolhash;
  77     foreach ( @$main_pool ) {
  78         # Note which nodes are already in the main pool so that we
  79         # don't re-add them.
  80         $poolhash{$_->name} = 1;
  81     }
  82
  83     foreach( @$pool ) {
  84         # Add the remaining nodes to the main pool...
  85         push( @$main_pool, $_ ) unless $poolhash{$_->name};
  86     }
  87     return $main_pool;
  88 }
  89
  90 # Much easier to do this with a hash than with an array of Relationship objects,
  91 # which would be the proper OO method.
  92
  93 sub has_relationship {
  94     my( $self, $rel ) = @_;
  95     return exists( $self->relationships->{ $rel } );
  96 }
  97
  98 sub get_relationship {
  99     my( $self, $rel ) = @_;
 100     if( $self->has_relationship( $rel ) ) {
 101         return $self->relationships->{ $rel };
 102     }
 103     return undef;
 104 }
 105
 106 sub set_relationship {
 107     my( $self, $rel, $value ) = @_;
 108     $self->relationships->{ $rel } = $value;
 109 }
 110
 111 no Moose;
 112 __PACKAGE__->meta->make_immutable;
 113
 114 1;
 115
 116 ######################################################
 117 ## copied from Graph::Easy::Parser docs
 118 ######################################################
 119 # when overriding nodes, we also need ::Anon
 120
 121 package Text::Tradition::Collation::Reading::Anon;
 122 use Moose;
 123 use MooseX::NonMoose;
 124 extends 'Text::Tradition::Collation::Reading';
 125 extends 'Graph::Easy::Node::Anon';
 126 no Moose;
 127 __PACKAGE__->meta->make_immutable;
 128
 129 1;
 130 # use base qw/Text::Tradition::Collation::Reading/;
 131 # use base qw/Graph::Easy::Node::Anon/;
 132
 133 ######################################################
 134 # and :::Empty
 135
 136 package Text::Tradition::Collation::Reading::Empty;
 137 use Moose;
 138 use MooseX::NonMoose;
 139 extends 'Graph::Easy::Node::Empty';
 140 no Moose;
 141 __PACKAGE__->meta->make_immutable;
 142
 143 1;
 144 # use base qw/Text::Tradition::Collation::Reading/;
 145
 146 ######################################################