script/orth_case_links.pl

   1 #!/usr/bin/env perl
   2
   3 use lib 'lib';
   4 use strict;
   5 use warnings;
   6 use Text::Tradition::Directory;
   7
   8 binmode STDERR, ':utf8';
   9 binmode STDOUT, ':utf8';
  10 eval { no warnings; binmode $DB::OUT, ':utf8' };
  11
  12 my( $dsn, $user, $pass ) = @ARGV;
  13
  14 my $connect_args = { dsn => $dsn };
  15 $connect_args->{'extra_args'} = { user => $user, password => $pass }
  16         if $user && $pass;
  17 my $dir = Text::Tradition::Directory->new( $connect_args );
  18
  19 foreach my $text ( $dir->traditionlist ) {
  20         my $id = $text->{'id'};
  21         next unless $text->{'name'} =~ /Heinrichi/;
  22         my $scope = $dir->new_scope;
  23         my $tradition = $dir->lookup( $id );
  24         print STDERR "Processing tradition " . $tradition->name . "\n";
  25         my $c = $tradition->collation;
  26         $c->flatten_ranks(); # just in case
  27         foreach my $rank ( 1 .. $c->end->rank - 1 ) {
  28                 my @readings = $c->readings_at_rank( $rank );
  29                 my %merged;
  30                 while( @readings ) {
  31                         my $r = pop @readings;
  32                         next if $r->is_meta;
  33                         next if $merged{$r->id};
  34                         my @orthmatch = grep { lc( $r->text ) eq lc( $_->text ) } @readings;
  35                         foreach my $om ( @orthmatch ) {
  36                                 if( $r->text eq $om->text ) {
  37                                         print STDERR "Merging identical readings $r and $om ("
  38                                                 . $r->text . ")\n";
  39                                         $merged{$om->id} = 1;
  40                                         $c->merge_readings( $r, $om );
  41                                 } else {
  42                                         print STDERR sprintf( "Adding orthographic link for %s and %s (%s / %s)\n",
  43                                                 $r->id, $om->id, $r->text, $om->text );
  44                                         eval { $c->add_relationship( $r, $om,
  45                                                 { 'type' => 'orthographic', 'scope' => 'global' } ); };
  46                                         print STDERR $@ if $@;
  47                                 }
  48                         }
  49                 }
  50         }
  51         $dir->save( $tradition );
  52 }
  53
  54 print STDERR "Done\n";