save any defined stemmata in GraphML

[scpubgit/stemmatology.git] / lib / Text / Tradition / Parser / Self.pm

diff --git a/lib/Text/Tradition/Parser/Self.pm b/lib/Text/Tradition/Parser/Self.pm
index b8f12dd..8483891 100644 (file)
--- a/lib/Text/Tradition/Parser/Self.pm
+++ b/lib/Text/Tradition/Parser/Self.pm
@@ -3,6 +3,7 @@ package Text::Tradition::Parser::Self;
 use strict;
 use warnings;
 use Text::Tradition::Parser::GraphML qw/ graphml_parse /;
+use TryCatch;
 
 =head1 NAME
 
@@ -113,9 +114,10 @@ if( $t ) {
     is( scalar $t->witnesses, 13, "Collation has all witnesses" );
 }
 
-# TODO add a relationship, write graphml, reparse it, check that the rel
-# is still there
+# TODO add a relationship, add a stemma, write graphml, reparse it, check that 
+# the new data is there
 $t->language('Greek');
+$t->add_stemma( 'dotfile' => 't/data/florilegium.dot' );
 $t->collation->add_relationship( 'w12', 'w13', 
        { 'type' => 'grammatical', 'scope' => 'global', 
          'annotation' => 'This is some note' } );
@@ -133,6 +135,8 @@ if( $newt ) {
     my $rel = $newt->collation->get_relationship( 'w12', 'w13' );
     ok( $rel, "Found set relationship" );
     is( $rel->annotation, 'This is some note', "Relationship has its properties" );
+    is( scalar $newt->stemmata, 1, "Tradition has its stemma" );
+    is( $newt->stemma(0)->witnesses, $t->stemma(0)->witnesses, "Stemma has correct length witness list" );
 }
 
 
@@ -159,6 +163,10 @@ sub parse {
                my $val = $graph_data->{'global'}->{$gkey};
                if( $gkey eq 'version' ) {
                        $use_version = $val;
+               } elsif( $gkey eq 'stemmata' ) { # Special case, yuck
+                       foreach my $dotstr ( split( /\n/, $val ) ) {
+                               $tradition->add_stemma( 'dot' => $dotstr );
+                       }
                } elsif( $tmeta->has_attribute( $gkey ) ) {
                        $tradition->$gkey( $val );
                } else {
@@ -166,7 +174,10 @@ sub parse {
                }
        }
                
-    # Add the nodes to the graph. 
+    # Add the nodes to the graph.
+    # Note any reading IDs that were changed in order to comply with XML 
+    # name restrictions; we have to hardcode start & end.
+    my %namechange = ( '#START#' => '__START__', '#END#' => '__END__' );
 
     # print STDERR "Adding collation readings\n";
     foreach my $n ( @{$graph_data->{'nodes'}} ) {      
@@ -178,13 +189,20 @@ sub parse {
                next;
        }
                my $gnode = $collation->add_reading( $n );
+               if( $gnode->id ne $n->{'id'} ) {
+                       $namechange{$n->{'id'}} = $gnode->id;
+               }
     }
         
     # Now add the edges.
     # print STDERR "Adding collation path edges\n";
     foreach my $e ( @{$graph_data->{'edges'}} ) {
-        my $from = $collation->reading( $e->{'source'}->{'id'} );
-        my $to = $collation->reading( $e->{'target'}->{'id'} );
+       my $sourceid = exists $namechange{$e->{'source'}->{'id'}}
+               ? $namechange{$e->{'source'}->{'id'}} : $e->{'source'}->{'id'};
+       my $targetid = exists $namechange{$e->{'target'}->{'id'}}
+               ? $namechange{$e->{'target'}->{'id'}} : $e->{'target'}->{'id'};
+        my $from = $collation->reading( $sourceid );
+        my $to = $collation->reading( $targetid );
 
                warn "No witness label on path edge!" unless $e->{'witness'};
                my $label = $e->{'witness'} . ( $e->{'extra'} ? $collation->ac_label : '' );
@@ -205,8 +223,12 @@ sub parse {
        # TODO check that scoping does trt
        $rel_data->{'edges'} ||= []; # so that the next line doesn't break on no rels
        foreach my $e ( sort { _layersort_rel( $a, $b ) } @{$rel_data->{'edges'}} ) {
-               my $from = $collation->reading( $e->{'source'}->{'id'} );
-               my $to = $collation->reading( $e->{'target'}->{'id'} );
+       my $sourceid = exists $namechange{$e->{'source'}->{'id'}}
+               ? $namechange{$e->{'source'}->{'id'}} : $e->{'source'}->{'id'};
+       my $targetid = exists $namechange{$e->{'target'}->{'id'}}
+               ? $namechange{$e->{'target'}->{'id'}} : $e->{'target'}->{'id'};
+        my $from = $collation->reading( $sourceid );
+        my $to = $collation->reading( $targetid );
                delete $e->{'source'};
                delete $e->{'target'};
                # The remaining keys are relationship attributes.
@@ -224,7 +246,11 @@ sub parse {
                                $rel_exists = 1;
                        }
                }
-               $collation->add_relationship( $from, $to, $e ) unless $rel_exists;
+               try {
+                       $collation->add_relationship( $from, $to, $e ) unless $rel_exists;
+               } catch( Text::Tradition::Error $e ) {
+                       warn "DROPPING $from -> $to: " . $e->message;
+               }
        }
        
     # Save the text for each witness so that we can ensure consistency