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

##########################################################################
#
# 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
###########################################################################

eval "require diagnostics"; # some perl distros (eg mac) don't have this

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 = 4;
#allow recusive acronyms
my $allow_recursive = 0;
#let definitions be all capitals
my $allow_all_caps = 0;

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 = ();


my %acronyms_found_in_collection = ();
my %acronyms_banned_from_collection = ();

my $writing_acronyms = 1;
my $accumulate_acronyms = 1;
my $markup_accumulate_acronyms = 1;
my $markup_local_acronyms = 1;



###########################################################################
#   file saving / loading stuff
###########################################################################

sub initialise_acronyms {

    my $local_max_offset = $max_offset;
    my $local_upper_case = $upper_case;
    my $local_case_match = $case_match ;
    my $local_min_def_length = $min_def_length;
    my $local_min_acro_length = $min_acro_length;
    my $local_min_length_saving = $min_length_saving;
    my $local_allow_recursive = $allow_recursive;
    my $local_allow_all_caps = $allow_all_caps;
    my @local_stop_words = @stop_words;
    
    
    # the file to collate acronyms into

    my $def_acronym_acc_file_pm = '&util::filename_cat($ENV{\'GSDLCOLLECTDIR\'}, "etc","acronym_definitions.pm");';
    my $acronym_accumulate_file = eval { $def_acronym_acc_file_pm };
    my $acronym_options_file = &util::filename_cat($ENV{'GSDLCOLLECTDIR'},"etc","acronym_options.pm");


    my $file_text = "";
    if (open ACRONYM_HANDLE, "<$acronym_options_file")
    {
    $file_text = do { local $/; <ACRONYM_HANDLE> };  
    }
    if ($file_text eq "")
    {
    print STDERR "failed to open $acronym_options_file\n";
    open ACRONYM_HANDLE, ">$acronym_options_file\n";
    print ACRONYM_HANDLE "use util;\n";
    print ACRONYM_HANDLE "#Config file for acronym extraction. EDIT THIS FILE, it should\n";
    print ACRONYM_HANDLE "#not be overridden by the software. It's read by GSDL using perl's\n";
    print ACRONYM_HANDLE "#'eval' function, so pretty much anything that's valid in perl is \n";
    print ACRONYM_HANDLE "#valid here.\n\n";
    print ACRONYM_HANDLE "#Quite a few things here are defined in terms of recall and precision\n";
    print ACRONYM_HANDLE "#which are the key measures from Information Retreval (IR). If you\n";
    print ACRONYM_HANDLE "#don't understand recall and precision, any good IR textbook should\n";
    print ACRONYM_HANDLE "#explain them fully \n\n";
    print ACRONYM_HANDLE "#the maximum range to look for acronyms (raise to raise precision)\n"; 
    print ACRONYM_HANDLE "\$local_max_offset = $max_offset;\n\n"; 
    print ACRONYM_HANDLE "#acronyms must be upper case (0 = false, 1 = true (high precision))\n";
    print ACRONYM_HANDLE "\$local_upper_case = $upper_case;\n\n";
    print ACRONYM_HANDLE "#acronym case must match (0 = false, 1 = true (high precision))\n";
    print ACRONYM_HANDLE "\$local_case_match = $case_match;\n\n";
    print ACRONYM_HANDLE "#minimum acronym length (raise to raise precision)\n";
    print ACRONYM_HANDLE "\$local_min_def_length = $min_def_length;\n\n";
    print ACRONYM_HANDLE "#let definitions be all capitals\n";
    print ACRONYM_HANDLE "\$local_allow_all_caps = $allow_all_caps;\n\n";
    print ACRONYM_HANDLE "#minimum acronym length (raise to raise precision)\n";
    print ACRONYM_HANDLE "\$local_min_acro_length = 3;\n\n";
    print ACRONYM_HANDLE "#minimum acronym length saving (raise to raise precision)\n";
    print ACRONYM_HANDLE "\$local_min_length_saving = 4;\n\n";
    print ACRONYM_HANDLE "#allow recusive acronyms (0 = false (high precision), 1 = true)\n";
    print ACRONYM_HANDLE "\$local_allow_recursive = 0;\n\n";
    print ACRONYM_HANDLE "#stop words-words allowed in acronyms (the multi-lingual version\n";
    print ACRONYM_HANDLE "#slows down acronym extraction slightly so is not the default)\n";
    print ACRONYM_HANDLE "#\@local_stop_words = split / /, \"A OF AT THE IN TO AND VON BEI DER DIE DAS DEM DEN DES UND DE DU A LA LE LES L DANS ET S\";\n";
    print ACRONYM_HANDLE "\@local_stop_words = split / /, \"OF AT THE IN TO AND\";\n"; 
    print ACRONYM_HANDLE "\n"; 
    print ACRONYM_HANDLE "#the file to collate acronyms into\n";
    print ACRONYM_HANDLE "\$acronym_accumulate_file = $def_acronym_acc_file_pm\n";
    print ACRONYM_HANDLE "\n";
    print ACRONYM_HANDLE "# any acronym definitions which should always be marked up can be copied here\n";
    print ACRONYM_HANDLE "# from the acronym_accumulate_file file ...\n";
    print ACRONYM_HANDLE "# \n";
    print ACRONYM_HANDLE "# \n";
    print ACRONYM_HANDLE "# \n";
    print STDERR "written new options file to $acronym_options_file...\n";
    } else {
    print STDERR "read file $acronym_options_file...\n";
    eval $file_text ;
    warn $@ if $@;
    print STDERR "evaluated file $acronym_options_file...\n";
    }

    $max_offset = $local_max_offset;
    $upper_case = $local_upper_case;
    $case_match = $local_case_match ;
    $min_def_length = $local_min_def_length;
    $min_acro_length = $local_min_acro_length;
    $min_length_saving = $local_min_length_saving;
    $allow_recursive = $local_allow_recursive;
    $allow_all_caps = $local_allow_all_caps;
    @stop_words = @local_stop_words;
        

    &read_all_acronyms_from_file($acronym_accumulate_file);
#    rename $acronym_file, $acronym_file . "." . int(rand (2<<7)). 
#   int(rand (2<<7)). int(rand (2<<7)). int(rand (2<<7));
    if ($writing_acronyms && open ACRONYM_HANDLE, ">$acronym_accumulate_file")
    {
    print ACRONYM_HANDLE "#This is an automatically generated file.\n";
    print ACRONYM_HANDLE "#\n";
    print ACRONYM_HANDLE "#If you edit this file and it will be overwritten the next\n";
    print ACRONYM_HANDLE "#time the acronym code runs unless you set the file to \n";
    print ACRONYM_HANDLE "#read-only. \n";
    print ACRONYM_HANDLE "#\n";
    print ACRONYM_HANDLE "#start of acronyms...\n";
    $writing_acronyms = 1;
    } else {
    warn "failed to open $acronym_accumulate_file for writing\n";
    $writing_acronyms = 0;
    }
}

