refactor GraphML write/parse to use Moose introspection

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

diff --git a/lib/Text/Tradition/Collation/RelationshipStore.pm b/lib/Text/Tradition/Collation/RelationshipStore.pm
index 0f48552..c9136b3 100644 (file)
--- a/lib/Text/Tradition/Collation/RelationshipStore.pm
+++ b/lib/Text/Tradition/Collation/RelationshipStore.pm
@@ -228,21 +228,23 @@ sub add_relationship {
                $options->{'reading_b'} = $target_rdg->text;
                $options->{'orig_a'} = $source;
                $options->{'orig_b'} = $target;
-               $relationship = $self->create( $options );  # Will throw on error
+       if( $options->{'scope'} ne 'local' ) {
+                       # Is there a relationship with this a & b already?
+                       my $otherrel = $self->scoped_relationship( $options->{reading_a}, 
+                               $options->{reading_b} );
+                       if( $otherrel && $otherrel->type eq $options->{type}
+                               && $otherrel->scope eq $options->{scope} ) {
+                               warn "Applying existing scoped relationship";
+                               $relationship = $otherrel;
+                       }
+       }
+               $relationship = $self->create( $options ) unless $relationship;  # Will throw on error
     }
 
 
        # Find all the pairs for which we need to set the relationship.
        my @vectors = ( [ $source, $target ] ); 
     if( $relationship->colocated && $relationship->nonlocal && !$thispaironly ) {
-       # Is there a relationship with this a & b already?
-       my $otherrel = $self->scoped_relationship( $relationship->reading_a, 
-               $relationship->reading_b );
-       if( $otherrel && $otherrel->type eq $relationship->type 
-               && $otherrel->scope eq $relationship->scope ) {
-               warn "Applying existing scoped relationship";
-               $relationship = $otherrel;
-       }
        my $c = $self->collation;
        # Set the same relationship everywhere we can, throughout the graph.
        my @identical_readings = grep { $_->text eq $relationship->reading_a }
@@ -269,7 +271,6 @@ sub add_relationship {
                my $rel = $self->get_relationship( @$v );
        if( $rel && $rel ne $relationship ) {
                if( $rel->nonlocal ) {
-                       $DB::single = 1;
                        throw( "Found conflicting relationship at @$v" );
                } else {
                        warn "Not overriding local relationship set at @$v";
@@ -350,8 +351,12 @@ sub relationship_valid {
                # Otherwise, first make a lookup table of all the
                # readings related to either the source or the target.
                my @proposed_related = ( $source, $target );
-               push( @proposed_related, $self->related_readings( $source, 'colocated' ) );
-               push( @proposed_related, $self->related_readings( $target, 'colocated' ) );
+               # Drop the collation links of source and target, unless we want to
+               # add a collation relationship.
+               foreach my $r ( ( $source, $target ) ) {
+                       $self->_drop_collations( $r ) unless $rel eq 'collated';
+                       push( @proposed_related, $self->related_readings( $r, 'colocated' ) );
+               }
                my %pr_ids;
                map { $pr_ids{ $_ } = 1 } @proposed_related;
        
@@ -375,6 +380,15 @@ sub relationship_valid {
        }
 }
 
+sub _drop_collations {
+       my( $self, $reading ) = @_;
+       foreach my $n ( $self->graph->neighbors( $reading ) ) {
+               if( $self->get_relationship( $reading, $n )->type eq 'collated' ) {
+                       $self->del_relationship( $reading, $n );
+               }
+       }
+}
+
 =head2 related_readings( $reading, $filter )
 
 Returns a list of readings that are connected via relationship links to $reading.
@@ -486,13 +500,11 @@ sub _as_graphml {
                $edge_el->setAttribute( 'id', 'e'.$edge_ctr++ );
 
                my $rel_obj = $self->get_relationship( @$e );
-               _add_graphml_data( $edge_el, $edge_keys->{'relationship'}, $rel_obj->type );
-               _add_graphml_data( $edge_el, $edge_keys->{'scope'}, $rel_obj->scope );
-               _add_graphml_data( $edge_el, $edge_keys->{'annotation'}, $rel_obj->annotation );
-               _add_graphml_data( $edge_el, $edge_keys->{'non_correctable'}, 
-                       $rel_obj->non_correctable ) if $rel_obj->noncorr_set;
-               _add_graphml_data( $edge_el, $edge_keys->{'non_independent'}, 
-                       $rel_obj->non_independent ) if $rel_obj->nonind_set;
+               foreach my $key ( keys %$edge_keys ) {
+                       my $value = $rel_obj->$key;
+                       _add_graphml_data( $edge_el, $edge_keys->{$key}, $value ) 
+                               if defined $value;
+               }
        }
 }