ETOOBUSY

QR Encoding in Pure Perl

Sun, 26 Oct 2025 12:35:31 +0100

TL;DR

A module for doing QR Encoding in Pure Perl

I like my own mega-tool Romeo a lot and I also like adding stuff to it from time to time. That bloat seems like spoiling the real cat.

Well, it also spoils me, admittedly 😅

Anyway, I figured out a way to add support for QR codes generation, by implementing an optional plugin system that looks for stuff in some places and, when present, adds new commands under the same umbrella. This allows using the venerable Text::QRCode, which in turn uses the libqrencode library.

Alas, this has always bugged me, because the main design goal of Romeo is to produce a single-file program that can just be run wherever there’s a decent installation of Perl (v5.24 or newer). This whole plugin thing means that some compilation must happen in the target.

So well, it’s since some time that I’ve been toying with the idea of implementing QR Encoding directly in Pure Perl.

Reinventing a Wheel?

There is some prior art in CPAN for generating QR Codes, but to be honest I was a bit intimidated by it. I’m talking about GD::Barcode.

I was not too thrilled by the mix of QR Code generation and GD. Text::QRCode spoiled me into thinking that the encoding process can be thought as separated from actual image generation, and that GD was not making me too happy. Even though, admittedly, there is the following note:

From 1.14, you can use this module even if no GD (except plot method).

Looking at the code did also scare me a bit, there’s a bit too many if-s and conditions for me to confortably contribute anything.

In hindsight, anyway, what drove me away was the name: the GD part just made me skip over it thinking that it would need some compilation, which was not what I was after.

So Here’s the Wheel

So I just went to the coding board and released a couple of modules, hoping they will be useful:

QRCode::Encoder which has an interface compatible with Text::QRCode, and
Math::ReedSolomon::Encoder, which does the heavylifting for calculating the redundancy using Reed-Solomon codes.

Some Considerations

QR Codes are defined in ISO Standard ISO/IEC 18004. The document was basically donated by Denso Wave to ISO, I think because having something published as an ISO standard is definitely an achievement.

For all that, it has a very poor quality over cost ratio in my opinion. Take Table 9 as an example: it’s a total mess, to the point that someone wrote about it in How should I interpret Table 9 in the QR Code ISO IEC 18004 2015 Standard wrt number of blocks?. My take is that the Japanese original is much more readable, even for someone who does not know Japanese.

libqrencode was incredibly useful, I took most of the tables and part of the interface from there. I can’t say that my rating implementation is correct, though, as it is NOT specced very well (again…) and I definitely have some differences with respect to libqrencode. Anyway, it’s worked fine so far.

Back to Romeo…

So, back to Romeo… it has QR Code generation out of the box now:

Have fun!

Synacor Challenge Completed

Wed, 08 Jan 2025 23:14:00 +0100

TL;DR

I eventually completed The Synacor Challenge.

Slighly less than two years ago I wrote about The Synacor Challenge, a fun collection of puzzles that require some programming, from the same author (Eric Wastl) of Advent of Code.

I finally solved it!

Some notes have been collected in the wiki. You can safely land on that page without worrying about spoilers; from that page you can then jump to code-specific pages where you will eventually get spoilers!

I eventually opted for restarting from scratch, using Perl instead of Raku. I remembered that my original implementation in Raku was a bit slow and I didn’t want that to get in the way; I might take a second look now, though.

Why so long?

Quoting myself:

It starts at the Synacor Challenge site, where you too can register and download the package for taking part to the challenge.

We are supposed to go on a quest and collect 8 codes […]

… and then put those codes had to be put in the website for checking.

Little I knew at the time that the site would be shut down soon. Soon meaning I was only able to validate up to the fifth code.

At the time I first thought about some transient problem, then it was clear that the site would not come up. So I lost interest in the challenge and left it there; I knew that there might be traps with false codes (in pure Advent of Code spirit, where you might think that the solution is correct when it’s not, so the only way to know for sure is to check it on the web site), so being unable to validate the codes amounted to just be unable to solve the challenge in the first place.

After some time I found out about Aneurysm9’s repository; basically, a gentle soul that had already solved the challenge and validated the codes put their puzzle inputs (specification and binary) in a repo, along with the solution codes (well, not directly the solution codes but their MD5 hashes, which is equivalent for the purpose of solution validation). I don’t remember when I found the repository, but it was probably a period where I could not dedicate too much time to puzzle solving so I left it at that.

