From: Tara L Andrews <tla@mit.edu>
Date: Wed, 8 Aug 2012 20:51:01 +0000 (+0200)
Subject: make a majority text from a tradition
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c23749b5d30fa7c2102756edc2c308a1a8aee41b;p=scpubgit%2Fstemmatology.git

make a majority text from a tradition
---

diff --git a/script/majority_text.pl b/script/majority_text.pl
new file mode 100644
index 0000000..7bf3ef6
--- /dev/null
+++ b/script/majority_text.pl
@@ -0,0 +1,65 @@
+use lib 'lib';
+use feature 'say';
+use strict;
+use warnings;
+use Getopt::Long;
+use Text::Tradition::Directory;
+use TryCatch;
+
+binmode STDOUT, ':utf8';
+binmode STDERR, ':utf8';
+eval { no warnings; binmode $DB::OUT, ':utf8'; $DB::deep = 1000 };
+
+my( $dbuser, $dbpass );
+my $dsn = 'dbi:SQLite:dbname=stemmaweb/db/traditions.db';
+
+GetOptions( 
+	'dsn=s'    => \$dsn,
+	'u|user=s' => \$dbuser,
+	'p|pass=s' => \$dbpass,
+	);
+
+my $dbopts = { dsn => $dsn };
+$dbopts->{extra_args}->{user} = $dbuser if $dbuser;
+$dbopts->{extra_args}->{password} = $dbpass if $dbpass;
+
+my $dir = Text::Tradition::Directory->new( $dbopts );
+
+my $scope = $dir->new_scope();
+my $lookfor = $ARGV[0] || '';
+foreach my $tinfo ( $dir->traditionlist() ) {
+	next unless $tinfo->{'name'} =~ /$lookfor/ || $tinfo->{'id'} eq $lookfor;
+	my $tradition = $dir->lookup( $tinfo->{'id'} );
+	# Try to piece together the majority text.
+	my $c = $tradition->collation;
+	my $curr = $c->start;
+	my @text;
+	while( $curr ne $c->end ) {
+		my %witnumbers;
+		foreach my $candidate( $c->sequence->successors( $curr ) ) {
+			my $cobj = $c->reading( $candidate );
+			next if $cobj->is_lacuna;
+			my $witnum = scalar keys %{$c->sequence->get_edge_attributes( 
+				$curr->id, $candidate )};
+			$witnumbers{$witnum} = $cobj;
+		}
+		my @numbers = sort { $a <=> $b } keys %witnumbers;
+		if( @numbers ) {
+			$curr = $witnumbers{ pop @numbers };
+			push( @text, $curr ) unless $curr->is_meta;
+		} else {
+			warn "Did not find non-lacuna successor to $curr";
+			last;
+		}
+	}
+	my $pathtext = '';
+	my $last;
+	foreach my $r ( @text ) {
+		unless ( $r->join_prior || !$last || $last->join_next ) {
+			$pathtext .= ' ';
+		} 
+		$pathtext .= $r->text;
+		$last = $r;
+	}
+	say $pathtext;
+}
\ No newline at end of file