8 use Text::Tradition::Directory;
11 binmode STDOUT, ':utf8';
12 binmode STDERR, ':utf8';
14 my $dir = Text::Tradition::Directory->new(
15 'dsn' => 'dbi:SQLite:dbname=db/traditions.db',
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;
27 foreach my $id ( @ARGV ) {
28 my $tradition = $dir->lookup( $id );
29 say STDERR "Applying readings from " . $tradition->name;
30 my $c = $tradition->collation;
32 ## Duplicate the witnesses
33 foreach my $wit ( $tradition->witnesses ) {
34 unless( $main->has_witness( $wit ) ) {
37 sourcetype => $wit->sourcetype,
38 is_layered => $wit->is_layered,
39 is_collated => $wit->is_collated
41 $main->add_witness( %witopts );
45 ## Duplicate the readings
46 foreach my $rdg ( $c->readings ) {
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;
55 # Create the new reading
59 is_lacuna => $rdg->is_lacuna,
60 is_common => $rdg->is_common,
62 join_prior => $rdg->join_prior,
63 join_next => $rdg->join_next )
64 unless keys( %rdg_opts );
65 $mc->add_reading( \%rdg_opts );
70 ## Duplicate the edges
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 ) ) {
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} ) {
83 my $start = delete $need_end{$wit};
84 next if $start eq $p->[1];
85 @vector = ( $start, $p->[1] );
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] );
92 if ( $id ne $last && $c->reading( $p->[1] )->is_end ) {
93 $need_end{$wit} = $p->[0];
96 unless( $mc->has_path( @vector, $wit ) ) {
97 $mc->add_path( @vector, $wit );
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 );
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();
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 );
126 apply_relationship( $rel, $reledge );
127 } catch( Text::Tradition::Error $err ) {
128 say STDERR "Failed to apply " . $rel->type . " rel at @$reledge: "
134 $mc->calculate_ranks();
135 $mc->flatten_ranks();
136 say $mc->as_graphml();
138 sub apply_relationship {
139 my( $rel, $reledge ) = @_;
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 );
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;
156 # Helper sort function for applying the saved relationships in a
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;