Just one weekly challenge entry this week, because I am lacking in time and have no idea how to efficiently solve the second challenge.

So here goes:

Rank Score

First, the code:

#!/usr/bin/perl

use strict;
use v5.24;

my @sorted = reverse sort @ARGV;
my %hash;
my @table = ('G', 'S', 'B');
my $curr;

foreach (@sorted) {
    if ($curr <= 2) {
        $hash{$_} //= $table[$curr];
    } else {
        $hash{$_} //= $curr + 1;
    }
    $curr++;
}

say $hash{$_} for @ARGV;

At first, I thought this challenge was something totally different, I don't know why, but it still turned out quite simply. We want to keep the output in the same order as the input, so we obviously can't just sort and replace the inputs. The easiest way is then to use each score as the key of a hash, where the value is the rank. Since all equal scores will be equally ranked, this sorts the scores from highest to lowest and iteratively assigns ranks. For any duplicates, the index counter continues counting but the defined-or ranks that entry in the hash as the first appropriate rank. For the first 3 ranks, the table of podium winners is used.

That's all for this week! As usual, if you have any comments by all means post them. I'll look forward to seeing the other solutions to challenge 2.

Hey everybody, back this week with a couple really interesting weekly challenge tasks. The first one is extremely simple, like one-liner simple, and the second one is quite complex and nearly 90 lines long.

Challenge #1 - Fun Sort

This was fun, it's in the name. This challenge took me about 5 minutes. Sort the input, split into even and odd arrays and put them together to print out. Pretty self-explanatory.

#!/usr/bin/perl
use strict;
use v5.24;

my (@even, @odd);
$_ % 2 ? push @odd, $_ : push @even, $_ for sort @ARGV;
say @even, @odd;

Challenge #2 - Not Fun Dijkstra

I still don't know how Dijkstra came up with his algorithm after 20 minutes of thinking and it took me hours to understand it, but I'm glad he did. I had never heard of Dijkstra's algorithm, so originally I had no idea how to solve this challenge. To give me a starting point, I asked ChatGPT what it thought, and it said "Use Dijkstra's algorithm" and gave me an implementation to play with. As before, I wrote this code by hand, but it helped me a lot with the algorithmic design. Also, the AI seemed to fail badly when I asked it for additional error-checking if there was no route, so I designed and wrote that part entirely on my own.

If you haven't checked out the ways AI can assist your workflow and productivity, I highly recommend it. There are valid concerns about it, obviously, and I would never recommend copying and pasting code from it without understanding what it's doing, but it can help you understand a complex algorithm and how you would implement it.

Essentially, the theory behind Dijkstra's algorithm is not to traverse recursively, but to always follow whatever the shortest untraveled route attached to the source is. If you're always following whatever the shortest route is, the first route that reaches the destination will be the shortest route to the destination. Then you maintain a list of arrows (a hash of each node in our case) pointing backwards to the source node along that shortest route.

Here's the code:

#!/usr/bin/perl

use strict;
use v5.24;
use List::Util 'min';

my @routes = ([1, 2, 6], [5, 6, 7]);
my $source = 1;
my $destination = 7;

print_dijkstra(\@routes, $source, $destination);

@routes = ([1, 2, 3], [4, 5, 6]);
$source = 2;
$destination = 5;

print_dijkstra(\@routes, $source, $destination);

@routes = ([1,2,3], [4,5,6], [3,8,9], [7,8]);
$source = 1;
$destination = 7;

print_dijkstra(\@routes, $source, $destination);