#close the list of accumulated acronyms
sub finalise_acronyms {
    if ($writing_acronyms)
    {
    print ACRONYM_HANDLE "#end of acronyms.\n";  
    close ACRONYM_HANDLE;
    }
}

#eval a file of accumulated acronyms
sub read_all_acronyms_from_file {
    my ($acronym_accumulate_file) = @_;

    my $file_text = " ";
    if (open ACRONYM_HANDLE, "<$acronym_accumulate_file")
    {
    $file_text = do { local $/; <ACRONYM_HANDLE> };  
    } else {
    print STDERR "failed to open $acronym_accumulate_file for reading (this is the first pass?).\n";
    }
    eval $file_text;
    #promotes warnings/errors from evaluated file to current context 
    warn $@ if $@;
}

#called from within the file of accumulated acronyms to indicate a good acronym
sub add {
    my $self = shift (@_);
    if (defined ($acronyms_found_in_collection{$self->[0]}))
    {
    my $def = $self->to_def_string();
    if ($acronyms_found_in_collection{$self->[0]} =~ m/(^|\|)$def(\||$)/)
    {
        return;
    }
    $acronyms_found_in_collection{$self->[0]} = 
        $acronyms_found_in_collection{$self->[0]} . "|" . $self->to_def_string();
    } else {
    $acronyms_found_in_collection{$self->[0]} = $self->to_def_string();
    }
}

