Perl Weekly Challenge: Week 394
Challenge 1:
Alternate Case
You are given a string containing an equal number of uppercase and lowercase English letters.
Write a script to the minimum number of adjacent character swaps needed to turn the given string into an alternate case string.
Example 1
Input: $str = "aAbB"
Output: 0
Example 2
Input: $str = "AAbb"
Output: 1
Swap 1: "AbAb"
Example 3
Input: $str = "AAAbbb"
Output: 3
Swap 1: "AAbAbb"
Swap 2: "AbAAbb"
Swap 3: "AbAbAb"
Example 4
Input: $str = "aABb"
Output: 1
Swap 1: "aAbB"
Example 5
Input: $str = "bBBAaa"
Output: 2
Swap 1: "BbBAaa"
Swap 2: "BbBaAa"
First we split up $str into an array of individual characters.
my @characters = $str.comb;
Then we record the positions of the uppercase characters into another array.
my @uppers;
for @characters.keys -> $pos {
if @characters[$pos] ~~ /<[A..Z]>/ {
@uppers.push($pos);
}
}
We have to solve this task twice because there are two kinds of alternation,
uppercase then lowercase or lowercase then uppercase. So @swaps will have
two elements, one for each answer.
my @swaps;
for 0, 1 -> $offset {
$swap counts how many swaps were made.
my $swap = 0;
$i is the index of the current element in @uppers we are looking at. Initially
it is 0, the first uppercase character in $str.
my $i = 0;
In a loop we move each uppercase letter to the position indicated by its' corresponding
slot in @uppers. The absolute distance is the number of swaps needed for this letter; that
number is added to $swap.
for @characters.keys -> $pos {
if $pos % 2 == $offset {
$swap += (@uppers[$i] - $pos).abs;
$i++;
}
}
When we have gone through all the characters, the final value of $swap is added
to @swaps.
@swaps.push($swap);
}
As mentioned previously, there will be two values in @swaps. Whichever is the
smaller, will be printed out as the answer.
say @swaps.min;
For Perl, we don't need any extra code to reproduced the Raku version.
my @characters = split //, $str;
my @uppers;
for my $pos (keys @characters) {
if ($characters[$pos] =~ /[A-Z]/) {
push @uppers, $pos;
}
}
my @swaps;
for my $offset (0, 1) {
my $swap = 0;
my $i = 0;
for my $pos (keys @characters) {
if ($pos % 2 == $offset) {
$swap += abs($uppers[$i] - $pos);
$i++;
}
}
push @swaps, $swap;
}
Except, Perl doesn't have .min() so have to find the lesser value this way instead.
say 0+($swaps[0] < $swaps[1]) ? $swaps[0] : $swaps[1];
Challenge 2:
Alternating Vowel Consonents
You are given three strings containing English alphabetic characters.
Find all the longest contiguous substrings common to all three strings that strictly alternate between vowels and consonants.
Example 1
Input: @str = ("relocate", "delocate", "allocate")
Output: ("locate")
Example 2
Input: @str = ("apple", "banana", "cherry")
Output: ()
Example 3
Input: @str = ("navigate", "cavity", "gravity")
Output: ("avi")
Example 4
Input: @str = ("pedalgia", "pedalboard", "pedantic")
Output: ("peda")
Example 5
Input: @strings = ("schoolmaster", "schoolhouse", "schooling")
Output: ("ho", "ol")
We split up the first string into an array of individual characters.
my @characters = $str1.comb;
We will also need to store the longest strings found. I did it as a hash where the keys are the strings and the values their lengths. One more thing is the length of the current longest string.
my %longest;
my $longestLength = 0;
Treating each letter in @characters as a starting position, we try to extend
it into a longer string while the letters continue to alternate.
How do we know if the characters are alternating? We classify each letter as a vowel or consonant and compare it to the category of the previous letter if any.
for @characters.keys -> $start {
my $previousCategory;
for $start .. @characters.end -> $end {
# Classify each letter as a vowel or consonant, ignoring its case.
my $category = @characters[$end].lc ~~ /<[aeiou]>/
?? 'vowel'
!! 'consonant';
If the current letter and the previous letter have the same category, this substring
is a bust. An optimization we can make is that if this substring failed, all longer
substrings beginning at $start will also fail so we can stop searching altogether
and move on to the next letter.
if $previousCategory.defined && $category eq $previousCategory {
last;
}
If not, the category of the current letter becomes the previous category.
$previousCategory = $category;
Now we know there is an alternating substring in $str1, Is it also in $str2 and
$str3? If not, we abandon it and move on to the next letter.
my $candidate = @characters[$start .. $end].join;
unless $str2.contains($candidate) && $str3.contains($candidate) {
next;
}
We measure the length of the current substring and if it is longer than the previous
$longestLength we can replace shorter results or collect every distinct tie for
the longest.
my $length = $end - $start + 1;
if $length > $longestLength {
%longest = $candidate => True;
$longestLength = $length;
} elsif $length == $longestLength {
%longest{$candidate} = True;
}
}
}
We print out our final results. The extra code is to make the output the same style as in the spec.
say q{(} ~ %longest.keys.sort.map({ "\"$_\"" }).join(q{, }) ~ q{)};
This is the Perl version.
my @characters = split //, $str1;
my %longest;
my $longestLength = 0;
for my $start (keys @characters) {
my $previousCategory;
for my $end ($start .. scalar @characters - 1) {
my $category = (lc $characters[$end]) =~ /[aeiou]/
? 'vowel'
: 'consonant';
if (defined $previousCategory && $category eq $previousCategory) {
last;
}
$previousCategory = $category;
my $candidate = join q{}, @characters[$start .. $end];
unless ($str2 =~ /$candidate/ && $str3 =~ /$candidate/) {
next;
}
my $length = $end - $start + 1;
if ($length > $longestLength) {
%longest = ($candidate => true);
$longestLength = $length;
} elsif ($length == $longestLength) {
$longest{$candidate} = true;
}
}
}
say q{(} . (join q{, }, map { "\"$_\"" } sort keys %longest) . q{)};