Perl Weekly Challenge Archives

Perl Weekly Challenge #235 - Splicing and Dicing

Hi everybody, we've got another two challenges this week, so let's dive into them!

Remove One

The goal is to see if there's any one number that can be removed to make the set sorted in increasing order. Here's the code:

#!/usr/bin/perl
use v5.36;

my $success = 0;
REMOVAL: for my $removal (0 .. $#ARGV) {
    my @modified = @ARGV;
    splice(@modified, $removal, 1);
    for my $scan (1 .. $#modified) {
        if($modified[$scan] <= $modified[$scan - 1]) {
            next REMOVAL;
        }
    }
    $success = 1;
    last;
}

say ($success ? 'true' : 'false');

We have a labelled outer loop for the numbers we choose to remove. $removal is set to the index of each number we attempt to remove, then we copy the array, remove that number, and scan the result to make sure they all are increasing. If they don't, we skip this number and move on.

If we succeed, we set our flag and exit the loops and print the result.

Duplicate Ones

The next one is an array shifting challenge. We want to insert a duplicate of each 0, shifting everything to the right, and popping off the list to keep the length the same.

Here's the code:

#!/usr/bin/perl
use v5.36;

my @ints = @ARGV;
for(my $i = 0; $i <= $#ints; $i++) {
    if($ints[$i] == 0) {
        splice(@ints, $i, 0, 0);
        pop(@ints);
        $i++;
    }
}

say('(', join(', ', @ints), ')');

This one's also really quite simple. We scan the array, use splice to insert a 0, pop the last number off the end of the array, and skip over the 0 we just inserted. It's that simple!

Both of this week's solutions make use of splice() to insert and remove array elements, something I haven't used a lot before.

Stay tuned for next week's challenge, which should come out Monday!

Perl Weekly Challenge #234 - Sharing is Caring

Hi everybody! Back this week with a (surprisingly long) solution to just Task 1 of the weekly challenge. Task 2 makes no sense to me at all because it seems like examples 1 and 3 disagree with each other. Just sticking to one challenge for that reason. Anyways, let's dive into it!

The goal here is to find the letters that all the provided words share. Here's the code:

#!/usr/bin/perl
use v5.36;

my @words;
my %result_chars;

