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