base/script/rejoin_split.pl

   1 #!/usr/bin/env perl
   2
   3 use lib 'lib';
   4 use feature 'say';
   5 use strict;
   6 use warnings;
   7 use Text::Tradition;
   8 use Text::Tradition::Directory;
   9 use TryCatch;
  10
  11 binmode STDOUT, ':utf8';
  12 binmode STDERR, ':utf8';
  13
  14 my $dir = Text::Tradition::Directory->new(
  15     'dsn' => 'dbi:SQLite:dbname=db/traditions.db',
  16     );
  17
  18 my $scope = $dir->new_scope();
  19 my $main = Text::Tradition->new( name => 'Heinrichi combined', language => 'Finnish' );
  20 $main->_init_done( 0 ); # so that we can add disconnected readings
  21 my $mc = $main->collation;
  22
  23 my $first = $ARGV[0];
  24 my $last = $ARGV[-1];
  25 my $prior;
  26 my @endpaths;
  27 foreach my $id ( @ARGV ) {
  28         my $tradition = $dir->lookup( $id );
  29         say STDERR "Applying readings from " . $tradition->name;
  30         my $c = $tradition->collation;
  31
  32         ## Duplicate the witnesses
  33         foreach my $wit ( $tradition->witnesses ) {
  34                 unless( $main->has_witness( $wit ) ) {
  35                         my %witopts = (
  36                                 sigil => $wit->sigil,
  37                                 sourcetype => $wit->sourcetype,
  38                                 is_layered => $wit->is_layered,
  39                                 is_collated => $wit->is_collated
  40                                 );
  41                         $main->add_witness( %witopts );
  42                 }
  43         }
  44
  45         ## Duplicate the readings
  46         foreach my $rdg ( $c->readings ) {
  47                 my %rdg_opts;
  48                 my $skip;
  49
  50                 ## If the reading exists already, just check consistency.
  51                 if( $mc->reading( $rdg->id ) ) {
  52                         # Check that it matches
  53                         die "Reading mismatch at $rdg" unless $rdg->text eq $mc->reading( $rdg->id )->text;
  54                 } else {
  55                         # Create the new reading
  56                         %rdg_opts = (
  57                                 id => $rdg->id,
  58                                 text => $rdg->text,
  59                                 is_lacuna => $rdg->is_lacuna,
  60                                 is_common => $rdg->is_common,
  61                                 rank => $rdg->rank,
  62                                 join_prior => $rdg->join_prior,
  63                                 join_next => $rdg->join_next )
  64                                 unless keys( %rdg_opts );
  65                         $mc->add_reading( \%rdg_opts );
  66                 }
  67         }
  68 }
  69
  70 ## Duplicate the edges
  71 my %need_end;
  72 foreach my $id ( @ARGV ) {
  73         my $tradition = $dir->lookup( $id );
  74         say STDERR "Applying edges from " . $tradition->name;
  75         my $c = $tradition->collation;
  76         foreach my $p ( sort { _by_source_rank( $a, $b, $c ) } $c->paths ) {
  77                 foreach my $wit ( $c->path_witnesses( $p ) ) {
  78                         my @vector = @$p;
  79                         # Don't connect to intermediate start/end nodes
  80                         if( $id ne $first && $c->reading( $p->[0] )->is_start ) {
  81                                 if( exists $need_end{$wit} ) {
  82                                         # Connect them
  83                                         my $start = delete $need_end{$wit};
  84                                         next if $start eq $p->[1];
  85                                         @vector = ( $start, $p->[1] );
  86                                 } else {
  87                                         warn "Unconnected second half of path for $wit at " . $p->[1];
  88                                         # Try connecting it to the start node
  89                                         @vector = ( $mc->start, $p->[1] );
  90                                 }
  91                         }
  92                         if ( $id ne $last && $c->reading( $p->[1] )->is_end ) {
  93                                 $need_end{$wit} = $p->[0];
  94                                 next;
  95                         }
  96                         unless( $mc->has_path( @vector, $wit ) ) {
  97                                 $mc->add_path( @vector, $wit );
  98                         }
  99                 }
 100         }
 101         if( $id eq $last ) {
 102                 # Connect whatever is left in $need_end
 103                 foreach my $wit ( keys %need_end ) {
 104                         my $start = delete $need_end{$wit};
 105                         $mc->add_path( $start, $mc->end, $wit );
 106                 }
 107         }
 108 }
 109
 110 ## Make the witness text and indicate that the paths are in place
 111 $mc->text_from_paths();
 112 $main->_init_done( 1 );
 113 $mc->calculate_ranks();
 114
 115 ## Apply the relationships
 116 foreach my $id ( @ARGV ) {
 117         my $tradition = $dir->lookup( $id );
 118         say STDERR "Applying relationships from " . $tradition->name;
 119         my $c = $tradition->collation;
 120         ## Duplicate the relationships
 121         foreach my $reledge ( sort {
 122                         _apply_relationship_order( $a, $b, $c ) } $c->relationships ) {
 123                 my $rel = $c->get_relationship( $reledge );
 124                 # Apply it
 125                 try {
 126                         apply_relationship( $rel, $reledge );
 127                 } catch( Text::Tradition::Error $err ) {
 128                         say STDERR "Failed to apply " . $rel->type . " rel at @$reledge: "
 129                                 . $err->message;
 130                 }
 131         }
 132 }
 133
 134 $mc->calculate_ranks();
 135 $mc->flatten_ranks();
 136 say $mc->as_graphml();
 137
 138 sub apply_relationship {
 139         my( $rel, $reledge ) = @_;
 140         my $opts = {
 141                 type => $rel->type,
 142                 scope => $rel->scope };
 143         $opts->{annotation} = $rel->annotation if $rel->has_annotation;
 144         $opts->{thispaironly} = 1 if $rel->nonlocal;
 145         unless( $mc->get_relationship( $reledge ) ) {
 146                 $mc->add_relationship( @$reledge, $opts );
 147         }
 148 }
 149
 150 # Helper function for applying the path edges in the expected order
 151 sub _by_source_rank {
 152         my( $a, $b, $c ) = @_;
 153         return $c->reading( $a->[0] )->rank <=> $c->reading( $b->[0] )->rank;
 154 }
 155
 156 # Helper sort function for applying the saved relationships in a
 157 # sensible order.
 158 sub _apply_relationship_order {
 159         my( $a, $b, $c ) = @_;
 160         my $rg = $mc->relations;
 161         my $aobj = $c->get_relationship( $a ); my $bobj = $c->get_relationship( $b );
 162         my $at = $rg->type( $aobj->type ); my $bt = $rg->type( $bobj->type );
 163         # Apply strong relationships before weak
 164         return -1 if $bt->is_weak && !$at->is_weak;
 165         return 1 if $at->is_weak && !$bt->is_weak;
 166         # Apply local before global
 167         return -1 if !$aobj->nonlocal && $bobj->nonlocal;
 168         return 1 if !$bobj->nonlocal && $aobj->nonlocal;
 169         # Apply more tightly bound relationships first
 170         return $at->bindlevel <=> $bt->bindlevel;
 171 }