perl-weekly-challenge Archives

Perl Weekly Challenge 048: Survivor and Palindrome Dates


There are 50 people standing in a circle in position 1 to 50. The person standing at position 1 has a sword. He kills the next person i.e. standing at position 2 and pass on the sword to the immediate next i.e. person standing at position 3. Now the person at position 3 does the same and it goes on until only one survives.
Write a script to find out the survivor.

I tried two different approaches to the problem.

The first one uses an array of living people and a variable $sword that stores the index of the person holding the sword. In each iteration of the loop, the next person is removed from the array, and the sword is passed to the next person.

The “next person” has a special cyclic meaning: at the end of the array, the sword must return to the beginning. This is achieved by using the modulo operator %. Note that we use it twice, once to find the person to kill, and once to find the person to pass the sword to—and each case uses a different array size in the modulo operation, as killing a person changes the size of the array.

Perl Weekly Challenge 046: Cryptic Message & Is the Room Open?

Cryptic Message

The communication system of an office is broken and message received are not completely reliable. To send message Hello, it ended up sending these following:
H x l 4 !
c e - l o
z e 6 l g
H W l v R
q 9 m # o

Similarly another day we received a message repeatedly like below:

P + 2 l ! a t o
1 e 8 0 R $ 4 u
5 - r ] + a > /
P x w l b 3 k \
2 e 3 5 R 8 y u
< ! r ^ ( ) k 0

Write a script to decrypt the above repeated message (one message repeated 6 times).

Even without reading the hint, the idea seems clear: for each column, the output should consist of its most frequent character. As usually, to count frequency, we’ll use a hash. To find the most frequent one, we’ll use max from List::Util.

Perl Weekly Challenge 045: Square Secret Code & Source Dumper

Square Secret Code

The square secret code mechanism first removes any space from the original message. Then it lays down the message in a row of 8 columns. The coded message is then obtained by reading down the columns going left to right.

For example, the message is “The quick brown fox jumps over the lazy dog”. The code message would be as below:

tbjrd hruto eomhg qwpe unsl ifoa covz kxey

Let’s start with the test:

use warnings;
use strict;

use Test::More tests => 1;
is square_secret_code('The quick brown fox jumps over the lazy dog'),
    'tbjrd hruto eomhg qwpe unsl ifoa covz kxey',

Let’s use a regex to extract groups of 8 letters from the message. Then split each group into individual letters and append each of them to a string corresponding to an output word.

use Syntax::Construct qw{ /r // };

sub square_secret_code {
    my ($message) = @_;
    my @code = ("") x 8;
    for my $group ($message =~ s/\s//gr =~ m/(.{1,8})/g) {
        $code[$_] .= (split //, $group)[$_] // "" for 0 .. 7;
    return join ' ', @code

Perl Weekly Challenge 044: One Hundred, Two Hundred

Only 100, please

You are given a string “123456789”. Write a script that would insert ”+” or ”-” in between digits so that when you evaluate, the result should be 100.

We can populate each place “between digits” with one of three possible values: a plus sign, minus sign, or nothing. To check all the possible permutations, we’ll use an indicator function similarly to The Knapsack Problem. In this case, though, there are three possible values, so we need to loop over numbers in the ternary numeral system.

The only operation we’ll need will be the increment, so we don’t need the full support for arithmetic in base 3. We can implement the increment ourselves: we start from the right of the number, change any 2 into 0 and move left. Once we find 0 or 1, we increment it and we’re done.

To create the expression, we just need to intersperse the digits with the operators. See the apply subroutine below.

Perl Weekly Challenge 043: Olympic Rings and Self-Descriptive Numbers

Olympic Rings

There are 5 rings in the Olympic Logo [as shown below]. They are colour coded as in Blue, Black, Red, Yellow and Green. We have allocated some numbers to these rings as below: Blue: 8, Yellow: 7, Green: 5, Red: 9. The Black ring is empty currently. You are given the numbers 1, 2, 3, 4 and 6. Write a script to place these numbers in the rings so that the sum of numbers in each ring is exactly 11.

My first idea was to go over all the possible permutation of the numbers and report those that satisfy the sum condition. I chose Math::Combinatorics as the module to handle the permutations.

use warnings;
use strict;
use feature qw{ say };

use Math::Combinatorics;

my $SUM = 11;
my ($red, $green, $yellow, $blue) = (9, 5, 7, 8);

my $mc = 'Math::Combinatorics'->new(data => [1, 2, 3, 4, 6]);
while (my ($black, $red_green, $black_green, $black_yellow, $blue_yellow)
           = $mc->next_permutation
) {
    my @sums = ($red + $red_green,
                $green + $red_green + $black_green,
                $black + $black_green + $black_yellow,
                $yellow + $black_yellow + $blue_yellow,
                $blue + $blue_yellow);
    say join ' ',
        $red_green, $black_green, $black, $black_yellow, $blue_yellow
        unless grep $_ != $SUM, @sums;

It tries all the 120 possible permutations, but from a computer point of view, it’s not so many. While finishing the solution, I already saw it could be solved in a much faster and straightforward way.

Perl Weekly Challenge 040: Multiple Arrays & Sort SubList

Multiple Arrays

You are given two or more arrays. Write a script to display values of each list at a given index.

For example:

Array 1: [ I L O V E Y O U ]
Array 2: [ 2 4 0 3 2 0 1 9 ]
Array 3: [ ! ? £ $ % ^ & * ]

We expect the following output:

I 2 !
L 4 ?
O 0 £
V 3 $
E 2 %
Y 0 ^
O 1 &
U 9 *

The pound sign is not part of the standard ASCII, so we’ll need to properly encode it. The use utf8; clause tells perl that the script itself contains UTF-8 encoded characters, the binmode function sets the encoding for the given filehandle, i.e. standard output.

Perl Weekly Challenge 039: Guest Book and Reverse Polish Notation

Guest Book

A guest house had a policy that the light remain ON as long as the at least one guest is in the house. There is guest book which tracks all guest in/out time. Write a script to find out how long in minutes the light were ON.
1) Alex    IN: 09:10 OUT: 09:45
2) Arnold  IN: 09:15 OUT: 09:33
3) Bob     IN: 09:22 OUT: 09:55
4) Charlie IN: 09:25 OUT: 10:05
5) Steve   IN: 09:33 OUT: 10:01
6) Roger   IN: 09:44 OUT: 10:12
7) David   IN: 09:57 OUT: 10:23
8) Neil    IN: 10:01 OUT: 10:19
9) Chris   IN: 10:10 OUT: 11:00

