script/propagate_transitive.pl

   1 #!/usr/bin/env perl
   2
   3 use lib 'lib';
   4 use feature 'say';
   5 use strict;
   6 use warnings;
   7 use Getopt::Long;
   8 use Lingua::Features::Structure;
   9 use Text::Tradition::Directory;
  10 use XML::Easy::Syntax qw/ $xml10_name_rx $xml10_namestartchar_rx /;
  11 use TryCatch;
  12
  13 binmode STDOUT, ':utf8';
  14 binmode STDERR, ':utf8';
  15 eval { no warnings; binmode $DB::OUT, ':utf8'; $DB::deep = 1000 };
  16
  17 my %TYPEVALUES = (
  18         orthographic => 1,
  19         spelling => 2,
  20         grammatical => 3,
  21         lexical => 3,
  22         collated => 50,
  23         );
  24
  25 my( $dbuser, $dbpass );
  26 my $dsn = 'dbi:SQLite:dbname=stemmaweb/db/traditions.db';
  27 my $testrun;
  28
  29 GetOptions(
  30         'dsn=s'    => \$dsn,
  31         'u|user=s' => \$dbuser,
  32         'p|pass=s' => \$dbpass,
  33         'n|test'   => \$testrun,
  34         );
  35
  36 my $dbopts = { dsn => $dsn };
  37 $dbopts->{extra_args}->{user} = $dbuser if $dbuser;
  38 $dbopts->{extra_args}->{password} = $dbpass if $dbpass;
  39
  40 my $dir = Text::Tradition::Directory->new( $dbopts );
  41
  42 my $scope = $dir->new_scope();
  43 my $lookfor = $ARGV[0] || '';
  44 foreach my $tinfo ( $dir->traditionlist() ) {
  45         next unless $tinfo->{'name'} =~ /$lookfor/ || $tinfo->{'id'} eq $lookfor;
  46         my $tradition = $dir->lookup( $tinfo->{'id'} );
  47         my $c = $tradition->collation;
  48
  49         my $represented_by = {};
  50         my $representative = {};
  51         # For each set of ranked relationships, make all the implied links
  52         # explicit. Start with orthographic readings
  53         push_rel_type( $c, 'orthographic', $representative, $represented_by );
  54         # then move on to spelling readings
  55         push_rel_type( $c, 'spelling', $representative, $represented_by );
  56
  57         # Now all orth/spelling linked words are the same word for the purposes of
  58         # other colocated links, and in our representation hashes.
  59         # Go through the other relationships and propagate them to all words that are
  60         # the same word.
  61         foreach my $rel ( $c->relationships ) {
  62                 my $relobj = $c->get_relationship( $rel );
  63                 next unless $relobj->type =~ /^(grammatical|lexical)$/;
  64                 my $r1pool = $represented_by->{$representative->{$rel->[0]}};
  65                 my $r2pool = $represented_by->{$representative->{$rel->[1]}};
  66                 # Error check
  67                 if( check_distinct( $r1pool, $r2pool ) ) {
  68                         map { propagate_rel( $c, $relobj->type, $_, @$r2pool ) } @$r1pool;
  69                 } else {
  70                         warn "Pools not distinct for " . join( ' and ', @$rel );
  71                 }
  72         }
  73         $dir->save( $tradition ) unless $testrun;
  74 }
  75
  76 sub propagate_rel {
  77         my( $c, $type, @list ) = @_;
  78         my $curr = shift @list;
  79         while( @list ) {
  80                 foreach my $r ( @list ) {
  81                         next if $curr eq $r;
  82                         my $hasrel = $c->get_relationship( $curr, $r );
  83                         if( !$hasrel || $hasrel->type eq 'collated' ) {
  84                                 say STDERR "Propagating $type relationship $curr -> $r";
  85                                 $c->add_relationship( $curr, $r, { type => $type } );
  86                         } elsif( $hasrel->type ne $type ) {
  87                                 warn "Found relationship conflict at $curr / $r: "
  88                                         . $hasrel->type . " instead of $type"
  89                                         unless( $TYPEVALUES{$hasrel->type} < $TYPEVALUES{$type} );
  90                         }
  91                 }
  92                 $curr = shift @list;
  93         }
  94 }
  95
  96 sub push_rel_type {
  97         my( $c, $type, $r2rep, $rep2r ) = @_;
  98         my %handled;
  99         foreach my $rdg ( $c->readings ) {
 100                 next if $rdg->is_meta;
 101                 next if $handled{"$rdg"};
 102                 if( exists $r2rep->{"$rdg"} ) {
 103                         $rdg = $r2rep->{"$rdg"};
 104                 }
 105                 # Get the specified relationships
 106                 my @set = $rdg->related_readings( sub {
 107                         $_[0]->colocated && ( $_[0]->type eq $type ||
 108                         $TYPEVALUES{$_[0]->type} < $TYPEVALUES{$type} ) } );
 109                 push( @set, $rdg );
 110                 propagate_rel( $c, $type, @set ) if @set > 2;
 111                 # Set up the representatives
 112                 map { $r2rep->{"$_"} = $rdg } @set;
 113                 $rep2r->{"$rdg"} = \@set;
 114                 map { $handled{"$_"} = 1 } @set;
 115         }
 116 }
 117
 118 sub check_distinct {
 119         my( $l1, $l2 ) = @_;
 120         my %seen;
 121         map { $seen{"$_"} = 1 } @$l1;
 122         map { return 0 if $seen{"$_"} } @$l2;
 123         return 1;
 124 }
 125