One month ago I took the Advent of Code again, managing to solve each puzzle in the day when it came out (second time, yay!), and I remembered about The Synacor Challenge again, so why not?

Want to take it?

If you’re interested into solving the challenge, the material shared in Aneurysm9’s repository is completely self-sufficient. The following Javascript helper aims at easing validation of codes as you find them (whitespaces are automatically removed, don’t put other extra characters though):

If you already have your personalized material, my suggestion is to go with the material above first, just to make sure that you get all solutions in the right way. After that, you can re-apply your solution ideas to your specific input, which might still require some tinkering.

Conclusions

I’m happy that it’s still possible to take the challenge, even tough the original web site has been shut down. If you like Advent of Code I definitely invite you to take The Synacor Challenge in its preserved mode!

Getting the `ntSecurityDescriptor` with an LDAP query

Fri, 13 Sep 2024 06:00:00 +0200

TL;DR

I found out how to retrieve the ntSecurityDescriptor in Active Directory, via LDAP.

Active Directory is a… beast and it’s not always easy to get what’s needed. This took me… some time.

One configuration that is supported for an account is the possibility to set a flag for preventing a user to change password. I’m not sure why there’s such a flag; I can only imagine that’s an easy way to lock an account (you just set a very random password, then prevent anyone from changing it).

There’s a promising flag PASSWD_CANT_CHANGE in userAccountControl, but alas:

You can’t assign this permission by directly modifying the UserAccountControl attribute. For information about how to set the permission programmatically, see the [Property flag descriptions][] section.

The link eventually lands us on page Modifying User Cannot Change Password (LDAP Provider), which is somehow helpful but not too much, because it includes code examples that assume the use of some Microsoft library for C++. I guess 🙄

Anyway, the page includes some interesting info:

the information that we’re after is in an Discretionary Access Control List (DACL)
it is included in property (/attribute) ntSecurityDescriptor in the LDAP record.

Only fact is that this attribute is nowhere to be found.

Wait a minute. What?!?

It turns out that depending on how you set the query parameters, this field will contain more or less information. By default it is supposed to contain everything, except that normal users are not supposed to see everything, so Active Directory does not include this attribute in the answer.

The trick consists in asking for less. This answer got me on the right track for a solution in Perl: we have to set the extension control LDAP_SERVER_SD_FLAGS_OID to a value that excludes the System Access Control List part from the answer, while keeping everything else. The answer also includes a quick and dirty way of building up the right value to pass for this control:

$sdFlags = 7;
...
   "value" => sprintf("%c%c%c%c%c", 48, 3, 2, 1, $sdFlags)

This even works in Perl, but it’s a bit too hackish and I’d like to know more.

This page contains the information I was after:

The LDAP_SERVER_SD_FLAGS_OID control is used with an LDAP Search request to control the portion of a Windows security descriptor to retrieve.

…

When sending this control to the DC, the controlValue field is set to the BER encoding of the following ASN.1 structure.
SDFlagsRequestValue ::= SEQUENCE {
    Flags    INTEGER
}

This makes it clearer the trick in the PHP code; it’s just a way to produce the BER encoding of the required data structure. In particular:

