Task — Similar words

You are given an array of words made up of alphabetic characters only. Write a script to find the number of pairs of similar words. Two words are similar if they consist of the same characters.

From the examples we can deduce that this means that neither member of the pair contains a letter that is not present in the other.

Examples

Example 1
Input: @words = ("aba", "aabb", "abcd", "bac", "aabc")
Output: 2

Pair 1: similar words ("aba", "aabb")
Pair 2: similar words ("bac", "aabc")

Example 2
Input: @words = ("aabb", "ab", "ba")
Output: 3

Pair 1: similar words ("aabb", "ab")
Pair 2: similar words ("aabb", "ba")
Pair 3: similar words ("ab", "ba")

Example 3
Input: @words = ("nba", "cba", "dba")
Output: 0

Analysis

My approach to this task is as follows:

• Loop over all the words.
• For each word extract an alphabetically sorted string of its unique characters, for example 'letter' => 'elrt'.
• Compare this string with those from all previous ones, and if they match, we have a pair.

Try it 

Script

#!/usr/bin/perl

use v5.16;    # The Weekly Challenge - 2023-09-04
use utf8;     # Week 233 task 1 - Similar words
use strict;   # Peter Campbell Smith
use warnings; # Blog: http://ccgi.campbellsmiths.force9.co.uk/challenge

similar_words('aba', 'aabb', 'abcd', 'bac', 'aabc');
similar_words('aabb', 'ab', 'ba');
similar_words('nba', 'cba', 'dba');
similar_words(qw[discovery cervid ciders coders corves cosied cosier covers coveys 
    credos cyders decors decoys descry devoir dicers dioecy divers dories drives droves 
    scored scried scrive videos vireos voiced voicer voices voider]);

sub similar_words {
    
    my (@words, $j, $k, $pairs, $rubric);
    @words = @_;
    $pairs = 0;
    
    # sort letters within each word and remove duplicates
    for ($j = 0; $j < scalar @words; $j ++) {
        $words[$j] = join('', sort(split('', $words[$j])));
        $words[$j] =~ s|(.)\1+|$1|g;
        
        # compare the result with all previous results
        if ($j > 0) {
            for ($k = 0; $k < $j; $k ++) {
                
                # we have a pair
                if ($words[$k] eq $words[$j]) {
                    $pairs ++;
                    $rubric .= qq[        Pair $pairs: similar words ('$_[$j]', '$_[$k]')\n];
                }
            }
        }
    }
    
    # report
    say qq[\nInput:  \@words = ('] . join(qq[', '], @_) . qq[')];
    say qq[Output: $pairs];
    say substr($rubric, 0, -1) if $pairs;
}

Output

Input:  @words = ('aba', 'aabb', 'abcd', 'bac', 'aabc')
Output: 2
        Pair 1: similar words ('aabb', 'aba')
        Pair 2: similar words ('aabc', 'bac')

Input:  @words = ('aabb', 'ab', 'ba')
Output: 3
        Pair 1: similar words ('ab', 'aabb')
        Pair 2: similar words ('ba', 'aabb')
        Pair 3: similar words ('ba', 'ab')

Input:  @words = ('nba', 'cba', 'dba')
Output: 0

Input:  @words = ('discovery', 'cervid', 'ciders', 
   'coders', 'corves', 'cosied', 'cosier', 'covers', 
   'coveys', 'credos', 'cyders', 'decors', 'decoys', 
   'descry', 'devoir', 'dicers', 'dioecy', 'divers', 
   'dories', 'drives', 'droves', 'scored', 'scried', 
   'scrive', 'videos', 'vireos', 'voiced', 'voicer', 
   'voices', 'voider')
Output: 13
        Pair 1: similar words ('covers', 'corves')
        Pair 2: similar words ('credos', 'coders')
        Pair 3: similar words ('decors', 'coders')
        Pair 4: similar words ('decors', 'credos')
        Pair 5: similar words ('descry', 'cyders')
        Pair 6: similar words ('dicers', 'ciders')
        Pair 7: similar words ('drives', 'divers')
        Pair 8: similar words ('scored', 'coders')
        Pair 9: similar words ('scored', 'credos')
        Pair 10: similar words ('scored', 'decors')
        Pair 11: similar words ('scried', 'ciders')
        Pair 12: similar words ('scried', 'dicers')
        Pair 13: similar words ('voider', 'devoir')