Anagram generator

Using the unixdict.txt word file by default.

unit sub MAIN ($in is copy = '', :$dict = 'unixdict.txt');

say 'Enter a word or phrase to be anagramed. (Loading dictionary)' unless $in.chars;

# Load the words into a word / Bag hash
my %words = $dict.IO.slurp.lc.words.race.map: { .comb(/\w/).join => .comb(/\w/).Bag };

# Declare some globals
my ($phrase, $count, $bag);

loop {
    ($phrase, $count, $bag) = get-phrase;
    find-anagram Hash.new: %words.grep: { .value ⊆ $bag };
}

sub get-phrase {
    my $prompt = $in.chars ?? $in !! prompt "\nword or phrase? (press Enter to quit) ";
    $in = '';
    exit unless $prompt;
    $prompt,
    +$prompt.comb(/\w/),
    $prompt.lc.comb(/\w/).Bag;
}

sub find-anagram (%subset, $phrase is copy = '', $last = Inf) {
    my $remain = $bag ∖ $phrase.comb(/\w/).Bag;        # Find the remaining letters
    my %filtered = %subset.grep: { .value ⊆ $remain }; # Find words using the remaining letters
    my $sofar = +$phrase.comb(/\w/);                   # Get the count of the letters used so far
    for %filtered.sort: { -.key.chars, ~.key } {       # Sort by length then alphabetically then iterate
        my $maybe = +.key.comb(/\w/);                  # Get the letter count of the maybe addition
        next if $maybe > $last;                        # Next if it is longer than last - only consider descending length words
        next if $maybe == 1 and $last == 1;            # Only allow one one character word
        next if $count - $sofar - $maybe > $maybe;     # Try to balance word lengths
        if $sofar + $maybe == $count {                 # It's an anagram
            say $phrase ~ ' ' ~ .key and next;         # Display it and move on
        } else {                                       # Not yet a full anagram, recurse
            find-anagram %filtered, $phrase ~ ' ' ~ .key, $maybe;
        }
    }
}

Punctuation, capitalization and (in some cases) word order manually massaged.

Last updated

Was this helpful?