use strict;
my ($dict, $adda, $line, @words, $word, %wordpl, $k, @lengths, $l, @ad
+dw, $oword, $lo, $i);
$dict="<untitled:Desktop Folder:WORD.LST";
$adda=">untitled:Desktop Folder:addagram.lst";

####
#Open the dictionary file and read each word into @words
####

open (DICT, $dict) or die ("Can't open $dict: $!\n");
while(defined($line=readline(*DICT))) {
    chomp $line;
    push @words, $line;
}
close (DICT);

####
#Create a hash (%wordpl) of arrays, where each element in each array i
+s
#the same length, and the keys represent those lengths
####

foreach $word (@words) {
    push @{ $wordpl{length($word)} }, $word;
}

####
#Read the keys of %wordpl, i.e. the lengths of the elements in the arr
+ay
#@{ $wordpl{length($word)} } in @lengths and sort @length numerically
#in descending order
####

foreach $k (keys %wordpl ) {
    push @lengths, $k;
}
@lengths = sort {$b <=> $a} @lengths;

####
#Start a loop where $l is the length, or the key, for %wordpl.
####


foreach $l (@lengths) {
    @addw=word(%wordpl, $l, $oword, @addw);
}

####
#Start a loop where you pick the a word in @{ $wordpl{$l} }
#and pass that word and $l-1 (index of array of words with one
#less character then aforementioned word) to word1()
####

sub word {
    my ($word, $l, %wordpl, $oword, $p, @addw, $oword);
    %wordpl=$_[0];
    $l=$_[1];
    $oword=$_[2];
    @addw=$_[3];
    foreach $word ( @{ $wordpl{$l} } ) {
        $oword=$word; #define original word
        my $p=$l-1;
        word1($p, $word, %wordpl, $l, $oword, @addw);
    }
    return @addw;
}

####
#Split $word from sub word into an @a, do the same for the word
#picked by WO. If the two words differ by one character, and the
#newest word ($sword) is greater then 3 characters, pass $sword
#and $p-1 (index of array of words with one less character then
#aforementioned word) to word2(). When word2() exits, exit WO
#and return to word(). If the newest word is equal to three 
#characters in length, push that word into the array of 
#add-a-grams and exit WO to word() to restart process
####


sub word1 {
    my ($p, @a, %wordpl, $l, $sword, @b, %seen, @aonly, $item, @addw, 
+$oword);
    $p=$_[0];
    @a=split(//,$_[1]);
    %wordpl=$_[2];
    $l=$_[3];
    $oword=$_[4];
    @addw=$_[5];
    WO: foreach $sword ( @{ $wordpl{$p} } ) {
        @b=split(//,$sword);
        %seen = ();
        @aonly = ();
        @seen{@b}=();
        foreach $item (@a) {
            push (@aonly, $item) unless exists $seen{$item};
        }
        if (length(@aonly)==1) {
            if ($p==3) {
                push @addw, $oword;
                last WO;
            }
            $p--;
            word2($p, $sword, %wordpl, $l, $oword, @addw);
            last WO;
        }
    }
}


####
#Split $sword from sub word1 into an @a, do the same for the word
#picked by WT. If the two words differ by one character, and the
#newest word ($sword) is greater then 3 characters, pass $sword
#and $p-1 (index of array of words with one less character then
#aforementioned word) to word1(). When word1() exits, exit WT
#and return to word(). If the newest word is equal to three 
#characters in length, push that word into the array of 
#add-a-grams and exit WT to word() to restart process
####

sub word2 {
    my ($p, @a, %wordpl, $l, $sword, @b, %seen, @aonly, $item, @addw, 
+$oword);
    $p=$_[0];
    @a=split(//,$_[1]);
    %wordpl=$_[2];
    $l=$_[3];
    $oword=$_[4];
    @addw=$_[5];
    WT: foreach $sword ( @{ $wordpl{$p} } ) {
        @b=split(//,$sword);
        %seen = ();
        @aonly = ();
        @seen{@b}=();
        foreach $item (@a) {
            push (@aonly, $item) unless exists $seen{$item};
        }
        if (length(@aonly)==1) {
            if ($p==3) {
                push @addw, $oword;
                last WT;
            }
            $p--;
            word2($p, $sword, %wordpl, $l, $oword, @addw);
            last WT;
        }
    }
}

####
#determine the longest add-a-gram and print it and the
#others to a file
####


$lo="";
foreach $i (@addw) {
    if ( length($lo)<length($i) ) {
        $lo=$i;
    }
}




open (ADD, $adda) or die ("Cant open $adda: $!\n");
foreach $i (@addw) {
    if ($i ne $lo) {
        print ADD "$i\n";
    } else {
        print ADD "longest: $i\n";
    }
}
close (ADD);
[download]