#called from within the file of accumulated acronyms to indicate a bad acronym
sub ban {
    my $self = shift (@_);
    
    if (!defined $acronyms_banned_from_collection{$self->[0]})
    {
    $acronyms_banned_from_collection{$self->[0]} = $self->to_def_string();
    } else {
    $acronyms_banned_from_collection{$self->[0]} = $acronyms_banned_from_collection{$self->[0]} . "|" . $self->to_def_string();
    }
}


#write a good acronym to the accumulated acronyms file
sub write_to_file {
    my $self = shift (@_);
    if ($writing_acronyms)
    {
    print ACRONYM_HANDLE "new acronym(\"$self->[0]\",\"" . 
        $self->to_def_string() . 
        "\")->add();\n";
    }
}


###########################################################################
# mark functionality    
###########################################################################

#small routine to sort by length 
sub sort_by_length {
    length($b) <=> length($a) or $a cmp $b
}

sub markup_acronyms {
    my  $text = shift (@_);
    my  $verbosity_obj = shift (@_);
    if (defined $text)
    {
    for my $acro (sort sort_by_length keys %acronyms_found_in_collection)
    {
        $text  =~ s/^((?:[^\<\n]|(?:\<[^\>\n]*\>))*)$acro([^\<A-Z])/$1$acro\<img src=\"\" width=8 height=8 alt=\"$acronyms_found_in_collection{$acro}\"\>$2/gm;
        printf STDERR " " .  $acro . ","
        if ($verbosity_obj->{'verbosity'} >= 2);
    }
    }
    return $text;
}



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


sub new {
    my $trash = shift (@_); 
    my $acro = shift (@_); 
    my $def  = shift (@_); 
    
    my $self = [
        "", # 0 acronym
        [], # 1 definition
               ];
    
    $self->[0] = $acro                    if defined $acro;
    push @{$self->[1]},  split / /, $def  if defined $def;
    
    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;
    }
    if (!$allow_all_caps && 
    $self->to_def_string() eq uc($self->to_def_string()))
    {
#   print "acronym " . $self->to_string() . " rejected (all upper)\n";
    return 0;
    }
    if (!$allow_all_caps)
    {
    my $upper_count = 0;
    my $lower_count = 0;
    my @letters = $self->to_def_string();
    for my $letter (split //, $self->to_def_string())
    {
        if ($letter eq uc($letter))
        { 
        $upper_count++;
        } else {
        $lower_count++;
        }       
    }
    return 0 if ($upper_count > $lower_count);
    }
    if (!$allow_recursive && $self->to_def_string() =~ /$self->to_acronym()/i )
    {
    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;
}

#the main
sub acronyms {
    #clean up the text
    my $processed_text =  shift @_;
    $$processed_text =~ s/<[^>]*>/ /g;
    $$processed_text =~ s/\W/ /g;
    $$processed_text =~ s/[0-9_]/ /g;
    $$processed_text =~ s/\s+/ /g;
    $$processed_text =~ s/(\n|\>)References.*/ /i;
    $$processed_text =~ s/(\n|\>)Bibliography.*/ /i;
    $$processed_text =~ s/(\n|\>)(Cited Works?).*/ /i;
    $$processed_text =~ s/(\n|\>)(Works? Cited).*/ /i;

    #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;