sub print_dijkstra {
    my $result = dijkstra(@_);
    if ($result == -1) {
        say -1;
    } else {
        my @route = @{$result};
        for (@route) {
            $_ != $route[$#route] ? print "$_, " : print "$_\n"
        }
    }
}

sub dijkstra {
    my ($routeref, $source, $destination) = @_;
    my @routes = @{$routeref};

    my %adjacency;
    for my $route (@routes) {
        my @nodes = @$route;
        for my $i (0 .. $#nodes - 1) {
            push @{$adjacency{$nodes[$i]}}, $nodes[$i + 1];
            push @{$adjacency{$nodes[$i + 1]}}, $nodes[$i];
        }
    }

    my %distance;
    my %visited;
    my %previous;
    $distance{$source} = 0;

    my %new_visits;
    while (keys %visited != keys %adjacency) {
        my $node = min(grep {!defined $visited{$_}} keys %distance);
        $visited{$node} = 1;

        for my $adjacent (@{$adjacency{$node}}) {
            my $total_distance = $distance{$node} + 1;
            if (!defined $distance{$adjacent} || $total_distance < $distance{$adjacent}) {
                $distance{$adjacent} = $total_distance;
                $previous{$adjacent} = $node;
            }
        }

        if (%visited == %new_visits && !$visited{$destination}) {
            return -1;
        } elsif ($visited{$destination}) {
            last;
        }
        %new_visits = %visited;
    }

    my @route;
    my $node = $destination;
    while ($node != $source) {
        unshift @route, $node;
        $node = $previous{$node};
    }
    unshift @route, $source;

    return \@route;
}

The first iteration through, the second example ended up in an endless loop because it kept trying to reach the separate set of nodes and couldn't. Because of that, I had to write the no route code properly, which essentially checks whether we're making any progress through the route or not. If not and we've reached a dead-end, we return a -1 and leave. However, the third example shows that we also need to handle the case where there are nodes that can't be reached but we have visited the destination, so that's included in the no route code.

Conclusion

This week we had a very simple challenge and a tough one. I had fun with the first one (albeit briefly) and I learned a lot from the second one, including the power of AI. It's a very powerful tool to have on hand. Have a good week and if I have time next week I'll see you then with the next challenge!

Back already with this week's solutions to the PWC #212. Spoiler alert, because the challenge doesn't close for another few days if you want to have a try.

Challenge #1 - Spinning Letters

This week we've got a simple letter rotation. Take each letter of the word provided and rotate it by each number in the list. At first I thought this would be a lot longer code. i even put it in a sub. That actually doubles the size though for absolutely no benefit, so I just simplified. We split the word, then loop through the letters and apply the rotation. If it wraps we start from the start of the alphabet. Upper-case is handled with a simple test to insert the right case of each character. Then we don't even bother putting the word back together again because we can just say it as-is.

#!/bin/perl

use strict;
use v5.28;

my @letters = split(//, shift);
my @jumps = @ARGV;
my @new_word;

foreach (my $i = 0; $i <= $#letters; $i++) {
    push @new_word, ord($letters[$i]) + $jumps[$i] < (uc($letters[$i]) eq $letters[$i] ? 91 : 123) ? chr(ord($letters[$i]) + $jumps[$i]) : chr(ord($letters[$i]) + $jumps[$i] - 26);
}
say @new_word;

Challenge #2 - Chopping Numbers

This one's slightly more difficult. There may be a more efficient way of doing this, I think using hashes, but in this case it's not so slow as it seems with two for loops. The inner loop only cycles through the list once per number of resulting list. So for instance, in a list of 9 values with a size of 3, the inner list iterates over up to 9 numbers only 3 times. That's very satisfactory performance to me, so it's not worth optimization.

First we sort the list in ascending order, then check if the math works out for the original list size and the size of the intended chopped lists. If not, immediately exit. After that, we pretty much just have the outer loop to keep passing over the list once per needed pass, then the inner loop takes the first item in the list and looks for consecutive numbers up to the requested list size. If it finds all of them it removes them from the list and adds them to their own results array. If it doesn't, it exits. This one took me about an hour or so, but came together eventually and I'm still getting faster!

#!/bin/perl

use strict;
use v5.28;

my $size = shift;
my @list = sort @ARGV;

say '-1' and exit if scalar @list % $size != 0;
my $passes = (scalar @list / $size) - 1;

my @results;

for (my $i = 0; $i <= $passes; $i++) {
    my $curr_digit = 0;
    push @{$results[$i]}, $list[0];
    for (my $j = 1; $j <= $#list; $j++) {
        if ($list[$j] == $list[0] + $curr_digit + 1) {
            push @{$results[$i]}, $list[$j];
            splice (@list, $j, 1);
            if (scalar @{$results[$i]} == $size) {
                last;
            } else {
                $curr_digit++;
                $j--;
            }
        }
        if ($j == $#list and scalar @{$results[$i]} != $size) {say '-1' and exit}
    }
    splice (@list, 0, 1);
}

for (my $k = 0; $k <= $#results; $k++) {
    say @{$results[$k]};
}

That's it for this week. Drop me a comment if you like!

A couple very very last-minute solutions to the Weekly Challenge #211. I was crammed for time, so I didn't get to these until the last minute.

Challenge #1

For challenge number 1 I had an idea of the method I would use, but since I've been experimenting with it anyway, I asked ChatGPT for its ideas as well. Because of my lack of time, I wanted to get some help with the design process. ChatGPT is amazing at both developing and describing an algorithm in simple terms to make it understandable. I based my solution somewhat off the AI's algorithm, but I did write it entirely by hand. It's pretty simple, it just iterates across the matrix and makes sure everything matches its diagonal neighbor prior to it.

Another thing you might notice this week is that I actually put my solutions into functions, not just a basic script. Anyways, here it is:

#!/bin/perl

use strict;
use v5.28;

my @matrix1 = (
    [4, 3, 2, 1],
    [5, 4, 3, 2],
    [6, 5, 4, 3],
);

my @matrix2 = ([1, 2, 3], [3, 2, 1]);

say 'Is Matrix1 a Toeplitz matrix? : ' . (is_toeplitz(@matrix1) ? 'TRUE' : 'FALSE');
say 'Is Matrix2 a Toeplitz matrix? : ' . (is_toeplitz(@matrix2) ? 'TRUE' : 'FALSE');

sub is_toeplitz {
    my @matrix = @_;

    my $rows = scalar @matrix;
    my $cols = scalar @{$matrix[0]};

    for (my $r = 1; $r < $rows; $r++) {
        for (my $c = 1; $c < $cols; $c++) {
            if ($matrix[$r][$c] != $matrix[$r - 1][$c - 1]) {return 0;}
        }
    }
    return 1;
}

Challenge #2

For the second challenge, I had no idea of the algorithm to use, so I did some more research on it and found an algorithm to achieve the result. This sorts the numbers, adds the largest ones first, then adds alternating ends to each list to bring the average together. Interestingly, once both arrays match, it continues adding to the first array, so the solution that it finds to the first example is to put 1, 3, 4, 5, 6, and 8 all in the first array and only 2 and 7 in the second. It still works well and is a single pass, so it is quite efficient.

#!/bin/perl

use strict;
use v5.28;

use List::Util 'sum';

if ($#ARGV > 0) {can_split(@ARGV) ? say 'true' : say 'false'};

sub can_split {
    my @nums = sort {$b <=> $a} (@_);
    my $maxindex = scalar @nums;
    my $avg = sum(@nums) / scalar(@nums);
    my (@list1, @list2, $sum1, $sum2);

    for (my $i = 0; $i < $maxindex; $i++) {
        if (scalar @list1 == 0) {
            push @list1, @nums[0];
            $sum1 += @nums[0];
            splice @nums, 0, 1;
        } elsif (scalar @list2 == 0) {
            push @list2, @nums[0];
            $sum2 += @nums[0];
            splice @nums, 0, 1;
        } else {
            if (abs(($sum1 / @list1) - $avg) >= abs(($sum2 / @list2) - $avg)) {
                if ($sum1 / @list1 <= $avg) {
                    push @list1, @nums[0];
                    $sum1 += @nums[0];
                    splice @nums, 0, 1;
                } else {
                    push @list1, @nums[$#nums];
                    $sum1 += @nums[$#nums];
                    splice @nums, $#nums, 1;
                }
            } else {
                if ($sum2 / @list2 <= $avg) {
                    push @list2, @nums[0];
                    $sum2 += @nums[0];
                    splice @nums, 0, 1;
                } else {
                    push @list2, @nums[$#nums];
                    $sum2 += @nums[$#nums];
                    splice @nums, $#nums, 1;
                }
            }
        }
    }
    $sum1 / scalar @list1 == $sum2 / scalar @list2 ? return 1 : return 0;

}

That's all for this week! If I have time I'll see you all next week with more solutions!