ETOOBUSY

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!

PWC236 - Array Loops

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

TL;DR

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

The challenge

You are given an array of unique integers.

Write a script to determine how many loops are in the given array.

To determine a loop: Start at an index and take the number at array[index] and then proceed to that index and continue this until you end up at the starting index.

Example 1
Input: @ints = (4,6,3,8,15,0,13,18,7,16,14,19,17,5,11,1,12,2,9,10)
Output: 3

To determine the 1st loop, start at index 0,
the number at that index is 4, proceed to index 4,
the number at that index is 15, proceed to index 15
and so on until you're back at index 0.

Loops are as below:
[4 15 1 6 13 5 0]
[3 8 7 18 9 16 12 17 2]
[14 11 19 10]
Example 2
Input: @ints = (0,1,13,7,6,8,10,11,2,14,16,4,12,9,17,5,3,18,15,19)
Output: 6

Loops are as below:
[0]
[1]
[13 9 14 17 18 15 5 8 2]
[7 11 4 6 10 16 3]
[12]
[19]
Example 3
Input: @ints = (9,8,3,11,5,7,13,19,12,4,14,10,18,2,16,1,0,15,6,17)
Output: 1

Loop is as below:
[9 4 5 7 19 17 15 1 8 12 18 6 13 2 3 11 10 14 16 0]

The questions

Well well well… we’re going to take a huge assumption here, that is the integer values will always be valid indexes in the input array. OK with that?!?

Additionally, we will consider a loop also a situation in which an element points to itself, OK? This is within the rules and within the examples, so this question is probably not needed but better be clear.

The solution

The assumption allows us to rule out arrays like (100) where there is no loop at all, or (100,2,1) where there is one with two elements only.

This said, every input array is then a permutation of all (and only) the indexes of the array itself, i.e. integers from $0$ up to $n - 1$, where $n$ is the number of elements in the array. Every element in the array is part of a chain; I have a wonderful demonstration of this fact, but the margins of this blog post are too tight to write it down so trust me because you trusted Fermat for about 350 years and he was eventually right.

At this point, we just have to calculate how many of them are there, ranging from 1 (just a big chain) up to $n$ (every element just points to itself). This is a partition of the initial set and the perfect candidate for the Union-Find algorithm, where we only need to know how many unified sets we are left after considering all inputs.

As a matter of fact, cglib-perl indeed has a UnionFind.pm implementation, that we are happy to leverage here:

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

say array_loops(map { split m{\D+}mxs } @ARGV);

