8 use Text::Tradition::Directory;
11 binmode STDOUT, ':utf8';
12 binmode STDERR, ':utf8';
13 eval { no warnings; binmode $DB::OUT, ':utf8'; $DB::deep = 1000 };
23 my( $dbuser, $dbpass );
24 my $dsn = 'dbi:SQLite:dbname=stemmaweb/db/traditions.db';
29 'u|user=s' => \$dbuser,
30 'p|pass=s' => \$dbpass,
31 'n|test' => \$testrun,
34 my $dbopts = { dsn => $dsn };
35 $dbopts->{extra_args}->{user} = $dbuser if $dbuser;
36 $dbopts->{extra_args}->{password} = $dbpass if $dbpass;
38 my $dir = Text::Tradition::Directory->new( $dbopts );
40 my $scope = $dir->new_scope();
41 my $lookfor = $ARGV[0] || '';
42 foreach my $tinfo ( $dir->traditionlist() ) {
43 next if $tinfo->{'name'} eq 'xxxxx';
44 next unless $tinfo->{'name'} =~ /$lookfor/ || $tinfo->{'id'} eq $lookfor;
45 my $tradition = $dir->lookup( $tinfo->{'id'} );
46 say "Looking at tradition " . $tradition->name;
47 my $c = $tradition->collation;
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 );
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
61 foreach my $rel ( $c->relationships ) {
62 my $relobj = $c->get_relationship( $rel );
63 if( $relobj->type =~ /^(grammatical|lexical)$/ ) {
64 my $r1pool = $represented_by->{$representative->{$rel->[0]}};
65 my $r2pool = $represented_by->{$representative->{$rel->[1]}};
67 if( check_distinct( $r1pool, $r2pool ) ) {
68 map { propagate_rel( $c, $relobj->type, $_, @$r2pool ) } @$r1pool;
70 warn "Pools not distinct for " . join( ' and ', @$rel );
72 } elsif( $relobj->type eq 'transposition' ) {
73 # We also need to propagate transposition links, but rather more strictly.
74 propagate_rel( $c, 'transposition', map { $c->reading( $_ ) } @$rel );
79 $dir->save( $tradition ) unless $testrun;
83 my( $c, $type, @list ) = @_;
84 my $curr = shift @list;
86 foreach my $r ( @list ) {
88 # Check that the given relationship type exists between $curr and $r.
89 # Also check that the given relationship type exists between $curr and
90 # the same-type relationships of $r.
91 my @candidates = ( $r );
92 foreach my $rrel ( $r->related_readings() ) {
93 next if $curr eq $rrel;
94 my $rrelobj = $c->get_relationship( $r, $rrel );
95 if( $rrelobj && $rrelobj->type eq $type ) {
96 my $hasrrel = $c->get_relationship( $curr, $rrel );
97 push( @candidates, $rrel ) unless $hasrrel;
100 foreach my $cand ( @candidates ) {
101 my $hasrel = $c->get_relationship( $curr, $cand );
102 if( !$hasrel || $hasrel->type eq 'collated' ) {
103 say STDERR "Propagating $type relationship $curr -> $cand";
104 $c->add_relationship( $curr, $cand, { type => $type } );
105 } elsif( $hasrel->type ne $type ) {
106 warn "Found relationship conflict at $curr / $cand: "
107 . $hasrel->type . " instead of $type"
108 unless( $TYPEVALUES{$hasrel->type} < $TYPEVALUES{$type} );
117 my( $c, $type, $r2rep, $rep2r ) = @_;
119 foreach my $rdg ( $c->readings ) {
120 next if $rdg->is_meta;
121 next if $handled{"$rdg"};
122 if( exists $r2rep->{"$rdg"} ) {
123 $rdg = $r2rep->{"$rdg"};
125 # Get the specified relationships
126 my @set = $rdg->related_readings( sub {
127 $_[0]->colocated && ( $_[0]->type eq $type ||
128 $TYPEVALUES{$_[0]->type} < $TYPEVALUES{$type} ) } );
130 propagate_rel( $c, $type, @set ) if @set > 2;
131 # Set up the representatives
132 map { $r2rep->{"$_"} = $rdg } @set;
133 $rep2r->{"$rdg"} = \@set;
134 map { $handled{"$_"} = 1 } @set;
141 map { $seen{"$_"} = 1 } @$l1;
142 map { return 0 if $seen{"$_"} } @$l2;