Perl Weekly Challenge: Week 307

Challenge 1:

Check Order

You are given an array of integers, @ints.

Write a script to re-arrange the given array in an increasing order and return the indices where it differs from the original array.

Example 1

Input: @ints = (5, 2, 4, 3, 1)
Output: (0, 2, 3, 4)

Before: (5, 2, 4, 3, 1)
After : (1, 2, 3, 4, 5)

Difference at indices: (0, 2, 3, 4)

Example 2

Input: @ints = (1, 2, 1, 1, 3)
Output: (1, 3)

Before: (1, 2, 1, 1, 3)
After : (1, 1, 1, 2, 3)

Difference at indices: (1, 3)

Example 3

Input: @ints = (3, 1, 3, 2, 3)
Output: (0, 1, 3)

Before: (3, 1, 3, 2, 3)
After : (1, 2, 3, 3, 3)

Difference at indices: (0, 1, 3)

Basically, all we need to do for this one is compare the list of integers (taken from command-line arguments) and compare them to a sorted version of the same list.

This line creates the sorted (in ascending numeric order) list.

my @sorted = @ints.sort({ $^a <=> $^b });

We also need a list to store the indices that differ; @diffs seems an appropriate name for it.

my @diffs;

We find the indices for @ints with .keys() and compare the element at that index with the element at the same index in @sorted.

for @ints.keys -> $i {

If the two elements are not equal, the index is added to @diffs.

    if @ints[$i] != @sorted[$i] {
        @diffs.push($i);
    }
}

Finally we output @diffs. The extra code is just so the output will have the same format as that in the examples.

say q{(}, @diffs.join(q{, }), q{)};

(Full code on Github.)

The Perl version works exactly the same as in Raku.

my @sorted = sort { $a <=> $b }  @ints;
my @diffs;

for my $i (keys @ints) {
    if ($ints[$i] != $sorted[$i]) {
        push @diffs, $i;
    }
}

say q{(}, (join q{, }, @diffs), q{)};

(Full code on Github.)

Challenge 2:

Find Anagrams

You are given a list of words, @words.

Write a script to find any two consecutive words and if they are anagrams, drop the first word and keep the second. You continue this until there is no more anagrams in the given list and return the count of final list.

Example 1

Input: @words = ("acca", "dog", "god", "perl", "repl")
Output: 3

Step 1: "dog" and "god" are anagrams, so dropping "dog" and keeping "god" => ("acca", "god", "perl", "repl")
Step 2: "perl" and "repl" are anagrams, so dropping "perl" and keeping "repl" => ("acca", "god", "repl")

Example 2

Input: @words = ("abba", "baba", "aabb", "ab", "ab")
Output: 2

Step 1: "abba" and "baba" are anagrams, so dropping "abba" and keeping "baba" => ("baba", "aabb", "ab", "ab")
Step 2: "baba" and "aabb" are anagrams, so dropping "baba" and keeping "aabb" => ("aabb", "ab", "ab")
Step 3: "ab" and "ab" are anagrams, so dropping "ab" and keeping "ab" => ("aabb", "ab")

This challenge is much simpler than the wording of the spec might have you think. Actually, you don't need to do all that dropping the first and keeping the second business. To get the right answer, you just need to count the number of unique words ignoring anagrams.

In Raku, you can do this as a one-liner like this:

@*ARGS.map({ $_.comb.sort.join }).unique.elems.say

(Full code on Github.)

First we take the input from command-line arguments (in @*ARGS) and using .map() normalize the form of each word by splitting it into individual characters with .comb(), .sort()ing them and .join()ing them back into a word. If two words have the same form, they are anagrams. We find how many unique normalized words there are with .unique(), count them with .elems() and print the result with .say().

For Perl, I used a slightly different approach.

A hash called %anagrams will hold the normalized words.

my %anagrams;

For each word, its' normalized form will become a key in %anagrams and each time that form occurs, the keys' value will be incremented.

foreach my $word (@words) {
    my $sorted = join q{}, sort split //, $word;
    $anagrams{$sorted}++;
}

Now we can get the number of unique normalized words simply be counting the number of keys.

say scalar %anagrams;

(Full code on Github.)