Larry Wall Says...

Enjoy.

Larry Wall
lwall@netlabs.com

What? Oh, yes, the program. Here it is. It's called "alt", which is, of course, "tla" spelled backwards.

#!/usr/bin/perl

$THRESHOLD = 2;

srand;
while (<>) {
    next unless /^([A-Z]\S+): */;
    $key = $1;
    $acro{$key} = $';
    @words = split(/\W+/,$');
    unshift(@words,$key);
    $off = 0;
    foreach $word (@words) {
        next unless $word =~ /^[A-Z]/;
        *w = $&;
        vec($w{$word}, $off++ % 6, 1) = 1;
    }
}

foreach $letter (A .. Z) {
    *w = $letter;
    @w = keys %w;
    if (@w < $THRESHOLD) {
        @d = `egrep '^$letter' /usr/dict/words`;
        chop @d;
        push(@w, @d);
    }
}

foreach $key (sort keys %acro) {
    $off = 0;
    $acro = $acro{$key};
    $acro =~ s/((([A-Z])[A-Z]*)[a-z]*)/ &pick($3, $2, $1, ++$off) || $& /eg;
    print "$key: $acro";
}

sub pick {
    local($letter, $prefix, $oldword, $off) = @_;
    $i = 0;
    if (length($prefix) > 1 && index($key,$prefix) < 0) {
        if ($prefix eq $oldword) {
            $prefix = '';
        }
        else {
            $prefix = $letter;
        }
    }
    if (length($prefix) > 1) {
        local(*w) = substr($prefix,0,1);
        do {
            $word = $w[rand @w];
        } until $word ne $oldword && $word =~ /^$prefix/i || ++$i > 30;
        $word =~ s/^$prefix/$prefix/i;
        $word;
    }
    elsif (length($prefix) == 1) {
        local(*w) = $prefix;
        do {
            $word = $w[rand @w];
        } until $word ne $oldword && vec($w{$word}, $off, 1) || ++$i > 10;
        $word = "\u\L$word" if $word =~ tr/a-z/A-Z/;
        $word;
    }
    else {
        local(*w) = substr($oldword,0,1);
        do {
            $word = $w[rand @w];
        } until $word ne $oldword && $word =~ tr/a-z/A-Z/ == 0 || ++$i > 30;
        $word;
    }
}