Hello everybody! Welcome back to the Weekly Challenge series, where today we're working on dates again. I like these challenges in particular, for some reason. In this case, we have a rather simple challenge except that it gives us less common date formats than usual.

The challenge gives us a year, month, week(day) of the month, and day of week. Now DateTime provides us with get operations to find WoM and DoW info, but it doesn't provide set operations. For that we need to do a little math. Here's the code below:

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

my ($year, $month, $wom, $dow) = @ARGV;
my $obj = DateTime->new(year => $year, month => $month, day => 1);
if($obj->dow() <= $dow) {
    $obj->add(days => (($dow - $obj->dow()) + (($wom - 1) * 7)));
} else {
    $obj->add(days => ((7 - ($obj->dow() - $dow)) + (($wom - 1) * 7)));
}
say 0 and exit if $obj->month() != $month;
say $obj->day();

We only really have to handle wrapping and assessing whether that day is possible within the month. We use DateTime because it just makes sense, and we create an object with the first day of the month that we're using. If the day is the same or earlier in the week (to save code complexity) than the day we're looking for, we shift the difference and add that to the number of weeks later that the target day is on. If the 1st of the month is later in the week than our target day, we wrap and still shift $wom-1 weeks later.

If our addition to the date means we're now in a different month from the intended one we print out 0 and exit, otherwise we say what the date is now.

It's that simple! Just 12 lines including file header and boilerplate. Hope to see you next week!

Welcome back to another round of the weekly challenge, with just one solution this week. I'm setting up a lemonade stand and need to deal with change. Interestingly, I can only sell one juice per person, so I hope you're not super thirsty!

We can take $5, $10, and $20 bills, and we don't start with any change, so we need our previous customers to provide us with change for future customers. Let's find out if we can make change for a set of customers.

Here's the code:

#!/usr/bin/perl
use v5.36;
use List::Util 'any';

my %till;
my $failure;
foreach my $bill (@ARGV) {
    if(!any {$bill == $_} (5, 10, 20)) {
        say('At least one bill provided is not $5, $10, or $20.') and exit;
    }
    $till{$bill}++;
    if($bill == 20) {
        if($till{10} and $till{5}) {
            $till{10}--;
            $till{5}--;
        } elsif($till{5} >= 3) {
            $till{5} -= 3;
        } else {
            $failure = 'false';
            last;
        }
    } elsif($bill == 10) {
        if($till{5}) {
            $till{5}--;
        } else {
            $failure = 'false';
            last;
        }
    }
}
say(defined($failure) ? $failure : 'true');

It might be possible to make this cleaner, but this is what I came up with quickly, so here it is. Our cash drawer is represented by the hash %till, which contains our $5s, $10s, and $20s. We add each bill we get, then we need to make change (unless it's a 5). If we can't make change at any point, we set our failure flag and stop serving customers. We check for the ability to successfully make change depending on the bill we've been handed. For a 20, first we try to make change with a $10 and a $5, otherwise three $5s, and for a $10 we see if we have any $5s. That's all we have to do! It's a lot of code for a simple result.

Hope to see you all next week. Enjoy!

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!

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!

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.

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.

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.

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.

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.

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!