for(@ARGV) {
    push(@words, [split(//, $_)])
}
@words = sort {$#{$a} <=> $#{$b}} @words;
$result_chars{$_}++ for @{$words[0]};

for my $word (1..$#words) {
    for my $key (keys(%result_chars)) {
        my $occurrences = grep(/$key/, @{$words[$word]});
        if($occurrences == 0) {
            delete($result_chars{$key});
            next;
        } elsif($occurrences <= $result_chars{$key}) {
            $result_chars{$key} = $occurrences;
        }
    }
}

for my $char (@{$words[0]}) {
    if($result_chars{$char}) {
        $result_chars{$char}--;
        say $char;
    }
}

First we make a 2D array of the characters in all the words. That way we only have to split the words up once, instead of repeatedly as we seek through them. It does mean a bit more complexity to deal with a matrix, unfortunately.

We also sort the words by length so the shortest one is first, then make a histogram of all the letters in it. Now it's important to keep all the letters and not remove duplicates, because we have to print duplicates as we see from the example that prints "e, l, l".

We loop through each word, then loop through each letter in the first word (keys of the histogram) and search the current word for that letter. If we don't find it, we delete the letter from the histogram. If we find fewer occurrences than in the histogram, we remove some from the histogram to show how many we actually can make in the current word. If that letter is in the histogram fewer or equal times to the occurrences in the word, we move on to the next letter.

Next, for printing, we would have to have multiple loops to loop through the histogram and remove one instance at a time, so instead I decided I should simply search the original word for characters that successfully passed the test of the other words, then print those characters.

When I first started, I thought this would be super easy, but I discovered complications numerous times through the challenge. Perhaps others will have some better ideas of solutions I can learn from. Unfortunately Flavio Poletti hasn't been doing his solutions recently, I always enjoyed them very much, but be sure to check out past solutions of his at github.polettix.it.

Hopefully I'll be back next week with more solutions!

Perl Weekly Challenge #233 - Similar Words and Frequency Sort

Hello everybody! For this week's weekly challenge I thought the challenges looked really easy, but they both had a couple slight complicating factors. Also, this was the first time I've used sub signatures.

Similar Words

For this one, we're looking for words that share all characters. We print out each pair of countries.

#!/usr/bin/perl
use v5.36;

my @words = @ARGV;
my $matched = 0;
for (my $i = 0; $i <= $#ARGV - 1; $i++) {
    my $start_word = $words[$i];
    my %start_chars = map {$_ => 1} split(//, $start_word);

    for (my $j = $i + 1; $j <= $#ARGV; $j++) {
        my $match_word = $words[$j];
        my %match_chars = map {$_ => 1} split(//, $match_word);

        if (hashes_equal(\%start_chars, \%match_chars)) {
            say $start_word . ", " . $match_word;
            $matched = 1;
        }
    }
}
say 0 unless $matched;

sub hashes_equal ($start_ref, $match_ref) {
    my %start_chars = %{$start_ref};
    my %match_chars = %{$match_ref};

    if (scalar keys %start_chars == scalar keys %match_chars) {
        foreach (keys %start_chars) {
            if (!defined($match_chars{$_})) {
                return;
            }
        }
        return 1;
    } else {
        return;
    }
}

It essentially boils down to looping through all combinations of words in two loops, converting each word to a hash containing all unique characters. hashes_equal makes sure that the hashes have the same number of keys, then tries the keys and makes sure they have the same values.

Frequency Sort

For this one, we're sorting numbers by how frequently they occur, in increasing order, except when they share a frequency, then we sort them decreasing by value.

Here's the code:

#!/usr/bin/perl
use v5.36;

my %ints;
$ints{$_}++ foreach @ARGV;

my %ints_by_occurrence;
my @results;

foreach (keys %ints) {
    push @{$ints_by_occurrence{$ints{$_}}}, $_;
}
foreach (sort keys %ints_by_occurrence) {
    my $frequency = $_;
    foreach (sort {$b <=> $a} @{$ints_by_occurrence{$frequency}}) {
        my $number = $_;
        for (1..$frequency) {
            push @results, $number;
        }
    }
}
say $_ foreach @results;

This time we're making a hash of arrays, where %intsbyoccurrence uses frequencies as the key, and an array of numbers as the value. %ints contains the initial histogram which is reversed into %intsbyoccurrence. We sort once by frequency, then we sort each array of a given frequency by value, which is pushed onto the results array in the proper order.

Those are my solutions to this week's challenge! Hopefully I'll have more for both challenges next week. See you then.

Perl Weekly Challenge #231 - Not Going to Extremes but Accepting Senior Citizens

Hi everybody! In this week's weekly challenge, we're searching for anything but the minimum or maximum in a dataset, and searching for senior citizens on a plane.

Min And Max

This challenge is a very interesting one, because obviously the easiest solution in terms of development is to sort and filter the first and last element. However, that is O(n log n) and it's very little added complexity to do the O(n) solution with a single-pass filter.

my %hist;
$hist{$_} = 1 for @ARGV;

say "You didn't provide two or more arguments." and exit if scalar keys %hist < 2;
say "-1" and exit if scalar keys %hist == 2;

my ($max, $min);
for (keys %hist) {
    $max = $_ if (!defined($max) || $_ > $max);
    $min = $_ if (!defined($min) || $_ < $min);
}
for (keys %hist) {
    say $_ if $_ != $max and $_ != $min;
}

First we make a histogram hash where duplicates are filtered out. Using the histogram, we exit with a failure or -1 if there are 1 or 2 unique numbers left. As we scan the histogram keys we keep track of the minimum/maximum values, then one more pass to print all of them out.

Senior Citizens

Contrary to the typical pattern of the second challenge being harder, this one's incredibly simple. We're looking for any senior citizens in a dataset made up of "9999999999A1122”, where 9 denotes the phone number, A the sex, 1 the age and 2 the seat number.

The simplest way I can think of is substr():

my $count;
for (@ARGV) {$count++ if substr($_, 11, 2) >= 60}
say $count // 0;

That's it! We just count up every time substr() comes up with someone 60 or over. Then we print out the result.

That's it for this week! Hopefully I'll be back with another blog post next week.

Perl Weekly Challenge #230 - Turning Numbers into Characters and Words into Numbers

Hi everybody! I'm finally back with another PWC/TWC blog post for week 230.

Separate Digits

For the first challenge we want to split all the numbers in the array into single digits. Here's the code:

use v5.36;
my @nums;
push(@nums, split(//, $_)) for @ARGV;
say $_ for @nums;

It very simply splits anything in its arguments into individual characters and pushes them onto a new array.

Count Words

Our second challenge asks us to count the words that start with the given prefix. Here's a 4-liner (minus boilerplate) to help us out with this one:

use v5.36;
my $pattern = shift;
my $count;
for (@ARGV) {$count++ if $_ =~ /^$pattern/}
say $count // 0;

We take the pattern and then add to the count if our regex prefix matches the start of any of the strings in the arguments.

That's all for this week, two nice easy challenges! Hope I'll be able to post again next week maybe.

Perl Weekly Challenge #225 - Words to the Max and Diff Sum

Hi all! Back this week with both solutions to The Weekly Challenge for once. We've got a word counting challenge and one that I really don't know how to explain. You have to see the challenge to understand it.

Max Words

So this challenge is just to tell us what the longest sentence in a set of sentences is. How many words does it have? A very simple easy solution can follow:

my $highest;
foreach (@ARGV) {
    my @words = split(/ /, $_);
    shift @words if !$words[0];
    $highest = scalar @words if scalar @words > $highest;
}
say $highest;

We take the input sentences (in quotes) and split them by spaces. Now, I tested and splitting by space puts an empty element at the start of the array, so if there is such an empty element we remove it with the shift. Then we check the number of words in this sentence and replace the existing champion if this one is the highest. That one's pretty simple and took just about 15 minutes to write and test.

Left Right Sum Diff

No idea what the actual practical purpose of this one is, but it's an interesting challenge and a lot simpler than I initally thought, although I realized in the middle there were some additional cases to handle from what I was thinking.

The goal is to split a list of integers into @left, made of (0, $ints[0], $ints[0] + $ints[1], etc.) and @right, made of 'etc., $ints[-2] + $ints[-1], $ints[-1], 0). Then we iterate through and for each pair we take the absolute difference between$left[$]and$right[$]`.

So here's the code:

my @ints = @ARGV;
my (@left, @right, @diff);
push @left, 0;
unshift @right, 0;
if ($#ints) {
    foreach (1..$#ints) {
        push @left, $left[$_ - 1] + $ints[$_ - 1];
        unshift @right, $right[-$_] + $ints[-$_];
    }
}
foreach (0..$#ints) {
    $diff[$_] = abs($left[$_] - $right[$_]);
}
say $_ for @diff;

First we put the zeros on each list. That's just in case we have a integer list like the second example, with just one number in the list. Then if we have additional integers we count and add numbers to the right side of the @left list and the left side of the @right list.

We loop through both completed lists and we compute the absolute difference, then print the list one-by-one. Voila! Again, not sure what the practical application is, but an interesting challenge. Many thanks to Mohammad and an enjoyable pair of challenges. I also appreciate being the June champion, so you'll hear more of my bio when it's released.

Have a great week! See you next week.

Perl Weekly Challenge #224 - Passing Notes

Hi everybody! Just doing one challenge again this week. Time limitations hold me back once again.

This week we're looking for the letters of a target word in a source word, and we're not allowed to use the same letter twice. Spoiler alert because it's only Wednesday and you still have the rest of the week to submit solutions if desired.

The easiest way to do this is with a dictionary hash initialized like so:

foreach (split //, $source) {$chars{$_}++}

Many people use map() to do this, but I'm not a big fan of map in many cases because I feel it makes code less readable.

This gives us the number of occurrences of each letter in the original word.

Then we iterate through the target word and look for (and remove) the letters in the dictionary:

foreach (split //, $target) {
    if ($chars{$_}) {
        $chars{$_}--;
    } else {
        say 'false' and exit;
    }
}
say 'true';

Obviously if the script did more than just this we'd need a success flag in there instead, but as it is we can just exit if we ever don't find the matching character in the dictionary.

Anyways, that's the solution for this week! I have a definite idea of how I'd solve the second challenge, I just don't have the time to implement it. I look forward to seeing the other solutions, because I'm sure they'll have more efficient ways to do it.

Perl Weekly Challenge #223 - Count Primes? I've Never Met the Man

Hello everybody! It's another week with a new Perl Weekly Challenge. This week I'm only doing the first challenge, not because of time, but because the second challenge makes absolutely no sense to me. Perhaps a clarification will come out, but I'm not going to bother at the moment.

This week the challenge is to find the number of primes under the provided number. This is a challenge that really isn't worth rebuilding, and so I would recommend using Math::Prime::Util. You have to know when to just trust the professionals and use modules. With the use of M::P::U, we can essentially do the challenge in one line.

use Math::Prime::Util 'primes';
say scalar @{primes(shift)};

primes() returns an array reference, so we have to dereference the array after calling the function. We shift the number that is entered, call primes (which provides an array of the primes under that number), and dereference it and count it to print the answer.

It's that simple! This is a case where I definitely wouldn't recommend writing your own custom prime finder. I'll hopefully see you next week with the next challenge!

Perl Weekly Challenge #222 - Checking Against My List of Members

Hi everybody! Just doing the first weekly challenge task again this week. This week we're sorting a list of numbers and then checking whether the number matches the same position in the unsorted list. It's a very simple challenge and easily written in about 4 actual lines of clean code.

Here's the code:

#!/usr/bin/perl
use strict;
use v5.24;
my @sorted = sort @ARGV;
my $matches;
for (my $i = 0; $i <= $#ARGV; $i++) {$matches++ if $ARGV[$i] == $sorted[$i]}
say $matches // 0;

This obviously doesn't have any error-checking to make sure the values are integers, so they could be text that's sorted differently, but we're assuming the input is trustworthy. For anyone new to programming reading this, never assume user input is trustworthy. Always do your safety checks and sanitize inputs.

Very simply, we're making a sorted copy of the inputs to the script, initializing $matches, looping through both lists checking for identical values (for which we need an index counter, which is why we use the 3-part loop structure) and add to $matches if we find one. Then we print either the number of matches or 0 if we didn't find any. The // 0 is necessary just so it doesn't print an empty line if the variable is still uninitialized.

Hope to see you all again next week with the next weekly challenge! Join the challenges if you find them interesting to read about.

Perl Weekly Challenge #221 - Good Strings, Bad Strings

Hi everybody! Very limited time this week so just a brief blog post.

This week we're looking for any words in the list that can be created only using letters from a dictionary string. Then print the number of characters in the good words.

Here's the code:

#!/usr/bin/perl

use strict;
use v5.24;

my %chars;
$chars{$_}++ for (split(//, shift));

my $total;

foreach (@ARGV) {
    my @currWordChars = split(//, $_);
    my %list = %chars;
    my $notFound;

    for my $char (@currWordChars) {
        if ($list{$char}) {
            $list{$char}--;
        } else {
            $notFound = 1;
            last;
        }
    }
    $total += ($notFound ? 0 : @currWordChars);
}
say $total;

So we try every single word against a hash of the dictionary letters, and if we're missing a letter we skip that word. We do this by making a copy of the dictionary hash and removing letters as we use them to create the word we're currently looking at.

A very simple solution and I started work on the second one but didn't have enough time available. Have a good week and I'll hopefully see you next week!

About oldtechaa

user-pic Just getting back into Perl programming. I have a personal project, SeekMIDI, a small graphical MIDI sequencer.