sub array_loops (@ints) {
   my $uf = UnionFind->new(components => [0 .. $#ints]);
   $uf->union($_, $ints[$_]) for 0 .. $#ints;
   return $uf->count;
}


package UnionFind; # Sedgewick & Wayne, Algorithms 4th ed, §1.5
use strict;

sub add;    # see below
sub connected { return $_[0]->find($_[1]) eq $_[0]->find($_[2]) }
sub count     { return $_[0]{count} }
sub find      { return $_[0]{cs}{$_[0]->find_id($_[1])}[1] }
sub find_id;    # see below
sub new;        # see below
sub union;      # see below

sub add {
   my $id = $_[0]{id_of}->($_[1]);
   return $_[0] if $_[0]{cs}{$id};
   $_[0]{cs}{$id} = [$id, $_[1], 1];
   $_[0]{count}++;
   return $_[0];
}

sub find_id {
   my $r = my $i = $_[0]{id_of}->($_[1]);
   return unless exists $_[0]{cs}{$r};
   $r = $_[0]{cs}{$r}[0] while $r ne $_[0]{cs}{$r}[0];
   ($i, $_[0]{cs}{$i}) = ($_[0]{cs}{$i}[0], $_[0]{cs}{$r}) while $i ne $r;
   return $r;
} ## end sub find_id

sub new {
   my ($pk, %args) = (@_ > 0 && ref($_[1])) ? ($_[0], %{$_[1]}) : @_;
   my $id_of = $args{identifier} || sub { return "$_[0]" };
   my $self = bless {id_of => $id_of, count => 0}, $pk;
   $self->add($_) for @{$args{components} || []};
   return $self;
} ## end sub new

sub union {
   my ($i, $j) = ($_[0]->find_id($_[1]), $_[0]->find_id($_[2]));
   return $_[0] if $i eq $j;
   ($i, $j) = ($j, $i) if $_[0]{cs}{$i}[2] < $_[0]{cs}{$j}[2];   # i -> max
   $_[0]{cs}{$i}[2] += $_[0]{cs}{$j}[2];
   $_[0]{cs}{$j} = $_[0]{cs}{$i};
   $_[0]{count}--;
   return $_[0];
} ## end sub union

Alas, cglib-raku did not have the corresponding implementation… up to this challenge, which was the perfect occasion to add it as UnionFind.rakumod. So here we are with the Raku solution too:

#!/usr/bin/env raku
use v6;

class UnionFind {
   has $.count = 0;
   has %!cs;
   has &!id-of is built;
   has @!items;

   method add ($item) {
      my $id = &!id-of($item);
      return self if %!cs{$id};
      %!cs{$id} = [ $id, $item, 1 ];
      $!count++;
      return self;
   }

   method find ($item) { %!cs{self.find-id($item)}[1] }

   method find-id ($item) {
      my $r = my $i = &!id-of($item);
      return unless %!cs{$r}:exists;
      $r = %!cs{$r}[0] while $r ne %!cs{$r}[0];
      ($i, %!cs{$i}) = (%!cs{$i}[0], %!cs{$r}) while $i ne $r;
      return $r;
   }

   method new (:&id-of = -> $n { $n.Str }, :@components) {
      my $obj = self.bless(:&id-of);
      $obj.add($_) for @components;
      return $obj;
   }

   method union ($p, $q) {
      my ($i, $j) = self.find-id($p), self.find-id($q);
      return self if $i eq $j;
      ($i, $j) = $j, $i if %!cs{$i}[2] < %!cs{$j}[2]; # i -> max
      %!cs{$i}[2] += %!cs{$j}[2];
      %!cs{$j} = %!cs{$i};
      $!count--;
      return self;
   }
}

sub MAIN (*@indexes) {
   @indexes = @indexes.map({.split(/\D+/)}).flat;
   my $uf = UnionFind.new(components => [ ^@indexes ]);
   for @indexes.kv -> $i, $j { $uf.union($i, $j) }
   put $uf.count;
}

Some might argue that re-implementing stuff in Raku could be a waste of time, but I beg to differ. I still have to learn to play with the object model (there’s a huge regression in how I’m providing a constructor), but I got to better understand what bless does and I uncovered a bug in the Perl implementation too. Win-win, yay!

That’s all for this post, see you soon and stay safe!

PWC236 - Exact Change

Fri, 29 Sep 2023 06:00:00 +0200

TL;DR

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

The challenge

You are asked to sell juice each costs $5. You are given an array of bills. You can only sell ONE juice to each customer but make sure you return exact change back. You only have $5, $10 and $20 notes. You do not have any change in hand at first.

Write a script to find out if it is possible to sell to each customers with correct change.

Example 1
Input: @bills = (5, 5, 5, 10, 20)
Output: true

From the first 3 customers, we collect three $5 bills in order.
From the fourth customer, we collect a $10 bill and give back a $5.
From the fifth customer, we give a $10 bill and a $5 bill.
Since all customers got correct change, we output true.
Example 2
Input: @bills = (5, 5, 10, 10, 20)
Output: false

From the first two customers in order, we collect two $5 bills.
For the next two customers in order, we collect a $10 bill and give back a $5 bill.
For the last customer, we can not give the change of $15 back because we only have two $10 bills.
Since not every customer received the correct change, the answer is false.
Example 3
Input: @bills = (5, 5, 5, 20)
Output: true

The questions

Long time no see, uh?!?

One question is about this shortage of juice… why only one per customer?

More seriously, it seems that we’re not allowed to sort the incoming bills by value, otherwise the consideration You do not have any change in hand at first. would not be needed. So I’m assuming that they have to be addressed as a FIFO.

The solution

In the good ol’ times spirit, let’s start with Raku first:

#!/usr/bin/env raku
use v6;
sub MAIN (*@bills) { put exact-change(@bills) ?? 'true' !! 'false' }

sub exact-change (@bills) {
   my %bills-of = <5 0 10 0 20 0>;
   for @bills -> $bill {
      if $bill == 5 { %bills-of<5>++ }
      elsif $bill == 10 {
         return False unless %bills-of<5>-- > 0;
         %bills-of<10>++;
      }
      else { # $bill == 20
         return False unless %bills-of<5>-- > 0;
         if %bills-of<10> >= 1 {
            %bills-of<10>--;
         }
         elsif %bills-of<5> >= 2 {
            %bills-of<5> -= 2;
         }
         else {
            return False;
         }
      }
   }
   return True;
}

Every customer with a 5$ bill is very welcome and we have to give no change back. Every customer with a 10$ bill gets back a 5$ bill if available, otherwise we bail out. Customers with 20$ bills always get one 5$ bill back, then a 10$ bill (if possible) or two 5$ bills. It’s always better to check if 10$ bills are available first, because the 5$ bills are the most needed in changes.

Perl:

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

say exact_change(@ARGV) ? 'true' : 'false';

sub exact_change (@bills) {
   my %bills_of = map { $_ => 0 } (5, 10, 20);
   for my $bill (@bills) {
      if ($bill == 5) {
         $bills_of{5}++;
      }
      elsif ($bill == 10) {
         return 0 unless $bills_of{5}-- > 0;
         $bills_of{10}++;
      }
      else { # $bill == 20
         return 0 unless $bills_of{5}-- > 0;
         if ($bills_of{10} >= 1) {
            $bills_of{10}--;
         }
         elsif ($bills_of{5} >= 2) {
            $bills_of{5} -= 2;
         }
         else {
            return 0;
         }
      }
   }
   return 1;
}

I think this is it!