reading IDs must be XML names; now used in SVG node IDs

[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 bdadce2..5e92b9a 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
 
@@ -166,7 +167,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 +182,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 : '' );
@@ -192,7 +203,8 @@ sub parse {
                
                # Add the witness if we don't have it already.
                unless( $witnesses{$e->{'witness'}} ) {
-                       $tradition->add_witness( sigil => $e->{'witness'} );
+                       $tradition->add_witness( 
+                               sigil => $e->{'witness'}, 'sourcetype' => 'collation' );
                        $witnesses{$e->{'witness'}} = 1;
                }
                $tradition->witness( $e->{'witness'} )->is_layered( 1 ) if $e->{'extra'};
@@ -202,9 +214,14 @@ sub parse {
        # Nodes are added via the call to add_reading above.  We only need
        # add the relationships themselves.
        # TODO check that scoping does trt
-       foreach my $e ( @{$rel_data->{'edges'}} ) {
-               my $from = $collation->reading( $e->{'source'}->{'id'} );
-               my $to = $collation->reading( $e->{'target'}->{'id'} );
+       $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 $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.
@@ -222,7 +239,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
@@ -230,6 +251,21 @@ sub parse {
        $collation->text_from_paths();  
 }
 
+## Return the relationship that comes first in priority.
+my %LAYERS = (
+       'collated' => 1,
+       'orthographic' => 2,
+       'spelling' => 3,
+       );
+
+sub _layersort_rel {
+       my( $a, $b ) = @_;
+       my $key = exists $a->{'type'} ? 'type' : 'relationship';
+       my $at = $LAYERS{$a->{$key}} || 99;
+       my $bt = $LAYERS{$b->{$key}} || 99;
+       return $at <=> $bt;
+}
+
 1;
 
 =head1 BUGS / TODO