use Graph;
use IPC::Run qw( run binary );
use Text::CSV;
+use Text::Tradition::Collation::Data;
use Text::Tradition::Collation::Reading;
use Text::Tradition::Collation::RelationshipStore;
use Text::Tradition::Error;
use XML::LibXML::XPathContext;
use Moose;
-has 'sequence' => (
- is => 'ro',
- isa => 'Graph',
- default => sub { Graph->new() },
- handles => {
- paths => 'edges',
- },
- );
-
-has 'relations' => (
- is => 'ro',
- isa => 'Text::Tradition::Collation::RelationshipStore',
- handles => {
- relationships => 'relationships',
- related_readings => 'related_readings',
- get_relationship => 'get_relationship',
- del_relationship => 'del_relationship',
- equivalence => 'equivalence',
- equivalence_graph => 'equivalence_graph',
- },
- writer => '_set_relations',
- );
+has _data => (
+ isa => 'Text::Tradition::Collation::Data',
+ is => 'ro',
+ required => 1,
+ handles => [ qw(
+ sequence
+ paths
+ _set_relations
+ relations
+ _set_start
+ _set_end
+ ac_label
+ has_cached_table
+ relationships
+ related_readings
+ get_relationship
+ del_relationship
+ equivalence
+ equivalence_graph
+ readings
+ reading
+ _add_reading
+ del_reading
+ has_reading
+ wit_list_separator
+ baselabel
+ linear
+ wordsep
+ start
+ end
+ cached_table
+ _graphcalc_done
+ has_cached_svg
+ wipe_table
+ )]
+);
has 'tradition' => (
is => 'ro',
weak_ref => 1,
);
-has 'readings' => (
- isa => 'HashRef[Text::Tradition::Collation::Reading]',
- traits => ['Hash'],
- handles => {
- reading => 'get',
- _add_reading => 'set',
- del_reading => 'delete',
- has_reading => 'exists',
- readings => 'values',
- },
- default => sub { {} },
- );
-
-has 'wit_list_separator' => (
- is => 'rw',
- isa => 'Str',
- default => ', ',
- );
-
-has 'baselabel' => (
- is => 'rw',
- isa => 'Str',
- default => 'base text',
- );
-
-has 'linear' => (
- is => 'rw',
- isa => 'Bool',
- default => 1,
- );
-
-has 'ac_label' => (
- is => 'rw',
- isa => 'Str',
- default => ' (a.c.)',
- );
-
-has 'wordsep' => (
- is => 'rw',
- isa => 'Str',
- default => ' ',
- );
-
-has 'start' => (
- is => 'ro',
- isa => 'Text::Tradition::Collation::Reading',
- writer => '_set_start',
- weak_ref => 1,
- );
-
-has 'end' => (
- is => 'ro',
- isa => 'Text::Tradition::Collation::Reading',
- writer => '_set_end',
- weak_ref => 1,
- );
-
-has 'cached_svg' => (
- is => 'rw',
- isa => 'Str',
- predicate => 'has_cached_svg',
- clearer => 'wipe_svg',
- );
-
-has 'cached_table' => (
- is => 'rw',
- isa => 'HashRef',
- predicate => 'has_cached_table',
- clearer => 'wipe_table',
- );
-
-has '_graphcalc_done' => (
- is => 'rw',
- isa => 'Bool',
- default => undef,
- );
-
=head1 NAME
Text::Tradition::Collation - a software model for a text collation
=cut
+sub BUILDARGS {
+ my ( $class, @args ) = @_;
+ my %args = @args == 1 ? %{ $args[0] } : @args;
+ # TODO determine these from the Moose::Meta object
+ my @delegate_attrs = qw(sequence relations readings wit_list_separator baselabel
+ linear wordsep start end cached_table _graphcalc_done);
+ my %data_args;
+ for my $attr (@delegate_attrs) {
+ $data_args{$attr} = delete $args{$attr} if exists $args{$attr};
+ }
+ $args{_data} = Text::Tradition::Collation::Data->new(%data_args);
+ return \%args;
+}
+
sub BUILD {
my $self = shift;
$self->_set_relations( Text::Tradition::Collation::RelationshipStore->new( 'collation' => $self ) );
$joinstr = $self->wordsep unless defined $joinstr;
}
$kept_obj->alter_text( join( $joinstr, $kept_obj->text, $del_obj->text ) );
+ # Change this reading to a joining one if necessary
+ $kept_obj->_set_join_next( $del_obj->join_next );
$kept_obj->normal_form(
join( $joinstr, $kept_obj->normal_form, $del_obj->normal_form ) );
# Combine the lexemes present in the readings
# readings.
my %gobbled;
foreach my $rdg ( sort { $a->rank <=> $b->rank } $self->readings ) {
+ # While we are here, get rid of any extra wordforms from a disambiguated
+ # reading.
+ if( $rdg->disambiguated ) {
+ foreach my $lex ( $rdg->lexemes ) {
+ $lex->clear_matching_forms();
+ $lex->add_matching_form( $lex->form );
+ }
+ }
+ # Now look for readings that can be joined to their successors.
next if $rdg->is_meta;
next if $gobbled{$rdg->id};
next if $rdg->grammar_invalid || $rdg->is_nonsense;
my $want_subgraph = exists $opts->{'from'} || exists $opts->{'to'};
$self->calculate_ranks()
unless( $self->_graphcalc_done || $opts->{'nocalc'} || !$self->linear );
- if( !$self->has_cached_svg || $opts->{'recalc'} || $want_subgraph ) {
- my @cmd = qw/dot -Tsvg/;
- my( $svg, $err );
- my $dotfile = File::Temp->new();
- ## USE FOR DEBUGGING
- # $dotfile->unlink_on_destroy(0);
- binmode $dotfile, ':utf8';
- print $dotfile $self->as_dot( $opts );
- push( @cmd, $dotfile->filename );
- run( \@cmd, ">", binary(), \$svg );
- $svg = decode_utf8( $svg );
- $self->cached_svg( $svg ) unless $want_subgraph;
- return $svg;
- } else {
- return $self->cached_svg;
- }
+ my @cmd = qw/dot -Tsvg/;
+ my( $svg, $err );
+ my $dotfile = File::Temp->new();
+ ## USE FOR DEBUGGING
+ # $dotfile->unlink_on_destroy(0);
+ binmode $dotfile, ':utf8';
+ print $dotfile $self->as_dot( $opts );
+ push( @cmd, $dotfile->filename );
+ run( \@cmd, ">", binary(), \$svg );
+ $svg = decode_utf8( $svg );
+ return $svg;
}
is( scalar $st->collation->paths, $PATHS, "Reparsed collation has all paths" );
is( scalar $st->collation->relationships, 3, "Reparsed collation has new relationships" );
-# Now add a stemma, write to GraphML, and parse again.
+# Now add a stemma, write to GraphML, and look at the output.
my $stemma = $tradition->add_stemma( 'dotfile' => 't/data/florilegium.dot' );
is( ref( $stemma ), 'Text::Tradition::Stemma', "Parsed dotfile into stemma" );
is( $tradition->stemmata, 1, "Tradition now has the stemma" );
$graphml = $c->as_graphml;
like( $graphml, qr/digraph/, "Digraph declaration exists in GraphML" );
+# Now add a user, write to GraphML, and look at the output.
+unlike( $graphml, qr/testuser/, "Test user name does not exist in GraphML yet" );
+my $testuser = Text::Tradition::User->new(
+ id => 'testuser', password => 'testpass' );
+is( ref( $testuser ), 'Text::Tradition::User', "Created test user object" );
+$testuser->add_tradition( $tradition );
+is( $tradition->user->id, $testuser->id, "Tradition assigned to test user" );
+$graphml = $c->as_graphml;
+like( $graphml, qr/testuser/, "Test user name now exists in GraphML" );
+
=end testing
=cut
'http://graphml.graphdrawing.org/xmlns/1.0/graphml.xsd';
# Create the document and root node
+ require XML::LibXML;
my $graphml = XML::LibXML->createDocument( "1.0", "UTF-8" );
my $root = $graphml->createElementNS( $graphml_ns, 'graphml' );
$graphml->setDocumentElement( $root );
'RelationshipScope' => 'string',
);
- # List of attribute names *not* to save on our objects.
- # We will also not save any attribute beginning with _.
- my %skipsave;
- map { $skipsave{$_} = 1 } qw/ cached_svg /;
-
# Add the data keys for the graph. Include an extra key 'version' for the
# GraphML output version.
my %graph_data_keys;
map { $gattr_from{$_->name} = 'Collation' } $cmeta->get_all_attributes;
foreach my $attr ( ( $tmeta->get_all_attributes, $cmeta->get_all_attributes ) ) {
next if $attr->name =~ /^_/;
- next if $skipsave{$attr->name};
next unless $save_types{$attr->type_constraint->name};
$graph_attributes{$attr->name} = $save_types{$attr->type_constraint->name};
}
- # Extra custom key for the tradition stemma(ta)
- $graph_attributes{'stemmata'} = 'string';
+ # Extra custom keys for complex objects that should be saved in some form.
+ # The subroutine should return a string, or undef/empty.
+ $graph_attributes{'stemmata'} = sub {
+ my @stemstrs;
+ map { push( @stemstrs, $_->editable( {linesep => ''} ) ) }
+ $self->tradition->stemmata;
+ join( "\n", @stemstrs );
+ };
+ $graph_attributes{'user'} = sub {
+ $self->tradition->user ? $self->tradition->user->id : undef
+ };
foreach my $datum ( sort keys %graph_attributes ) {
$graph_data_keys{$datum} = 'dg'.$gdi++;
my $key = $root->addNewChild( $graphml_ns, 'key' );
+ my $dtype = ref( $graph_attributes{$datum} ) ? 'string'
+ : $graph_attributes{$datum};
$key->setAttribute( 'attr.name', $datum );
- $key->setAttribute( 'attr.type', $graph_attributes{$datum} );
+ $key->setAttribute( 'attr.type', $dtype );
$key->setAttribute( 'for', 'graph' );
$key->setAttribute( 'id', $graph_data_keys{$datum} );
}
my $rmeta = Text::Tradition::Collation::Reading->meta;
foreach my $attr( $rmeta->get_all_attributes ) {
next if $attr->name =~ /^_/;
- next if $skipsave{$attr->name};
next unless $save_types{$attr->type_constraint->name};
$reading_attributes{$attr->name} = $save_types{$attr->type_constraint->name};
}
my $pmeta = Text::Tradition::Collation::Relationship->meta;
foreach my $attr( $pmeta->get_all_attributes ) {
next if $attr->name =~ /^_/;
- next if $skipsave{$attr->name};
next unless $save_types{$attr->type_constraint->name};
$edge_attributes{$attr->name} = $save_types{$attr->type_constraint->name};
}
my $value;
if( $datum eq 'version' ) {
$value = '3.2';
- } elsif( $datum eq 'stemmata' ) {
- my @stemstrs;
- map { push( @stemstrs, $_->editable( {linesep => ''} ) ) }
- $self->tradition->stemmata;
- $value = join( "\n", @stemstrs );
+ } elsif( ref( $graph_attributes{$datum} ) ) {
+ my $sub = $graph_attributes{$datum};
+ $value = &$sub();
} elsif( $gattr_from{$datum} eq 'Tradition' ) {
$value = $self->tradition->$datum;
} else {
map { $char_hash{$_} = undef } @$positions;
my $debug = 0;
foreach my $rdg ( @$path ) {
- my $rtext = $rdg->text;
- $rtext = '#LACUNA#' if $rdg->is_lacuna;
say STDERR "rank " . $rdg->rank if $debug;
# say STDERR "No rank for " . $rdg->id unless defined $rdg->rank;
$char_hash{$rdg->rank} = { 't' => $rdg };
}
}
# Do we need to invalidate the cached data?
- if( $self->has_cached_svg || $self->has_cached_table ) {
+ if( $self->has_cached_table ) {
foreach my $r ( $self->readings ) {
next if defined( $existing_ranks{$r} )
&& $existing_ranks{$r} == $r->rank;
sub _clear_cache {
my $self = shift;
- $self->wipe_svg if $self->has_cached_svg;
$self->wipe_table if $self->has_cached_table;
}
projects / scpubgit/stemmatology.git / blobdiff