#!/usr/bin/perl -w
#
# $Revision: 1.3 $ $Date: 2012-07-26 17:11:47-04 $
# $Source: /home/vogelke/bin/RCS/abbreviate,v $
# $Host: sys7.com $
# $UUID: 29130516-960a-3f76-a361-7d4dbf8e60c3 $
#
#<abbreviate: tries to generate sensible abbreviations for words
# Based on http://www.perlmonks.org/index.pl?node_id=464885

use strict;
my $str;
my $word;
my %words;

# Show an example if invoked using "-e" as the argument.
example() if @ARGV && $ARGV[0] eq '-e';

# Otherwise read stdin or a file, splitting each line.
while (<>) {
    chomp;
    $str = $_;

    foreach (split(/\s+/, $str)) {
        next if /[\d\W_]/;
        next if length() <= 4;
        $word = lc($_);
        $words{$_} = abbreviate($word);
    }
}

print "$_ => $words{$_}\n" foreach (sort keys %words);
exit(0);

# ----------------------------------------------------------------------

sub example {
    my @list = qw/abbrev abbreviate abbreviated aeiou
      application characters containing defined excluding
      fewer foreach Input leaves length output parameters print
      readmore result return returns sample section shift string
      subroutine substr takes the title unchanged use using versions
      wantarray while wordlist words/;

    foreach (@list) {
        next if /[\d\W_]/;
        next if length() <= 4;
        $word = lc($_);
        $words{$_} = abbreviate($word);
    }
    print "$_ => $words{$_}\n" foreach (sort keys %words);
    exit(0);
}

# ----------------------------------------------------------------------
# Takes a list of words as parameters and returns a list or string
# containing abbreviations.  Words <= 4 characters are unchanged.
# NOTE: This doesn't just generate truncated versions of a word, it
# attempts to generate a sensible abbreviation.

sub abbreviate {
    my @result;
    local $_;

    foreach (@_) {
        my $abbrev = substr($_, 0, 1, "");

        if (length($_) >= 4) {
            tr/A-Z/a-z/;
            tr/a-z//cd;
            tr/aeiou//d;
            s/(.)\1+/$1/gi;
            s/ck/k/g;
            s/ptn/pn/g;
            s/tng/tg/g;
            s/thr/tr/g;
            s/vnt/vt/g;
            s/ltn/ln/g;
            s/lb/b/g;
            s/tt/t/g;
        }

        $abbrev .= $_;
        push @result, $abbrev;
    }

    return wantarray ? @result : join " ", @result;
}