source: trunk/gsdl/perllib/acronym.pm@ 1361

##########################################################################
#
# acronym.pm --
# A component of the Greenstone digital library software
# from the New Zealand Digital Library Project at the 
# University of Waikato, New Zealand.
#
# Copyright (C) 1999 New Zealand Digital Library Project
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
###########################################################################
#    class to handle acronyms
###########################################################################

use strict;
use diagnostics;

package acronym;

###########################################################################
#    global variables
###########################################################################
# valiables to control the recall/precision tradeoff

#the maximum range to look for acronyms
my $max_offset = 30;
#acronyms must be upper case
my $upper_case = 1;
#acronym case must match
my $case_match = 1;
#minimum acronym length
my $min_def_length = 3;
#minimum acronym length
my $min_acro_length = 3;
#minimum acronym length saving
my $min_length_saving = 3;
#allow recusive acronyms
my $allow_recursive = "";

my @stop_words = split / /, "A OF AT THE IN TO AND VON BEI DER DIE DAS DEM DEN DES UND";
#my @stop_words = split / /, "OF AT THE IN TO AND";

#the text split into an array, one word per element
my @split_text = ();
my @acronym_list = ();


###########################################################################
#    member functions 
###########################################################################


sub new {
    my $self = [
    "", # 0 acronym
    [], # 1 definition
    ];
    bless $self;
}



sub clone  {
    my $self = shift (@_);

    my $copy = new acronym;

    $copy->[0] = $self->[0];
    push @{$copy->[1]}, @{$self->[1]};
    bless $copy;

    return $copy;
}

#return the acronym
sub to_acronym {
    my $self = shift (@_);
    my @array = @{$self->[1]};

    return $self->[0];
}

#return the number of words in the acronym definition
sub words_in_acronym_definition {
    my $self = shift (@_);
    my @array = @{$self->[1]};

    return $#array + 1;
}

#return the number of letters in the acronym definition
sub letters_in_acronym_definition {
    my $self = shift (@_);

    return length($self->to_def_string());
}

#return the number of letters in the acronym definition
sub letters_in_acronym {
    my $self = shift (@_);

    return length($self->to_acronym());
}