If we visualise the input, we’ll see that it represents the easy case: the first guest turns the light on, and it stays on until the last guest leaves. But in the general case, the guest house might be empty several times a day, causing the lights being turned off and back on repeatedly.

Fortunately, CPAN has a tool to handle even the general case. It uses so called Inversion Lists: instead of storing each minute, we just store the times when the light changes its state. I first learned about the concept in the PerlMonks article RFC: The Lazy Manager’s Calendar with Inversion Lists.

Perl Weekly Challenge 038: Date Finder and Word Game

Date Finder

Create a script to accept a 7 digits number, where the first number can only be 1 or 2. The second and third digits can be anything 0-9. The fourth and fifth digits corresponds to the month i.e. 01, 02, 03…, 11, 12. And the last 2 digits respresents the days in the month i.e. 01, 02, 03…, 29, 30, 31. Your script should validate if the given number is valid as per the rule and then convert into human readable format date.


  1. If 1st digit is 1, then prepend 20 otherwise 19 to the 2nd and 3rd digits to make it 4-digits year.
  2. The 4th and 5th digits together should be a valid month.
  3. The 6th and 7th digits together should be a valid day for the above month.

For example, the given number is 2230120, it should print 1923-01-20.

As we’ve done several times, we’ll use the core module Time::Piece to handle dates.

use warnings;
use strict;

use Time::Piece;

sub validate {
    my ($number) = @_;

First, we’ll check the length of the input string.

    die 'Invalid length' unless length $number == 7;

Perl Weekly Challenge 037: Weekdays and Daylight Gain/Loss


Write a script to calculate the total number of weekdays (Mon-Fri) in each month of the year 2019.

I used the core module Time::Piece and its companion from the same distribution, Time::Seconds. Let’s start on the first day of the month, and keep adding one day while we stay in the same month. Along the way, count the days that aren’t Saturdays and Sundays.

use warnings;
use strict;

use Time::Piece;
use Time::Seconds qw{ ONE_DAY };

sub days_in_month {
    my ($month) = @_;
    my $date = 'Time::Piece'->strptime("2019 $month 1 12:00",
                                       '%Y %b %d %H:%M');
    my $count = 0;
    while ($date->month eq $month) {
        ++$count unless grep $date->day eq $_, qw( Sat Sun );
        $date += ONE_DAY;
    return $count

And here’s a test that the numbers are correct:

Perl Weekly Challenge 036: VIN Validation and the Knapsack Problem

VIN Validation

Write a program to validate given Vehicle Identification Number (VIN).

I followed the description at Wikipedia. Sometimes, it wasn’t exactly clear whether the described rule should be valid everywhere or just in a part of the world; the rules also developed with time, so older vehicles can bear VINs that would be considered invalid for a modern car.

Most of the validation is implemented in a single subroutine validate_vin. It takes two parameters, $vin and $sold: the second one says where the car was sold. "North America" and "China" are two values that trigger a different behaviour of the validator.

About E. Choroba

user-pic I blog about Perl.