Automating morphological tagging with Perl

Question

Let's suppose I've got a text with morphological tags, and a similar one with no tags at all. Both texts are merged in an interlinear fashion, one line below the other. Thus (additional carriage returns added for clarity's sake):

The(Art) day(N) started(V) well(Adv), windy(Adj) and(C) humid(Adj), here(Adv) in(P) London(PN),

The day was windy and quite humid here in London,

but(P) we(Pr) did(AuxV) not(Adv) mind(V), because(P) we(Pr) had(AuxV) planned(V) to(P) stay(V) indoors(Adv)

but no problem at all, mate! We had planned to stay at home anyway!

Second line (i.e., the untagged text) is always preceded by a space and a tab.

Besides, punctuation and case-sensitivity can be safely ignored. Additionally, it could be the case that some words in the first line are not tagged.

So, from this kind of pseudo-code, and given that my knowledge of Perl is somewhat limited, I decide to build a series of regexes to extract the tags (always in parentheses) on line 1 and insert them on line 2, provided the words are the same.

My current code looks like this:

use strict;
use warnings;

while ( <DATA> )
{
s/(^\w+)(\(\w+\))?(.+\r)(\s\t)(\1)/$1$2$3$4$5$2/g; #Tag 1st word on line 2 (if it's the same one as the 1st on line 1).
s/(^\w+)(\(\w+\))?\s(\w+)(\(\w+\))?(.+\r)(\s\t)(\1\2)\s(\3)/$1$2 $3$4$5$6$7 $8$4/g; #Tag 2nd word on line 2 (if it's the same one as the 2nd on line 1).
# And so on...

print;
}


__DATA__
The(Art) day(N) started(V) well(Adv), windy(Adj) and(C) humid(Adj), here(Adv) in(P) London(PN),
    The day was windy and quite humid here in London, 
but(P) we(Pr) did(AuxV) not(Adv) mind(V), because(P) we(Pr) had(AuxV) planned(V) to(P) stay(V) indoors(Adv) 
   but no problem at all, mate! We had planned to stay at home anyway! 

Obviously, the output I'm trying to get would look as follows:

The(Art) day(N) started(V) well(Adv), windy(Adj) and(C) humid(Adj), here(Adv) in(P) London(PN), The(Art) day(N) was windy and quite humid(Adj) here(Adv) in(P) London(PN),

but(P) we(Pr) did(AV) not(Adv) mind(V), because(P) we(Pr) had(AuxV) planned(V) to(P) stay(V) indoors(Adv)

but(P) no problem at all, mate! We(Pr) had(AuxV) planned(V) to(P) stay(V) at home anyway!

---

My problem is twofold:

a) The script above (where currently I'm trying to substitute just the first and second words), does not work, although I think the regexes are ok (I've tested them as Search/Replace in BBEdit).

b) I'm not at all sure this would be the right approach to tackle the task at hand (i.e., adding a whole series of increasingly longer and more complex regexes).

Could someone please tell me what I should do to get it to work, or, alternatively, show me a better way to optimize the task? I'm all ears!

Thank you very much indeed.

Answer 1

Something like this?

#!/usr/bin/perl

use strict;
use warnings;

my %tag;

while (<DATA>)
{
    if (m/\((Adj|Art|AuxV|C|N|PN|V)\)/) # it's an example
    {
        # Loop over tagged words; memorize tag for each
        while (m/(\w+)\((\w+)\)/g)
        {
            # If there were already some tags, add to existing
            $tag{$1} = (defined $tag{$1} ? "$tag{$1}|" : "") . $2;
        }
        print;
        next;
    }
    # else
    # Loop over all words; tag the ones we have a tag for
    s/(\w+)/defined $tag{$1} ? "$1($tag{$1})" : $1 /eg;
    print;

    # Flush tags for next iteration
    %tag = ();
}

Note the support for multiple example lines before the untagged line; and the support for multiple tags for a word.