#return the acronym definition
sub to_def_string {
    my $self = shift (@_);

    my $result = "";

    # do the definition
    my @array = @{$self->[1]};
    my $i = 0;
    while ($i <= $#array)
    {
    $result = $result . $array[$i];

    if ($i+1 <= $#array)
    {
        $result = $result . " ";
    }
    $i++;
    }
    return $result;
}


#print out the kwic for the acronym
sub to_string_kwic {
    my $self = shift (@_);

    # the list of all possible combinations
    my @list = ();

    my $result = "";

    my $j = 0;
    my @array = @{$self->[1]};
    while ($j <= $#array)
    {

    # do the definition
    my $i = 0;

    #add the key word
    $result = "<td halign=left>"  . $array[$j] . "</td><td halign=right>";

    #add the proceeding words
    while ($i < $j)
    {
        $result = $result .  $array[$i] . " ";
        $i++;
    }
    #add the key word
    $result = $result . "</td><td halign=left>"  . $array[$j] . 
        "</td><td halign=left>";

    #add the trailing words
    $i++;
    while ($i <= $#array )
    {
        $result = $result .  $array[$i] . " ";
        $i++;
    }

    #add the actual acronym

    $result = $result . "</td><td halign=left>" . $self->[0] . "</td>";

    push @list, $result;
    $j++;
    }
    return @list;
}

#this is the one used when building the collection ...
sub to_string {
    my $self = shift (@_);

    my $result = $self->[0] . " ";

    # do the definition
    my @array = @{$self->[1]};
    my $i = 0;
    while ($i <= $#array)
    {
    $result = $result . $array[$i];
    if ($i+1 <= $#array)
    {
        $result = $result . " ";
    }
    $i++;
    }
    return $result;
}

sub check {
    my $self = shift (@_);

    if (length($self->to_acronym()) < $min_acro_length) 
    {
#   print "acronym " . $self->to_string() . " rejected (too short I)\n";
    return 0;
    }
    if ($self->words_in_acronym_definition() < $min_def_length) 
    {
#   print "acronym " . $self->to_string() . " rejected (too short II)\n";
    return 0;
    }
    if ($min_length_saving * $self->letters_in_acronym() > 
    $self->letters_in_acronym_definition()) 
    {
#   print "acronym " . $self->to_string() . " rejected (too short III)\n";
#   print "" . $min_length_saving .
        "|" . $self->letters_in_acronym() .
        "|" . $self->letters_in_acronym_definition() . "\n";
    return 0;
    }
#    print "acronym " . $self->to_string() . " not rejected\n";
    return 1;
}

###########################################################################
#    static functions 
###########################################################################

sub recurse {
    my ($acro_offset,       #offset of word we're finding acronyms for
    $text_offset,       
    $letter_offset, 
    @def_so_far) = @_;

    my $word = $split_text[$text_offset];
    my $acro = $split_text[$acro_offset];
    $word = "" if !defined $word;
    $acro = "" if !defined $acro;
    
#    print "recurse(" . $acro_offset . ", " . $text_offset . ", " . 
#   $letter_offset  . ", " . @def_so_far . ")\n";

    #check for termination ...
    if ($letter_offset >= length($acro))
    {   
    my $acronym = new acronym();
    $acronym->[0] = $acro;
    push @{$acronym->[1]}, @def_so_far;
    if ($acronym->check())
    {
        push @acronym_list, ( $acronym );
    }
#   print "acronym created\n";
    return;
    }
    #check for recursion
    if (!$allow_recursive)
    {
    if ($word eq $acro)
    {
#       print "recursion detected\n";
        return;
    }
    }
    
    #skip a stop-word
    my $i = 0;
    if ($letter_offset != 0)
    {
    while ($i <= $#stop_words)
    {
        if ($stop_words[$i] eq uc($word))
        {
#       print "::found stop word::" . $stop_words[$i] . "\n";
        &recurse($acro_offset,
             $text_offset+1,
             $letter_offset,
             @def_so_far, $word);
        }
        $i++;
    }
    }
    $i = 1;
    #using the first $i letters ...
    while ($letter_offset+$i <= length($acro) )
    {
#   print "". ((substr $word, 0, $i) . " " . 
#       (substr $acro, $letter_offset, $i) . "\n");
    if (((!$case_match) &&
         (uc(substr $word, 0, $i) eq
          uc(substr $acro, $letter_offset, $i)))
        ||
        (($case_match) &&
         ((substr $word, 0, $i) eq
          (substr $acro, $letter_offset, $i))))
    {
#       print "::match::\n";
#       print "" . ((substr $word, 0, $i) . " " . 
#          (substr $acro, $letter_offset, $i) . "\n");
        &recurse($acro_offset,
             $text_offset+1,
             $letter_offset+$i,
             @def_so_far, $word);
    } else {
        return;
    }       
    $i++;
    }
    return;
}


sub acronyms {
    #clean up the text
    my $processed_text =  shift @_;
    $$processed_text =~ s/[^A-Za-z]/ /g;
    $$processed_text =~ s/\s+/ /g;

    #clear some global variables
    @split_text = ();
    @acronym_list = ();

    return &acronyms_from_clean_text($processed_text);
}

sub acronyms_from_clean_text {
    my ($processed_text) = @_;

    @split_text = split / /, $$processed_text;

#    my $i = 0;
#    while ($i <= $#split_text)
#    {
#   print $split_text[$i] . "\n";
#   $i++;
#    }

    my $first = 0;
    my $last = $#split_text +1;
    my $acro_counter = $first;
    
    while ($acro_counter < $last)
    {
    my $word = $split_text[$acro_counter];

    if ((!$upper_case) ||
        (uc($word) eq $word))
    {
        
        if (length $word >= $min_acro_length)
        {
        my $def_counter = 0;
        if ($acro_counter - $max_offset > 0)
        {
            $def_counter = $acro_counter - $max_offset;
        }
        my $local_last = $acro_counter  + $max_offset;
        if ($local_last > $last)
        {
            $local_last = $last;
        }
        while ($def_counter <= $local_last)
        {
            &recurse($acro_counter,$def_counter,0,());
            $def_counter++;
        }
        }
    }
    $acro_counter++;
    }

    return \@acronym_list;
}



sub test {

#    my $blarg = new acronym();
#    my $simple;
#    $simple = 10;
#    $blarg->initialise($simple, $simple, $simple);
#    my $blarg2 = $blarg->clone();
#    print $blarg->to_string();
#    print $blarg2;
#    print "\n";
#    
    my $tla = new acronym();
    $tla->[0] = "TLA";

    my @array = ("Three", "Letter", "Acronym");
#    my $i = 0;
#    while ($i <= $#array)
#    {
#   print @array[$i] . "\n";
#   $i++;
#    }

    print "\n";
    push @{$tla->[1]}, ("Three" );
    push @{$tla->[1]}, ("Letter" );
    push @{$tla->[1]}, ("Acronym" );
    print $tla->to_string(). "\n";
    print "\n";
    print "\n";
    my $tla2 = $tla->clone();
    push @{$tla2->[1]}, ("One");
    push @{$tla2->[1]}, ("Two");
    $tla2->[0] = "ALT";
    print $tla->to_string(). "\n";
    print $tla2->to_string(). "\n";

    print "\n";
    print "\n";

    print "Testing recursion ...\n";
    my $acros = &acronyms("TLA Three Letter Acronym in tla TlA");
    
    foreach my $acro (@$acros)
    {
    if ($acro->check)
        {
           print "accepted: " .$acro->to_string() . "\n";
#           print "|" .  $acro->to_acronym() . "|" .  $acro->to_def_string() .
#              "|" .  $acro->words_in_acronym_definition() .
#              "|" .  $acro->letters_in_acronym_definition() . 
#              "|" .  $acro->letters_in_acronym() . "|\n";
        } else {
#          print "found but rejected: " .$acro->to_string() . "\n";
        }
    }
}

#uncomment this line to test this package
#&test();

1;