morphology/t/text_tradition_morphology.t

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4 use Test::More 'no_plan';
   5 $| = 1;
   6
   7
   8
   9 # =begin testing
  10 {
  11 # Test that normal form follows lemma setting. Draws on code both here and in
  12 # the base module.
  13
  14 use Text::Tradition;
  15
  16 my $t = Text::Tradition->new(
  17         input => 'Self',
  18         file => 't/data/florilegium_graphml.xml' );
  19 my $c = $t->collation;
  20
  21 # First try lemmatizing and then adding a relationship
  22 my $r1 = $c->reading('w42');
  23 my $r2 = $c->reading('w44');
  24 $r1->normal_form('FOO');
  25 $r2->normal_form('BAR');
  26
  27 $r1->make_lemma( 1 );
  28 is( $r1->normal_form, 'FOO', "nothing changed yet" );
  29 is( $r2->normal_form, 'BAR', "nothing changed yet" );
  30
  31 $c->add_relationship( $r1, $r2, { type => 'spelling' } );
  32 is( $r2->normal_form, 'FOO', "Normal form followed lemma" );
  33
  34 # Now try setting relationships and then lemmatizing
  35 my $r3 = $c->reading('w98');
  36 my $r4 = $c->reading('w100');
  37 my $r5 = $c->reading('w103');
  38 $r3->normal_form('YAN');
  39 $r4->normal_form('TAN');
  40 $r5->normal_form('TETHERA');
  41
  42 $c->add_relationship( $r3, $r4, { type => 'orthographic', propagate => 1 } );
  43 $c->add_relationship( $r3, $r5, { type => 'orthographic', propagate => 1 } );
  44 is( $r3->normal_form, 'YAN', "nothing changed yet" );
  45 is( $r4->normal_form, 'TAN', "nothing changed yet" );
  46 is( $r5->normal_form, 'TETHERA', "nothing changed yet" );
  47
  48 $r3->make_lemma( 1 );
  49 is( $r4->normal_form, 'YAN', "normal form propagated" );
  50 is( $r5->normal_form, 'YAN', "normal form propagated" );
  51
  52 # Finally, try a relationship that shouldn't propagate the normal form
  53 my $r6 = $c->reading('w91');
  54 my $r7 = $c->reading('w92');
  55 $r6->normal_form('BAZ');
  56 $r7->normal_form('QUUX');
  57 $r6->make_lemma( 1 );
  58
  59 $c->add_relationship( $r6, $r7, { type => 'grammatical' } );
  60 is( $r7->normal_form, 'QUUX', "normal form on grammatical relationship unchanged" );
  61 }
  62
  63
  64
  65
  66 1;