0x30 (48 decimal)    tag for a SEQUENCE
0x03 (3 decimal)     length of SEQUENCE (# of following octets)
    0X02 (2 decimal)     tag for an INTEGER
    0x01 (1 decimal)     length of INTEGER (# of following octets)
    0x07 ($sdFlags)      value of INTEGER

When using Perl, especially when using Net::LDAP, there’s a cleaner and more readable way of producing the same:

use Convert::ASN1;
use constant OWNER_SECURITY_INFORMATION => 0x01;
use constant GROUP_SECURITY_INFORMATION => 0x02;
use constant DACL_SECURITY_INFORMATION  => 0x04;
use constant SACL_SECURITY_INFORMATION  => 0x08;
my $asn = Convert::ASN1->new;
$asn->prepare(<<'END');
   SDFlagsRequestValue ::= SEQUENCE {
      Flags    INTEGER
   }
END
my $ldap_control_sd_flags = $asn->encode(Flags =>
     OWNER_SECURITY_INFORMATION
   | GROUP_SECURITY_INFORMATION
   | DACL_SECURITY_INFORMATION
);

Setting the control for the query is quite straightforward, as it’s part of the interface for the search method:

use Net::LDAP::Constant qw< LDAP_CONTROL_SD_FLAGS >;
use Net::LDAP::Control;
my $control = Net::LDAP::Control->new(
    critical => 1,
    type     => LDAP_CONTROL_SD_FLAGS,
    value    => $ldap_control_sd_flags,
);
...
my $res = $ldap->search(..., control => $control);
...

This should eventually give us the ntSecurityDescriptor we’re after (including the DACL), even when we’re not super-administrators.

Stay safe!

App::Easer release 2.008 is out

Thu, 12 Sep 2024 07:00:00 +0200

TL;DR

There’s a new release of App::Easer: 2.008.

Long time no see, huh?!? My last post here was almost e-l-e-v-e-n months ago! ¯\_(ツ)_/¯

OK, back to App::Easer. It was a long due release, after fixing many bugs and annoyances that djerius reported.

There’s been new designing but in a backwards-compatible way, especially in how sources can be handled in a new way. Check out the new shiny tutorial for v2.008!

Stay safe!

PWC239 - Consistent Strings

Mon, 23 Oct 2023 06:00:00 +0200

TL;DR

On with TASK #2 from The Weekly Challenge #239. Enjoy!

The challenge

You are given an array of strings and allowed string having distinct characters.

A string is consistent if all characters in the string appear in the string allowed.

Write a script to return the number of consistent strings in the given array.

Example 1
Input: @str = ("ad", "bd", "aaab", "baa", "badab")
       $allowed = "ab"
Output: 2

Strings "aaab" and "baa" are consistent since they only contain characters 'a' and 'b'.
Example 2
Input: @str = ("a", "b", "c", "ab", "ac", "bc", "abc")
       $allowed = "abc"
Output: 7
Example 3
Input: @str = ("cc", "acd", "b", "ba", "bac", "bad", "ac", "d")
       $allowed = "cad"
Output: 4

Strings "cc", "acd", "ac", and "d" are consistent.

The questions

Talking about checking for equality… are accented characters the same as non-accented ones?

The solution

We can do the check using a hash/set and then checking that all characters belong to it.

Perl goes first, we encapsulate the test in a function so that it’s easy to use grep in scalar context to produce the output:

#!/usr/bin/env perl
use v5.24;
use warnings;
use experimental 'signatures';

my $cc = consistency_checker_for(shift);
say scalar grep { $cc->($_) } @ARGV;

sub consistency_checker_for ($string) {
   my %is_allowed = map { $_ => 1 } split m{}mxs, shift;
   return sub ($input) {
      for my $i (0 .. length($input) - 1) {
         return unless $is_allowed{substr($input, $i, 1)};
      }
      return 1;
   };
}

We do almost the same in Raku, just a little change moving the test function inside the function to do the overall test. We could have done like this in Perl as well.

#!/usr/bin/env raku
use v6;
sub MAIN ($allowed, *@str) { put consistent-string($allowed, @str).elems }

sub consistent-string ($allowed, @str) {
   my $al = $allowed.comb.Set;
   my &checker = sub ($input) {
      for $input.comb -> $c {
         return False unless $c ∈ $al;
      }
      return True;
   };
   @str.grep(&checker);
}

Stay safe!

PWC239 - Same String

Sun, 22 Oct 2023 06:00:00 +0200

TL;DR

Here we are with TASK #1 from The Weekly Challenge #239. Enjoy!

The challenge

You are given two arrays of strings.

Write a script to find out if the word created by concatenating the array elements is the same.

Example 1
Input: @arr1 = ("ab", "c")

Output: true

Using @arr1, word1 => "ab" . "c" => "abc"
Using @arr2, word2 => "a" . "bc" => "abc"
Example 2
Input: @arr1 = ("ab", "c")
       @arr2 = ("ac", "b")
Output: false

Using @arr1, word1 => "ab" . "c" => "abc"
Using @arr2, word2 => "ac" . "b" => "acb"

The questions

This time I have a meta-question… how is people addressing the problem of getting the inputs from the command line?

Well, apart from this I’d probably ask what the same means. E.g. should differently-accented character count as same? I’ll assume not…

The solution

We’re starting with Raku and we’re going the easy way, joining all strings together and comparing the results:

#!/usr/bin/env raku
use v6;
sub MAIN ($s1, $s2) { say is-same-string($s1.split(/\,/), $s2.split(/\,/)) }

sub is-same-string (@s1, @s2) { @s1.join('') eq @s2.join('') }

For the Perl counterpart, we’re going the over-engineering way and assume that there might be several input arrays, as well as avoiding to merge them in single strings and instead iterate them character by character:

#!/usr/bin/env perl
use v5.24;
use warnings;

my ($s1, $s2) = map { [ split m{,}mxs ]  } @ARGV[0,1];
say is_same_string($s1, $s2) ? 'true' : 'false';

sub is_same_string {
   my ($lead, @other) = map {
      my $aref = $_;
      my $idx = 0;
      my $ch_idx = 0;
      sub {
         while ($idx <= $aref->$#*) {
            return substr($aref->[$idx], $ch_idx++, 1)
               if $ch_idx < length($aref->[$idx]);
            ++$idx;
            $ch_idx = 0;
         }
         return;
      };
   } @_;
   while ('necessary') {
      my $ch = $lead->();
      if (! defined($ch)) {
         for my $it (@other) {
            return 0 if defined($it->());
         }
         return 1;
      }
      for my $it (@other) {
         my $och = $it->();
         return 0 if ($och // '') ne $ch;
      }
   }
}

Cheers and… stay safe!

PWC238 - Persistence Sort

Sat, 21 Oct 2023 16:43:00 +0200

TL;DR

On with TASK #2 from The Weekly Challenge #238. Enjoy!

The challenge

You are given an array of positive integers.

Write a script to sort the given array in increasing order with respect to the count of steps required to obtain a single-digit number by multiplying its digits recursively for each array element. If any two numbers have the same count of steps, then print the smaller number first.

Example 1
Input: @int = (15, 99, 1, 34)
Output: (1, 15, 34, 99)

15 => 1 x 5 => 5 (1 step)
99 => 9 x 9 => 81 => 8 x 1 => 8 (2 steps)
1  => 0 step
34 => 3 x 4 => 12 => 1 x 2 => 2 (2 steps)
Example 2
Input: @int = (50, 25, 33, 22)
Output: (22, 33, 50, 25)

50 => 5 x 0 => 0 (1 step)
25 => 2 x 5 => 10 => 1 x 0 => 0 (2 steps)
33 => 3 x 3 => 9 (1 step)
22 => 2 x 2 => 4 (1 step)

The questions

Doing multiplications can get big numbers quite fast, although each iteration will always produce a smaller value. Anyhow, it’s probably fine to ask for the input domain and rule out (or in!) the need for big integers.

The solution

We will go Perl first this time, enhancing the input array with info for doing the sorting, then getting the basic data back at the end. This is a common technique that I know under the name of Schwartzian transform (from Randal L. Schwartz, a.k.a. merlyn, who invented it):

#!/usr/bin/env perl
use v5.24;
use warnings;
use experimental 'signatures';

say '(', join(', ', persistence_sort(@ARGV)), ')';

sub persistence_sort (@int) {
   map { $_->[0] }
      sort { ($a->[1] <=> $b->[1]) || ($a->[0] <=> $b->[0]) }
      map { [ $_, persistence_for($_) ] }
      @int;
}

sub persistence_for ($v) {
   my $rounds = 0;
   my @digits = split m{}mxs, $v;
   while (@digits > 1) {
      ++$rounds;
      @digits = split m{}mxs, prod(@digits);
   }
   return $rounds;
}

sub prod (@ints) {
   my $retval = 1;
   for my $int (@ints) {
      $retval *= $int or return 0;
   }
   return $retval;
}

We can replicate the same in Raku, taking advantage of some of the included batteries (e.g. to compute the product of all digits):

#!/usr/bin/env raku
use v6;
sub MAIN (*@args) { say persistence-sort(@args) }

sub persistence-sort (@int) {
   return @int
      .map({ [$_, persistence-for($_)] })
      .sort({ ($^a[1] <=> $^b[1]) || ($^a[0] <=> $^b[0]) })
      .map({ $_[0] })
      .Array;
}

sub persistence-for ($v) {
   my $rounds = 0;
   my @digits = $v.comb;
   while @digits > 1 {
      ++$rounds;
      @digits = ([*] @digits).comb;
   }
   return $rounds;
}

The Schwartziant transform has a different taste this time, because it goes on a natural “reading” way instead of going backwards. Still, it’s basically the same as before.

Stay safe folks!

PWC238 - Running Sum

Sat, 21 Oct 2023 06:00:00 +0200

TL;DR

Here we are with TASK #1 from The Weekly Challenge #238. Enjoy!

The challenge

You are given an array of integers.

Write a script to return the running sum of the given array. The running sum can be calculated as sum[i] = num[0] + num[1] + …. + num[i].

Example 1
Input: @int = (1, 2, 3, 4, 5)
Output: (1, 3, 6, 10, 15)
Example 2
Input: @int = (1, 1, 1, 1, 1)
Output: (1, 2, 3, 4, 5)
Example 3
Input: @int = (0, -1, 1, 2)
Output: (0, -1, 0, 2)

The questions

I’d probably just ask:

the domain of the inputs (i.e. should we prepare for big integers?)
the length of the input/output arrays.

The solution

We can iterate over the input array and collect stuff along the way, using an accumulator variable. Here’s how to do it in Raku:

#!/usr/bin/env raku
use v6;
sub MAIN (*@args) { say running-sum(@args) }

sub running-sum (@int) {
   my $accumulator = 0;
   return [ @int.map({$accumulator += $_}) ];
}

I didn’t really like the accumulator variable, so I tried to implement an alternative solution with gather/take:

sub running-sum-alternative (@int) {
   return [ gather { take @int[0]; @int.reduce({ take $^a + $^b }) } ]
}

Still not that satisfactory, though. Surely Raku has something to the point, right? Right, let’s produce!

sub running-sum-alternative2 (@int) { @int.produce(&[+]) }

Surely Perl has something too, right? Right, let’s use reductions!

#!/usr/bin/env perl
use v5.24;
use warnings;
use List::Util 'reductions';

say '(', join(', ', running_sum(@ARGV)), ')';

sub running_sum { reductions { $a + $b } @_ }

That’s all for this challenge, folks!

PWC237 - Maximise Greatness

Sun, 08 Oct 2023 06:00:00 +0200

TL;DR

On with TASK #2 from The Weekly Challenge #237. Enjoy!

The challenge

You are given an array of integers.

Write a script to permute the give array such that you get the maximum possible greatness.

To determine greatness, nums[i] < perm[i] where 0 <= i < nums.length

Example 1
Input: @nums = (1, 3, 5, 2, 1, 3, 1)
Output: 4

One possible permutation: (2, 5, 1, 3, 3, 1, 1) which returns 4 greatness as below:
nums[0] < perm[0]
nums[1] < perm[1]
nums[3] < perm[3]
nums[4] < perm[4]
Example 2
Input: @ints = (1, 2, 3, 4)
Output: 3

One possible permutation: (2, 3, 4, 1) which returns 3 greatness as below:
nums[0] < perm[0]
nums[1] < perm[1]
nums[2] < perm[2]

The questions

My first question is… what is the question? I mean, not my question, but the challenge’s question. It seems we’re asked for a permutation, but examples seem to indicate that we need to calculate the greatness.

Additionally, any clue about the size of inputs would probably be a question worth asking.

The solution

OK, let’s start with some talk.

A permutation will generally have “great” positions (i.e. positions that contribute to greatness) and other “not-great” positions. In each great position, the corresponding number from the original input is strictly lower.

If we rearrange all such correspondent pairs in the respective permutations, nothing changes regarding the greatness, so it’s an invariant with respect to pre-arranging the input permutation in some way. For this reason, it will be useful to think the initial input permutation as sorted in descending order, e.g. the first example would become:

5 3 3 2 1 1 1

We are also optimistic folks, so we start big and assume that every position can be a great one!

greatness = 7
5 3 3 2 1 1 1

At this point we can observe that the first position can never be great: it holds the maximum value, so by definition there’s nothing inside the permutation that can be greater than it. One point lost to greatness. Anyway, we put this value in a pool of values that we can later use to fill in great positions.

greatness = 6
5 3 3 2 1 1 1
-
P

Where should we put this value, though? It can actually fill any position past its own, because it’s the maximum and there’s only one of it. We can observe, though, that it makes sense to allocate it to the value immediately below it, because if we e.g. “waste” it on a 2 or a 1 we might miss an opportunity. As a sub-example, consider all different values, like:

4 3 2 1

It only makes sense to allocate the 4 to a 3, because otherwise we will just “lose” the 3 and get a greatness score of 2 instead of 3.

Back to the original example and algorithm explanation, then, we use the pool as soon as it makes sense, i.e. the first 3 that we find. We fit the 5 in second position and remove it from the pool, because we can (and must) use it exactly once:

greatness = 6
5 3 3 2 1 1 1
- 5
x

As we pass, we collect this first 3 in the pool for possible great positions further down the road:

greatness = 6
5 3 3 2 1 1 1
- 5
x P

Now we move on to the following 3, and we find that there’s nothing in the pool to make this a great position. Hence we keep our pool as it is and declare this a miss, lowering the greatness value by 1 again. We also collect this 3 in the pool, by the way.

greatness = 5
5 3 3 2 1 1 1
- 5 -
x P P

Moving on, we find the 2, which can be made a great position thanks to the 3 that we have in the pool. Taking also into account that we collect the 2 in the pool, the step becomes:

greatness = 5
5 3 3 2 1 1 1
- 5 - 3
x x P P

We can move on with the same algorithm:

greatness = 5
5 3 3 2 1 1 1
- 5 - 3 3
x x x P P

greatness = 5
5 3 3 2 1 1 1
- 5 - 3 3 2
x x x x P P

The last position cannot be great, because we only have 1 in the pool, so we end up with:

greatness = 4
5 3 3 2 1 1 1
- 5 - 3 3 2 -
x x x x P P P

At this point we have found our greatness value. To find one permutation, we can just use what’s left in the pool inside the positions that we skipped so far:

greatness = 4
5 3 3 2 1 1 1
1 5 1 3 3 2 1

This approach guarantees us that we will always find both the maximum greatness and a corresponding permutation that has that value of greatness.

We can observe that we can establish the greatness at the end of the first sweep, by subtracting the size of the pool from the size of the input data. This is what happens in this Perl implementation:

#!/usr/bin/env perl
use v5.24;
use warnings;
use experimental 'signatures';
use JSON::PP;

my ($greatness, $permutation) = great_permutation(@ARGV);
say $greatness, ' -> ', JSON::PP->new->encode($permutation);

sub great_permutation (@inputs) {
   my @sorted_indexes = sort { $inputs[$b] <=> $inputs[$a] } 0 .. $#inputs;

   my @permutation = (undef) x @inputs;

   # first pass - set greatness!
   my @pool;
   my @not_great;
   for my $index (@sorted_indexes) {
      my $value = $inputs[$index];
      if (@pool && $pool[0] > $value) {
         $permutation[$index] = shift @pool;
      }
      else {
         push @not_great, $index;
      }
      push @pool, $value;
   }

   my $greatness = scalar(@inputs) - scalar(@pool);

   # second pass - fill the rest
   @permutation[@not_great] = @pool;

   return ($greatness, \@permutation);
}

The code above contains some initial index-calculation to make it possible to find a permutation for the actual input, not the one sorted descendingly that we used in our algorithm. Basically, we operate on the sorted one, but keep the original indexes so that our allocations end up in the right place.

If we just need the value of greatness (as it seems from the output of the examples), this can be further squeezed by working on whole blocks of same-valued positions. We still keep the pool, but it’s just a count at this point.

In our initial example, we first turn the input:

1 3 5 2 1 3 1

into an array of pairs of counts, sorted in descending order for the value (not the count):

(5 1) (3 2) (2 1) (1 3)

At this point, we can observe that we just need these values to be ordered by the original value, but we don’t need the value any more actually because we only care about “greater-than” relations, not actual values:

1 2 1 3

This means that we have 1 top value, then 2 (same) values, then 1 value, then 3 (same) values, all values being sorted descendingly.

The pool starts from 0; at each count, in order, what’s in the pool goes to “cover” that count as much as possible, with two possibilies:

the pool value is more than, or equal to, the count. This means that the greatness is not impacted, because all corresponding slots can be made great; in this case we “consume” the exact amount of count from the pool, while at the same time also gaining all of them for the next slot, so actually nothing changes!
the pool value is less than the count. This means that we will lose the difference in greatness, exhausting the current pool and resetting it with the count of the current slot (for the following slots).

All of this… in Perl:

sub greatness (@inputs) {
   my %count_for;
   $count_for{$_}++ for @inputs;
   my @counts = @count_for{sort { $a <=> $b } keys %count_for};

   my $greatness = @inputs;
   my $pool = 0;
   for my $count (@counts) {
      next if $count <= $pool; # win & accumulate the same quantity
      $greatness -= $count - $pool; # not enough in pool, lose some
      $pool = $count;  # restart pool from this slot
   }
   return $greatness;
}

… and, of course, in Raku:

#!/usr/bin/env raku
use v6;
sub MAIN (*@args) { put greatness(@args) }

sub greatness (@inputs) {
   my %count-for;
   %count-for{$_}++ for @inputs;
   my @counts = %count-for{ %count-for.keys.sort({$^a.Int <=> $^b.Int}) };

   my $greatness = @inputs.elems;
   my $pool = 0;
   for @counts -> $count {
      next if $count <= $pool; # win and accumulate the same quantity
      $greatness -= $count - $pool; # not enough in pool, lose some
      $pool = $count;  # restart pool from this slot
   }
   return $greatness;
}

Well, I guess I bored every single one of you future me:s at this point, to the rest please stay safe and have fun!

PWC237 - Seize The Day

Sat, 07 Oct 2023 06:00:00 +0200

TL;DR

Here we are with TASK #1 from The Weekly Challenge #237. Enjoy!

The challenge

Given a year, a month, a weekday of month, and a day of week (1 (Mon) .. 7 (Sun)), print the day.

Example 1

Input: Year = 2024, Month = 4, Weekday of month = 3, day of week = 2
Output: 16

The 3rd Tue of Apr 2024 is the 16th

Example 2

Input: Year = 2025, Month = 10, Weekday of month = 2, day of week = 4
Output: 9

The 2nd Thu of Oct 2025 is the 9th

Example 3

Input: Year = 2026, Month = 8, Weekday of month = 5, day of week = 3
Output: 0

There isn't a 5th Wed in Aug 2026

The questions

I have to admit that I had a hard time understanding what a weekday of month means, so I hope I got it right from the examples (i.e. that $n$ means the $n$-th such day in the specific month).

Another thing that is not clear is what to return if such a day does not exist, except that there’s an explicit example about it so I get that printing 0 is fine.

I would also like to know if there are limits that can be assumed on the dates range, just to avoid pitfalls like when different countries switched to the Gregorian calendar.

Speaking of which, I assume we’re actually talking about the Gregorian calendar or anything people living in the so-called “west” are used to.

The solution

We will start with Raku, which provides an excellent Date class out of the box that allows doing intuitive arithmetics with integers representing days. I’ll leave the algorithm to the comments:

#!/usr/bin/env raku
use v6;
sub MAIN (Int $year, Int $month, Int $weekday_in_month, Int $weekday) {
   my $date = Date.new(year => $year, month => $month, day => 1);

   # how much should we advance to find the first occurrence of the
   # target $weekday?
   my $delta = ($weekday + 7 - $date.day-of-week) % 7;

   # advance that much to land on the first, then additional weeks to
   # land on the target $weekday_in_month
   $date += $delta + ($weekday_in_month - 1) * 7;

   # print the result making sure it's still in the same year & month
   put($date.year == $year && $date.month == $month ?? $date.day !! 0);
}

It’s still easy to translate this into Perl, although we have to play at a lower level of abstraction if we want to stick with stuff in CORE (there are excellent libraries but they come with a toll).

So here our dates will be represented by the epoch of its mid-day in Greenwich Mean Time, and all transformations will take into account that a day has exactly $24 * 3600$ seconds. We are not worried by leap seconds here, though, because we’re anyway focusing on mid-day and we’re not using anything below the day granularity anyway.

Again, I’ll leave it to the comments to explain the gory details:

#!/usr/bin/env perl
use v5.24;
use warnings;
use experimental 'signatures';
use Time::Local 'timegm_modern';

say seize_the_day(@ARGV);

sub seize_the_day ($year, $month, $weekday_in_month, $weekday) {
   my $date = timegm_modern(0, 0, 12, 1, $month - 1, $year);
   my $date_day_of_week = (gmtime($date))[6];

   # how many days should we advance to find the first occurrence of the
   # target $weekday?
   my $delta = ($weekday + 7 - $date_day_of_week) % 7;

   # advance that many days to land on the first, then additional weeks
   # to land on the target $weekday_in_month.
   $date += ($delta + ($weekday_in_month - 1) * 7) * 24 * 3600;

   # get back the year and month of the date we landed on
   my (undef, undef, undef, $day, $newm, $newy) = gmtime($date);
   $newm += 1; # apply offset for month
   $newy += 1900; # apply offset for year

   # return making sure we're in the same year & month
   return $year == $newy && $month == $newm ? $day : 0;
}

This said… stay safe and have a good time!