generate svg with relationships invisible; fix graphml output

[scpubgit/stemmatology.git] / lib / Text / Tradition / Collation / Reading.pm

diff --git a/lib/Text/Tradition/Collation/Reading.pm b/lib/Text/Tradition/Collation/Reading.pm
index 8334564..e16818c 100644 (file)
--- a/lib/Text/Tradition/Collation/Reading.pm
+++ b/lib/Text/Tradition/Collation/Reading.pm
@@ -1,8 +1,9 @@
 package Text::Tradition::Collation::Reading;
 
+use Moose;
 use Moose::Util::TypeConstraints;
 use MooseX::NonMoose;
-use Moose;
+use Text::Tradition::Collation::Relationship;
 
 extends 'Graph::Easy::Node';
 
@@ -14,6 +15,7 @@ subtype 'Position'
 has 'position' => (
     is => 'rw',
     isa => 'Position',
+    predicate => 'has_position',
     );
 
 # This contains an array of reading objects; the array is a pool,
@@ -24,18 +26,32 @@ has 'same_as' => (
     isa => 'ArrayRef[Text::Tradition::Collation::Reading]',
     );
 
-# This is a hash mapping of 'relationship => reading'.
-# TODO we should validate the relationships sometime.
-has 'relationships' => (
-    is => 'ro',
-    isa => 'HashRef[Text::Tradition::Collation::Reading]',
-    default => sub { {} },
-    );
+# Deal with the non-arg option for Graph::Easy's constructor.
+around BUILDARGS => sub {
+    my $orig = shift;
+    my $class = shift;
+
+    my %args;
+    if( @_ == 1 && ref( $_[0] ) ne 'HASH' ) {
+       return $class->$orig( 'name' => $_[0] );
+    } else {
+       return $class->$orig( @_ );
+    }
+};
 
 # Initialize the identity pool. 
 sub BUILD {
     my( $self, $args ) = @_;
-#    $self->same_as( [ $self ] );
+    $self->same_as( [ $self ] );
+}
+
+sub text {
+    # Wrapper function around 'label' attribute.
+    my $self = shift;
+    if( @_ ) {
+       $self->set_attribute( 'label', $_[0] );
+    }
+    return $self->get_attribute( 'label' );
 }
 
 sub merge_from {
@@ -45,32 +61,27 @@ sub merge_from {
     my $new_pool = _merge_array_pool( \@now_identical, $self->same_as )
        if @now_identical;
 
-    # Adopt the relationship attributes of the other node.
-    my $now_rel = $merged_node->relationships;
-    foreach my $key ( %$now_rel ) {
-       if( $self->has_relationship( $key ) ) {
-           my $related = $self->get_relationship( $key );
-           if( $now_rel->{$key} ne $related ) {
-               warn( sprintf( "Merged reading %s has relationship %s to reading %s instead of %s; skipping",
-                              $merged_node->name, $key,
-                              $now_rel->{$key},
-                              $related) );
-           } # else no action needed
-       } else {
-           $self->set_relationship( $key, $now_rel->{$key} );
-       }
-    }
+    # TODO Adopt the relationship attributes of the other node.
 }
 
+## Dealing with transposed readings.  These methods are only really
+## applicable if we have a linear collation graph.
+
 sub set_identical {
     my( $self, $other_node ) = @_; 
     my $enlarged_pool = _merge_array_pool( $self->same_as, 
                                           $other_node->same_as );
 
     # ...and set this node to point to the enlarged pool.
-    $self->set_same_as( $enlarged_pool );
+    $self->same_as( $enlarged_pool );
 }   
 
+sub identical_readings {
+    my $self = shift;
+    my @same = grep { $_ ne $self } @{$self->same_as};
+    return @same;
+}
+
 sub _merge_array_pool {
     my( $pool, $main_pool ) = @_;
     my %poolhash;
@@ -87,25 +98,32 @@ sub _merge_array_pool {
     return $main_pool;
 }
 
-# Much easier to do this with a hash than with an array of Relationship objects,
-# which would be the proper OO method.
+sub has_primary {
+    my $self = shift;
+    my $pool = $self->same_as;
+    return $pool->[0]->name ne $self->name;
+}
+
+sub primary {
+    my $self = shift;
+    return $self->same_as->[0];
+}
+
+## Keep track of which readings are unchanged across witnesses.
 
-sub has_relationship {
-    my( $self, $rel ) = @_;
-    return exists( $self->relationships->{ $rel } );
+sub is_common {
+    my( $self ) = shift;
+    return $self->get_attribute( 'class' ) eq 'common';
 }
 
-sub get_relationship {
-    my( $self, $rel ) = @_;
-    if( $self->has_relationship( $rel ) ) {
-       return $self->relationships->{ $rel };
-    }
-    return undef;
+sub make_common {
+    my( $self ) = shift;
+    $self->set_attribute( 'class', 'common' );
 }
 
-sub set_relationship {
-    my( $self, $rel, $value ) = @_;
-    $self->relationships->{ $rel } = $value;
+sub make_variant {
+    my( $self ) = shift;
+    $self->set_attribute( 'class', 'variant' );
 }
 
 no Moose;