The Task 2 of the Weekly Challenge #145 asked us to build a Palindromic Tree. It also linked to a blog post explaining the "Eertree" data structure.

Maybe it was just me, but I found the blog post confusing. Fortunately, it further linked to a scientific paper that introduced the structure around 2014.

]]> I spent several evenings of the Christmas holidays wrapping my head around the description of the algorithm to efficiently build the graph. Most of it is described in the proof of Proposition 2, but some parts are rather laconic. I wasn’t able to implement the creation of a suffix link from`P`

where `|P| > 1`

. The article says:
…just continue traversing suffix-palindromes of`T`

starting with the suffix link of`Q`

.

My implementation passed all the test cases from the Challenge, but I was able to find counter examples (e.g. the string “xabcxc”) for which the implementation didn’t work correctly. I clearly had no idea what “continue traversing” meant, even though I had implemented the traversing up to the moment correctly.

In the end, I noticed the blog post had a reply (kind of hidden in the UI) which (when clicked to reveal the full text) showed a link to a Python implementation. From that I was able to understand the logic and finish my implementation.

Once finished, I checked fellow challengers’ solutions. To my surprise, someone just copied the solution from Rosetta Code:

```
for $n (1 .. length($str)) {
for $m (1 .. length($str)) {
$strrev = "";
$strpal = substr($str, $n-1, $m);
if ($strpal ne "") {
for $p (reverse 1 .. length($strpal)) {
$strrev .= substr($strpal, $p-1, 1);
}
($strpal eq $strrev) and push @pal, $strpal;
}
}
}
print join ' ', grep {not $seen{$_}++} @pal, "\n";
```

My solution had about 100 lines. I’d spent hours working on it, to only discover this short and easy implementation!

“Wait,” thought I to myself, “this is cheating. The Rosetta Code solution just lists all the palindromes, it doesn’t really construct the structure. And the structure was interesting because it was efficient. Maybe my solution is at least faster when it’s not shorter.”

And that’s actually true. For longer strings (more than 12 characters) my solution starts beating the Rosetta Code one, and for 25 characters it’s already 3.5× faster.

You can find my solution on GitHub. As there’s no Eertree module on CPAN (at least the search doesn’t return anything) I might end up uploading it there, but it needs some polishing before it’s ready.

**Update:** String::Eertree.
]]>

Given a list of4 or morenumbers, write a script to find the contiguous sublist that has the maximum product. The length of the sublist is irrelevant; your job is to maximize the product.Example

Input:

`[ 2, 5, -1, 3 ]`

Output:

`[ 2, 5 ]`

which gives maximum product`10`

.

The easiest (but probably not the fastest) method would be to start from each position and compute the products of all the possible sublists starting at the position, remembering the positions where the product is maximal.

I automatically reached for List::Util’s `product`

to get the products easily, but alas! Running

`product(-1, 3)`

caused a *Floating point exception* (bug reported). So, I had to implement `product`

myself:

```
#! /usr/bin/perl
use warnings;
use strict;
sub product {
my @list = @_;
my $p = 1;
$p *= $_ for @list;
return $p
}
sub max_prod {
my ($list) = @_;
my $max = [$list->[0]];
for my $i (0 .. $#$list) {
for my $j ($i .. $#$list) {
my $p = product(@$list[$i .. $j]);
$max = [$p, @$list[$i .. $j]] if $p > $max->[0];
}
}
return $max
}
use Test::More tests => 1;
is_deeply max_prod([2, 5, -1, 3]), [10, 2, 5];
```

The `max_prod`

subroutine returns the product and the list in this order.

**Note:** Don’t confuse `max_prod`

with Max Brod.

You are given a string containing only digits(0..9). The string should have between4and12digits.Write a script to print every possible valid

IPv4address that can be made by partitioning the input string.For the purpose of this challenge, a valid

IPv4address consists offour “octets”i.e.A,B,CandD, separated by dots (`.`

).

Each octet must be between

0and255, and must not have any leading zeroes. (e.g.,`0`

is OK, but`01`

is not.)Example

Input:

`25525511135`

,Output:

255.255.11.135 255.255.111.35

This problem is asking for a recursive solution: Given an already extracted previous octets, try to extract one, two, or three characters to create one more octet (if possible) and run the same subroutine on the remaining string(s).

The “if possible” means we have to check whether the prefix isn’t greater to 255, whether it doesn’t start with a 0 (unless it’s 0 itself) or whether there are enough digits to create an octet of the given length.

Once we’ve accumulated 4 octets and the string’s been exhausted, we have a solution.

```
#! /usr/bin/perl
use warnings;
use strict;
sub _partition {
my ($string) = @_;
my @p;
for my $pos (1 .. 3) {
next if $pos > length $string;
my $prefix = substr $string, 0, $pos;
next if $prefix > 255 || (
1 < length $prefix
&& 0 == index $prefix, '0');
if ($pos == length $string) {
push @p, [$prefix];
} else {
push @p, grep @$_ <= 4,
map [$prefix, @$_],
_partition(substr $string, $pos);
}
}
return @p
}
sub partition {
my ($string) = @_;
[ map { join '.', @$_ } grep 4 == @$_, _partition($string) ]
}
use Test::More;
use Test::Deep;
cmp_deeply partition('25525511135'),
bag(qw( 255.255.11.135 255.255.111.35 ));
cmp_deeply partition('1234'), [ '1.2.3.4'];
cmp_deeply partition('123405'),
bag(qw( 1.23.40.5 1.234.0.5 12.3.40.5 12.34.0.5 123.4.0.5 ));
done_testing();
```

]]>
Write a script that accepts a number and returns the Excel Column Name it represents and vice-versa.Excel columns start at

Aand increase lexicographically using the 26 letters of the English alphabet,A..Z. AfterZ, the columns pick up an extra “digit”, going fromAA,AB, etc., which could (in theory) continue to an arbitrary number of digits. In practice, Excel sheets are limited to 16,384 columns.Example

Input Number: 28 Output: AB Input Column Name: AD Output: 30

This seemed like a simple base 10 to base 26 conversion and back. I started by installing Math::Base::Convert, Math::BaseConvert, Math::BaseCnv, and Convert::AnyBase to quickly discover they wouldn’t help me much. What Excel uses for column names is a weird 26 digit system that lacks a symbol for zero, but has a symbol for 26 (or for 10_{26}). It’s called the bijective base-26 numeration system. The interesting fact about such systems is that digit addition, subtraction, and multiplication work the same way as in our common system (division is a bit problematic).

Converting a number to the column name is a bit more complex because of the missing zero symbol. In each step, we decrement the remaining number before adding it modulo 26 to the result and dividing it by 26. For example, to get the name of the 789^{th} column:

To convert | Decremented | Modulo 26 | Result --------------+-------------+-----------+------- 789 | 788 | 8 | I 788 / 26 = 30 | 29 | 3 | DI 29 / 26 = 1 | 0 | 0 | ADI

What’s missing is to recognise which way we want to convert, but a simple regex can do that:

```
#!/usr/bin/perl
use warnings;
use strict;
sub convert {
my ($in) = @_;
my $r;
if ($in =~ /^[0-9]+$/) {
$r = "";
while ($in) {
substr $r, 0, 0, chr(--$in % 26 + ord 'A');
$in = int($in / 26);
}
} elsif ($in =~ /^[A-Z]+$/) {
$r = 0;
while ($in) {
$r *= 26;
$r += ord(substr $in, 0, 1, "") + 1 - ord 'A';
}
} else {
die "Invalid input: $in!\n";
}
return $r
}
use Test::More;
is convert(1), 'A', 'A';
is convert(26), 'Z', 'Z';
is convert(27), 'AA', 'AA';
is convert(52), 'AZ', 'AZ';
is convert(53), 'BA', 'BA';
is convert(789), 'ADI', 'ADI';
is convert('A'), 1, 'A';
is convert('Z'), 26, 'Z';
is convert('AA'), 27, 'AA';
is convert('AZ'), 52, 'AZ';
is convert('BA'), 53, 'BA';
is convert('ADI'), 789, 'ADI';
is convert(28), 'AB', 'encode';
is convert('AD'), 30, 'decode';
done_testing();
```

Another way how to verify the correctness was to run Excel (well, in my case, LibreOffice Calc) (warning: YouTube, but without sound).

Write a script that accepts list of positive numbers (`@L`

) and two positive numbers`$X`

and`$Y`

.The script should print all possible numbers made by concatenating the numbers from

`@L`

, whose length is exactly`$X`

but value is less than`$Y`

.Example

Input:`@L = (0, 1, 2, 5); $X = 2; $Y = 21;`

Output: 10, 11, 12, 15, 20

The first thing I noticed was 0 was considered positive. If we only used positive numbers, i.e. excluded zero, the solution would be a bit simpler, because zero has a special property when considering the length of a number: concatenation of zero and a number has the same length as the original number (i.e. `concat(0, 12) = 12`

).

I decided to use a recursive function that extended the list of numbers by concatenations of all of their possible pairs. The trick was to keep the numbers that were still shorter than the target length separated from the numbers that had already reached the target length. It prevented the program from blindly trying to combine the shortest numbers again and again ad infinitum.

I used a hash for the concatenated numbers to remove duplicates. Numbers that were too long were simply thrown away. Once no new concatenated number was generated (i.e. the number of shorter numbers hadn’t changed), the recursion ended and the result was filtered by the remaining condition.

```
#!/usr/bin/perl
use warnings;
use strict;
sub extend {
my ($length, $short, $long) = @_;
my %next;
undef @next{@$short};
for my $i (0 .. $#$short) {
for my $j (0 .. $#$short) {
my $new = 0 + ($short->[$i] . $short->[$j]);
next if $length < length $new;
if (length($new) < $length) {
undef $next{$new};
} else {
undef $long->{$new};
}
}
}
return keys %$long if @$short == keys %next;
return extend($length, [keys %next], $long)
}
sub find {
my ($length, $greater, @list) = @_;
my @long = grep $length == length $_, @list;
my %long; undef @long{@long} if @long;
return grep $greater > $_,
extend($length, \@list, \%long);
}
use Test::More;
use Test::Deep;
cmp_deeply [ find(2, 21, 0, 1, 2, 5) ],
bag(10, 11, 12, 15, 20);
cmp_deeply [ find(4, 3111, 1, 2, 3) ],
bag(glob '{{1,2}{1,2,3}}{{1,2,3}{1,2,3}}');
cmp_deeply [ find(5, 20000, 0, 1) ],
bag(glob '1{0,1}{0,1}{0,1}{0,1}');
cmp_deeply [ find(3, 222, 2) ],
[];
cmp_deeply [ find(10, 2000000022, 0, 2) ],
bag(2000000000, 2000000002, 2000000020);
cmp_deeply [ find(5, 30000, 1, 20, 300) ],
bag(11111, 11120, 11201, 11300, 12011, 12020,
13001, 20111, 20120, 20201, 20300);
cmp_deeply [ find(3, 789, 123, 456) ],
bag(123, 456);
done_testing();
```

]]>
You are given a linked list and a valuek. Write a script to partition the linked list such that all nodes less thankcome before nodes greater than or equal tok. Make sure you preserve the original relative order of the nodes in each of the two partitions.For example:

Linked List: 1 → 4 → 3 → 2 → 5 → 2 k = 3 Expected Output: 1 → 2 → 2 → 4 → 3 → 5.

We saw Linked List not so long ago, when solving the LRU Cache. Nevertheless, I didn’t reuse my solution, as I previously used a cyclic variant which doesn’t seem to be helpful here.

So, let’s start with a class of list elements. I call them “nodes”. Each node has a value and a link to a next node (undef if there’s none). A node can be disconnected from the next node, or a new node can be attached to it.

]]>```
package My::Node;
sub new {
my ($class, $value) = @_;
bless [ $value, undef ], $class
}
sub Next { $_[0][1] }
sub value { $_[0][0] }
sub disconnect {
my ($self) = @_;
my $next = $self->Next;
undef $self->[1];
return $next
}
sub attach {
my ($self, $new_next) = @_;
die "Already attached" if defined $self->Next;
$self->[1] = $new_next;
}
```

I also added two helper methods. One of them follows node links to the last element (the one that doesn’t have a next one), the second one attaches one node to such a last element linked from another node.

```
sub Last {
my ($self) = @_;
my $node = $self;
$node = $node->Next while $node->Next;
return $node
}
sub append {
my ($self, $new) = @_;
if (defined $new) {
$new->Last->attach($self);
} else {
$_[1] = $self;
}
}
```

With the node class ready, we can proceed to the linked list. The constructor creates a linked list from a given list of values (i.e. it wraps them into `My::Node`

objects and connects them by links). Each list has a head (the node that starts the list) and values (I use capital **V** to distinguish it from the core function) which extracts the values from the list.

```
package My::LinkedList;
sub new {
my ($class, @list) = @_;
my $top;
while (@list) {
my $value = pop @list;
my $node = 'My::Node'->new($value);
$node->attach($top) if $top;
$top = $node;
}
bless { head => $top }, $class
}
sub head {
my ($self, $head) = @_;
$self->{head} = $head if @_ > 1;
return $self->{head}
}
sub Values {
my ($self) = @_;
my $node = $self->head;
my @values;
while ($node) {
push @values, $node->value;
$node = $node->Next;
}
return \@values
}
```

So, how should we now implement the partitioning? We’ll prepare two possible new nodes, “head” and “tail”. Walking the list, we’ll then disconnect each node and append it to the head or tail according to the comparison of its value to **k**. At the end, we’ll just append the tail to the head.

```
sub partition {
my ($self, $k) = @_;
my $node = $self->head;
my ($head, $tail);
while ($node) {
my $next = $node->disconnect;
$node->append($node->value >= $k ? $tail : $head);
$node = $next;
}
$tail->append($head) if $head && $tail;
$_[0]{head} = $head || $tail;
}
```

So, when working with the sample input, this is how the nodes are distributed to the head and tail.

You can check my test suite at GitHub.

## Helper Function

For this task, you will most likely need a function

`f(a,b)`

which returns the count of different bits of binary representation of`a`

and`b`

.For example,

`f(1,3) = 1`

, since:Binary representation of 1 = 01

Binary representation of 3 = 11

There is only 1 different bit. Therefore the subroutine should return 1. Note that if one number is longer than the other in binary, the most significant bits of the smaller number are padded (i.e., they are assumed to be zeroes).

## Script Output

You script should accept

npositive numbers. Your script should sum the result of`f(a,b)`

for every pair of numbers given:For example, given 2, 3, 4, the output would be

6, since`f(2,3) + f(2,4) + f(3,4) = 1 + 2 + 3 = 6`

We’ll start with the helper function. To get the number of different bits, we want to get the number of ones in the result of **a xor b**, as `xor`

returns 1 when the bits are different:

a b a xor b --------------- 0 0 0 0 1 1 1 0 1 1 1 0

In Perl, the bitwise xor is written `^`

.

To count the number of ones in a bit vector, we can use the trick described in unpack. Unfortunately, it doesn’t work directly on the result of `$x ^ $y`

, because it treats it as a string, so we first need to convert it to its binary numeric representation using pack:

```
sub diff_bits {
my ($x, $y) = @_;
return unpack '%32b*', pack 'N', $x ^ $y
}
```

To apply this to a list of integers, we need to iterate over all the possible pairs and sum the results:

```
sub chain_diff_bits {
my (@list) = @_;
my $s = 0;
for my $i (0 .. $#list - 1) {
for my $j ($i + 1 .. $#list) {
$s += diff_bits($list[$i], $list[$j]);
}
}
return $s
}
```

It seems like we’ve finished the task!

But, our method contains nested loops, which means it’s terribly inefficient. I’ve used a pen and paper to try whether it would be possible to compute the result more quickly, and I’ve found a way.

Imagine the following three numbers as input: 89, 106, and 116. In binary, they are

89 | 1 1 1 0 1 0 0 106 | 1 1 0 1 0 1 0 116 | 1 0 1 1 0 0 1 ---+-------------- 0+2+2+2+2+2+2 = 12

Do you see? The difference is always 0 or 2, it can never be 1 (for three numbers). Why is that?

In fact, if we have all the bits at a given position, each of them is either 0 or 1. The number of all differences is the number of zeros times the number of ones.

This leads to the fast solution which, as you might noticed, doesn’t use the helper function at all. In fact, the helper function was a red herring!

We loop over all the positions, and count the number of ones at the given position in binary representations of all the input numbers. The number of zeros can be easily computed as the number of all the numbers minus the number of ones. To get the number of ones, we use the bitwise AND: &.

```
sub chain_diff_bits_fast {
my (@list) = @_;
my $s = 0;
my $mask = 1;
for (1 .. 8 * length $list[0]) {
my $ones = grep $mask & $_, @list;
$mask <<= 1;
$s += $ones * (@list - $ones);
}
return $s
}
```

The `$mask`

starts at 1 and it shifts one bit to the left in each iteration, i.e. it takes the values 1, 2, 4, 8, 16, etc. Using `$mask & $_`

returns the bit at the given position, grep in scalar context returns the number of true values, i.e. the number of set bits.

Here’s a benchmark for a list of 1000 random integers < 100:

Rate old newest old 4.48/s -- -100% newest 1442/s 32115% --

That’s a **huge** improvement!

Compare two given version number stringsv1andv2such that:

- If
v1>v2return 1- If
v1<v2return -1- Otherwise, return 0
The version numbers are non-empty strings containing only digits, and the dot (“.”) and underscore (“_”) characters. (“_” denotes an alpha/development version, and has a lower precedence than a dot, “.”). Here are some examples:

v1 v2 Result 0.1 < 1.1 -1 2.0 > 1.2 1 1.2 < 1.2_5 -1 1.2.1 > 1.2_1 1 1.2.1 = 1.2.1 0

When I read the task assignment, I thought to myself: I’m not the first person in the world that needs to compare versions. There already must be a module on CPAN that does exactly that. As usually, it wasn’t so simple.

]]> In fact, there’s one module to compare versions directly in the core: version. Using it to solve the task is straightforward:```
#!/usr/bin/perl
use warnings;
use strict;
use version;
sub compare_versions {
my ($v1, $v2) = @_;
'version'->parse($v1) <=> 'version'->parse($v2)
}
```

The version objects overload the comparison operator in a way that should work exactly as we need. Let’s verify it by a test suite build from the table above:

```
use Test::More tests => 5;
is compare_versions('0.1', '1.1'), -1;
is compare_versions('2.0', '1.2'), 1;
is compare_versions('1.2', '1.2_5'), -1;
is compare_versions('1.2.1', '1.2_1'), 1;
is compare_versions('1.2.1', '1.2.1'), 0;
```

Alas, the test № 4 fails. According to the module, 1.2.1 doesn’t come after 1.2_1, it isn’t the same version, either, but 1.2.1 comes **before** 1.2_1. The documentation claims otherwise, and there’s a bug report #118493: How to compare version objects that discusses the discrepancy among other things. But it seems the implementation is correct because it’s consistent with the way how Perl interprets versions, so 1.2_1 is in fact understood as 1.21 which is definitely greater than 1.2.1.

CPAN offers another module to work with versions: Perl::Version. It handles trial versions as described in the task (which might change in the future, because it’s inconsistent with the way how Perl does it, see above). Switching to it satisfies all the tests:

```
use Perl::Version;
sub compare_versions {
my ($v1, $v2) = @_;
'Perl::Version'->new($v1) <=> 'Perl::Version'->new($v2)
}
```

Write a script to arrange people in a lineup according to how many taller people are in front of each person in line. You are given two arrays.@His a list of unique heights, in any order.@Tis a list of how many taller people are to be put in front of the corresponding person in@H. The output is the final ordering of people’s heights, or an error if there is no solution.Here is a small example:

`@H = (2, 6, 4, 5, 1, 3) # Heights @T = (1, 0, 2, 0, 1, 2) # Number of taller people in front`

The ordering of both arrays lines up, so

`H[i]`

and`T[i]`

refer to the same person. For example, there are 2 taller people in front of the person with height 4, and there is 1 person in front of the person with height 1.Your script would then output the ordering

`(5, 1, 2, 6, 3, 4)`

in this case. (The leftmost element is the “front” of the array.)

I needed a pen and paper to solve this which probably means we’ve moved into a more advanced phase of the challenge. In fact, when solving problems in programming competitions, using a pen and paper first is the only way for me to proceed (BTW, this weekend I participated in the Code Jam round 1C; I needed three sheets of paper, but solved only two tasks of three which gave me enough points to advance to the next round, but unfortunately, I was too slow, there were about 250 more people with the same score who finished before me).

First, I tried to line the people up starting from the smallest one. In our example, it’s the 1. They want to have one taller person in front of them—but we have just started and don’t have anyone else to place there.

So, let’s try to start with the tallest one. It’s the 6 who wants to have 0 taller people in front of them. In fact, they can’t get more than 0, as they’re the tallest one. The tallest but one is 5, they also want 0 taller people in front of them (they could have wanted 1), so we must place them **in front of** 6:

5 6

Now it’s 4’s turn. They want 2 taller people in front of them, so they’ll go behind the first two:

5 6 4

Three also wants 2 people, so it must go between 6 and 4:

5 6 3 4

Two wants just one taller person in front of them, so they’ll go between 5 and 6:

5 2 6 3 4

And 1 wants also just one person, so they’ll go in front of 2:

5 1 2 6 3 4

That’s the expected output! We have the algorithm, so let’s translate it to Perl. I used a temporary structure `@ht`

which is an array representing the people, each person is represented as a pair of their height and taller people requirement:

```
#!/usr/bin/perl
use warnings;
use strict;
use List::UtilsBy qw{ rev_nsort_by };
sub order {
my ($h, $t) = @_;
my @ht = map [ $h->[$_], $t->[$_] ], 0 .. $#$h;
my @r;
for my $ht (rev_nsort_by { $_->[0] } @ht) {
die "@$ht" if $ht->[1] > @r;
my $i = my $h = 0;
$r[$i++] > $ht->[0] and ++$h while $h < $ht->[1];
splice @r, $i, 0, $ht->[0];
}
return \@r
}
use Test::More tests => 20;
use Test::Exception;
is_deeply order([2, 6, 4, 5, 1, 3],
[1, 0, 2, 0, 1, 2]),
[5, 1, 2, 6, 3, 4];
is_deeply order([27, 21, 37, 4, 19, 52, 23, 64, 1, 7, 51, 17, 24, 50,
3, 2, 34, 40, 47, 20, 8, 56, 14, 16, 42, 38, 62, 53,
31, 41, 55, 59, 48, 12, 32, 61, 9, 60, 46, 26, 58,
25, 15, 36, 11, 44, 63, 28, 5, 54, 10, 49, 57, 30,
29, 22, 35, 39, 45, 43, 18, 6, 13, 33],
[6, 41, 1, 49, 38, 12, 1, 0, 58, 47, 4, 17, 26, 1, 61,
12, 29, 3, 4, 11, 45, 1, 32, 5, 9, 19, 1, 4, 28, 12,
2, 2, 13, 18, 19, 3, 4, 1, 10, 16, 4, 3, 29, 5, 49,
1, 1, 24, 2, 1, 38, 7, 7, 14, 35, 25, 0, 5, 4, 19,
10, 13, 4, 12]),
[35, 23, 5, 64, 37, 9, 13, 25, 16, 44, 50, 40, 2, 27, 36, 6, 18,
54, 20, 39, 56, 45, 12, 47, 17, 33, 55, 30, 26, 51, 42, 53, 49,
41, 32, 15, 22, 60, 14, 46, 24, 59, 10, 28, 62, 38, 58, 63, 8,
48, 4, 7, 31, 19, 61, 43, 57, 11, 1, 34, 21, 52, 29, 3];
is_deeply order([1, 2, 3], [0, 0, 0]), [1, 2, 3];
is_deeply order([1, 2, 3], [0, 1, 0]), [1, 3, 2];
is_deeply order([1, 2, 3], [1, 0, 0]), [2, 1, 3];
is_deeply order([1, 2, 3], [1, 1, 0]), [3, 1, 2];
is_deeply order([1, 2, 3], [2, 0, 0]), [2, 3, 1];
is_deeply order([1, 2, 3], [2, 1, 0]), [3, 2, 1];
throws_ok { order([1], [1]) } qr/1 1/;
throws_ok { order([1, 2], [1, 1]) } qr /2 1/;
throws_ok { order([1, 2, 3], [1, 2, 0]) } qr/2 2/;
throws_ok { order([1, 2, 3], [0, 0, 1]) } qr/3 1/;
throws_ok { order([1, 2, 3], [0, 1, 1]) } qr/3 1/;
throws_ok { order([1, 2, 3], [1, 1, 1]) } qr/3 1/;
throws_ok { order([1, 2, 3], [1, 0, 1]) } qr/3 1/;
throws_ok { order([1, 2, 3], [2, 0, 1]) } qr/3 1/;
throws_ok { order([1, 2, 3], [2, 1, 1]) } qr/3 1/;
throws_ok { order([1, 2, 3], [2, 2, 1]) } qr/3 1/;
throws_ok { order([1, 2, 3], [0, 2, 0]) } qr/2 2/;
throws_ok { order([1, 2, 3], [2, 2, 0]) } qr/2 2/;
```

Note that the invalid cases are correctly recognised: any time a person wants to have more taller people in front of them than available, there’s no solution. Also, if there’s no such person, there is a solution.

]]>Write a script to find the shortest unique prefix for each each word in the given list. The prefixes will not necessarily be of the same length.Sample Input

[ "alphabet", "book", "carpet", "cadmium", "cadeau", "alpine" ]Expected Output

[ "alph", "b", "car", "cadm", "cade", "alpi" ]

Let me start with the second task as it was definitely simpler (at least for me).

We iterate over all the input words. For each word, we try to find the shortest prefix possible. To know what prefixes have already been used, we keep two hashes: one stores the abandoned prefixes (i.e. those that were not unique anymore), the second one stores the “current” prefixes (the prefix is the key, the actual word is the value). We start from length 1 and add 1 in each step. If the prefix isn’t used and hasn’t been used, we assign it to the word and proceed to the next word. If the prefix is currently used for a different word, we store the prefix as “used” and prolong the prefix for the old word by one—but we continue the loop for the current word, in case their common prefix is longer.

]]> At the end, we map the words to the prefixes and return them. Here’s the code with some tests:```
#!/usr/bin/perl
use warnings;
use strict;
sub shortest_unique_prefixes {
my @words = @_;
my (%prefixes, %used);
for my $word (@words) {
my $i = 1;
while ($i <= length $word) {
my $prefix = substr $word, 0, $i++;
if (exists $prefixes{$prefix}) {
undef $used{$prefix};
my $old = $prefixes{$prefix};
$prefixes{ substr $old, 0, $i }
= delete $prefixes{$prefix};
die "Duplicate prefix: $prefix ($old:$word)"
if $i > length $word || $i > length $old;
} elsif (! exists $used{$prefix}) {
$prefixes{$prefix} = $word;
last
}
}
}
my %to_prefixes = reverse %prefixes;
return [@to_prefixes{@words}]
}
use Test::More tests => 4;
use Test::Exception;
is_deeply
shortest_unique_prefixes(
qw( alphabet book carpet cadmium cadeau alpine )),
[qw[ alph b car cadm cade alpi ]],
'sample input';
throws_ok {
shortest_unique_prefixes(qw( perl perl ))
} qr/Duplicate prefix: perl /, 'detect duplicate';
throws_ok {
shortest_unique_prefixes(qw( A AA AAA ))
} qr/Duplicate prefix: A /, 'common prefix asc';
throws_ok {
shortest_unique_prefixes(qw( BBB BB B ))
} qr/Duplicate prefix: B+ /, 'common prefix desc';
```

Note that for “perl” and „perlaceous”, the subroutine dies, as there’s no unique prefix to distinguish the two words.

You are given a full binary tree of any height, similar to the one below:1 / \ 2 3 / \ / \ 4 5 6 7Write a script to invert the tree, by mirroring the children of every node, from left to right. The expected output from the tree above would be:

1 / \ 3 2 / \ / \ 7 6 5 4The input can be any sensible machine-readable binary tree format of your choosing, and the output should be the same format.

BONUSIn addition to the above, you may wish to pretty-print your binary tree in a human readable text-based format similar to the following:

1 / \ 3 2 / \ / \ 7 6 5 4

There are two basic ways to represent a tree.

- List of the edges. In our case, we might need to add the information whether the edge goes to the left or to the right, but we can also imagine that the first edge described for a given parent is always the left one. Example: (child direction parent)
2 L 1 3 R 1

- Nest the values. Follow the parent’s value with the children’s values enclosed in parentheses. Example:
1(2,3)

The first serialisation way is easy to invert. We don’t remove nor add any edges, we just change their orientation. So, to invert a tree, we just need to replace all L’s with R’s and vice versa.

```
#!/usr/bin/perl
use warnings;
use strict;
print tr/LR/RL/r while <>;
```

If we hadn’t indicated the direction of an edge but assumed the first edge for a given parent goes to the left, the solution would have been to print the edges in the reversed order.

`print for reverse <>;`

The second notation is a bit more complex. We need to build some kind of a structure, invert it, and serialise it back. We could use a recursive structure to reflect the input, but it’s easier to just store a list of children for each parent (and it’s easier to implement the inversion for such a representation, too).

```
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
sub invert {
my ($tree) = @_;
$_ = [reverse @$_] for values %$tree;
}
sub serialise {
my ($node, $tree) = @_;
return $node unless exists $tree->{$node};
return "$node("
. join(',', map serialise($_, $tree), @{ $tree->{$node} })
. ')'
}
chomp( my $structure = <> );
my %tree;
while ($structure =~ s/([0-9]+) \( ([0-9]+) , ([0-9]+) \) /$1/x) {
my ($parent, $left, $right) = ($1, $2, $3);
$tree{$parent} = [$left, $right];
}
invert(\%tree);
say serialise($structure, \%tree);
```

If you’re interested how the recursive representation works, here’s the solution, too:

```
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
use Marpa::R2;
sub invert {
my ($tree) = @_;
return $tree unless ref $tree;
my ($root) = keys %$tree;
$tree->{$root} = [ reverse @{ $tree->{$root} } ];
invert($_) for @{ $tree->{$root} };
}
sub serialise {
my ($tree) = @_;
return $tree unless ref $tree;
my ($root) = keys %$tree;
return "$root(" . join(',', map serialise($_), @{ $tree->{$root} })
. ')'
}
my $dsl = << '__DSL__';
lexeme default = latm => 1
Tree ::= node action => ::first
| node ('(') Tree (',') Tree (')') action => subtree
node ~ [0-9]+
__DSL__
sub subtree { +{ $_[1] => [ $_[2], $_[3] ] } }
my $grammar = 'Marpa::R2::Scanless::G'->new({ source => \$dsl });
chomp( my $input = <> );
my $tree = ${ $grammar->parse(\$input, {semantics_package => 'main'}) };
invert($tree);
say serialise($tree);
```

Last thing to solve is the bonus. I originally tried to print the tree in the way shown in the task assignment, but it was too hard for my limited time. So, I decided to only print the tree rotated by 90°, i.e. like this:

1-+-2-+-4 | \-5 \-3-+-6 \-7

Note that the real fun starts when you use longer numbers.

I implemented a subroutine `to_graph`

that takes two arguments, `$root`

and `$tree`

, where `$tree`

corresponds to the structure shown above: it is a hash reference where the keys are the parents and values are the arrays of children.

```
sub to_graph {
my ($root, $tree) = @_;
_to_graph($root, $tree, my $output = []);
return @$output
}
sub _to_graph {
my ($root, $tree, $output, @lines) = @_;
push @$output, $root;
if (my @children = @{ $tree->{$root} // [] }) {
push @$output, '-+-';
_to_graph($children[0], $tree, $output, @lines,
(' ' x length($root)) . ' | ');
push @$output, @lines, ' ' x length $root, ' \\-';
_to_graph($children[1], $tree, $output, @lines,
(' ' x (2 + length($root))) . ' ');
} else {
push @$output, "\n";
}
}
```

It’s a recursive solution. It prints the parent, and then it serialises the children in a way they are aligned and keep all the needed higher parts of the tree printed. All the vertical lines and spaces to be printed before the node are kept in the `@lines`

array. For added beauty, we can use the Unicode box drawing characters to get the following output:

10─┬─200─┬─4 │ └─50000 └─300000─┬─6000000 └─700

To verify it works I also implemented the conversion from the “edges” format to the same structure, a test suite included. You can find the whole code in GitHub.

What’s missing? Maybe you’ve noticed we haven’t validated the input. There’s almost no error checking, the code can fail in various ways if the input doesn’t follow the specification. In fact, writing a validator for both the “edges” and “structure” formats (for any trees, not just full binary ones) was one of the homework assignments I gave to the students of my Introduction to Natural Language Processing course back at my postdoc days. Maybe we can reuse this task in a future challenge? Which of the two formats is easier to validate?

]]>You are given an array@Nof positive integers (sorted) and another non negative integer$k. Write a script to find if there exists 2 indices$iand$jsuch that`$A[$i] - $A[$j] == $k and $i != $j`

. It should print the pairs of indices, if any such pairs exist.Example:

`@N = (2, 7, 9); $k = 2;`

Output: 2, 1

I totally ignored the fact that the input array is sorted. My solution works for any input array, but it’s still rather efficient.

The basic trick is that we don’t have to compute `$A[$i] - $A[$j]`

for each combination or `$i`

and `$j`

. We know `$k`

from the very beginning, so we can just iterate the array for the first time to store it in a hash, and iterate it for the second time to check the hash whether the corresponding number exists in the array.

```
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
my @N = (2, 7, 9);
my $k = 2;
my %in_array;
@in_array{ @N } = 0 .. $#N;
for (@N) {
say join ', ', @in_array{ $k + $_, $_ }
if exists $in_array{ $k + $_ };
}
```

]]>
It works for the sample input, but it has a problem: It doesn’t work if a number is repeated in the array (because hash keys are unique). To fix it, we need to use a hash of arrays instead of a plain hash, and for each number store all the indices it appears at.
```
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
my @N = (2, 7, 9, 2, 7, 4);
my $k = 2;
my %in_array;
push @{ $in_array{ $N[$_] } }, $_ for 0 .. $#N;
for my $n (0 .. $#N) {
if (my $found = $in_array{ $N[$n] + $k }) {
say "$_, $n" for @$found;
}
}
```

The output lists all the possible pairs:

5, 0 2, 1 5, 3 2, 4

You are given a binary tree and a sum, write a script to find if the tree has a path such that adding up all the values along the path equals the given sum. Only complete paths (from root to leaf node) may be considered for a sum.

ExampleGiven the below binary tree and sum = 22,

5 / \ 4 8 / / \ 11 13 9 / \ \ 7 2 1For the given binary tree, the partial path sum

5 → 8 → 9 = 22isnotvalid. The script should return the path5 → 4 → 11 → 2whose sum is22.

So we are only interested in leaf nodes. Note that for each node, the sum corresponds to the sum of its parent plus the value of the node itself. We can process the tree in the depth-first order (using recursion), computing the sum for each node. If we arrive at a leaf node, we remember the sum. We also need to remember the path, but it’s similar: the path of a node is its parent’s path joined with the node itself.

At the beginning, I flirted with the idea of implementing a parser of the input tree, but I realised the format hadn’t been precisely specified, so I decided to postpone it. In hindsight, it was a good decision, otherwise I’d be bored this week.

```
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
use Syntax::Construct qw{ // };
sub fill_sum {
_fill_sum($_[0], 0, [], my $path_sums = {});
return $path_sums
}
sub _fill_sum {
my ($tree, $parent_sum, $parent_path, $path_sums) = @_;
$tree->{s} = $tree->{v} + ($parent_sum // 0);
$tree->{p} = [ @$parent_path, $tree->{v} ];
if ($tree->{ch}) {
_fill_sum($_, $tree->{s}, $tree->{p}, $path_sums)
for @{ $tree->{ch} };
} else {
push @{ $path_sums->{ $tree->{s} } }, $tree->{p};
}
}
my $tree = {
v => 5, ch => [
{ v => 4, ch => [
{ v => 11, ch => [
{ v => 7 },
{ v => 2 }
] }
] },
{ v => 8, ch => [
{ v => 13 },
{ v => 9, ch => [
{ v => 1 }
] }
] }
] };
my $sum = 22;
my $path_sums = fill_sum($tree);
say join '->', @$_ for @{ $path_sums->{$sum} // [] };
```

As you can see, *v* stands for “value”, *ch* is for “children”, *p* means the “path”, and *s* represents the “sum”.

Write a script to accept two integersn(>=1) andk(>=1). It should print thek-th permutationofnintegers.For example,

n=3andk=4, the possible permutation sequences are listed below:123 132 213 231 312 321The script should print the

4sequence^{th}permutation231.

The straightforward way is to generate all the permutations in the correct order and then output the k^{th} one. To generate them, we can use recursion: To get all the permutations of **n** elements, start with each element and extend it with all the permutations of the remaining elements.

```
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
sub perm {
my ($src) = @_;
return [$src] if 1 == @$src;
my @perms;
for my $s (@$src) {
my $subperms = perm([grep $s != $_, @$src]);
push @perms, map [$s, @$_], @$subperms;
}
return \@perms
}
sub kth_perm {
my ($n, $k) = @_;
return @{ perm([1 .. $n])->[$k - 1] }
}
my ($n, $k) = @ARGV;
say kth_perm($n, $k);
```

The problem of this solution is performance. It takes it more than 2 seconds to output the 5678^{th} permutation of 1 .. 9. If we replace the `!=`

with `ne`

so we can process permutations of letters, too, it takes twice as more.

There is a way how to construct the k^{th} permutation directly without enumerating the previous ones. Let’s have a closer look: The first character divides all the permutations into **n** groups.

1234 2134 3124 4123 1243 2143 3142 4132 1324 2314 3214 4213 1342 2341 3241 4231 1423 2413 3412 4312 1432 2431 3421 4321

Size of each group is the number of permutations of **n - 1** elements (i.e. the characters following the first one). And the same applies to subgroups of each group, e.g.

1234 1324 1423 1243 1342 1432

Size of each group is the number of permutations of the remaining elements.

The number of all the permutations of **x** elements is **x!** or *x factorial*, i.e. `product(1 .. $x)`

. If the **k** is given, e.g. 15, we can divide it by the size of a subgroup to know what group we can find the result in (`int(15 / 6) == 3`

). To repeat the step recursively, we need to know what **k** will be used in the subgroup. If we try searching several times, we’ll realise it’s the remainder of the division, i.e. `15 % 6 == 3`

(in the code bellow, you can notice I simplified the border conditions).

```
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
use List::Util qw{ product };
sub perm_recurse {
my ($k, @n) = @_;
return "" unless @n;
my $factorial = product(1 .. @n);
my $step = $factorial / @n;
my $select = int($k / $step);
--$select unless $k % $step;
return $n[$select]
. perm_recurse(($k % $step) || $step,
@n[ grep $_ != $select, 0 .. $#n ])
}
sub kth_perm { perm_recurse($_[1], 1 .. $_[0]) }
my ($n, $k) = @ARGV;
say kth_perm($n, $k);
```

This code finds the 5678^{th} permutations of 9 elements in less than 0.01 seconds. Even calculating `perm_recurse(10, 'a' .. 'z')`

takes less than a 0.1 seconds, not talking about the memory consumption of the naive approach.

It is thought that the following sequence will always reach 1:$n = $n / 2 when $n is even $n = 3*$n + 1 when $n is oddFor example, if we start at

23, we get the following sequence:23 → 70 → 35 → 106 → 53 → 160 → 80 → 40 → 20 → 10 → 5 → 16 → 8 → 4 → 2 → 1Write a function that finds the

Collatzsequence for any positive integer. Notice how the sequence itself may go far above the original starting number.## Extra Credit

Have your script calculate the sequence length for all starting numbers up to 1000000 (1e6), and output the starting number and sequence length for the longest 20 sequences.

I started with the naive implementation again. This time, there’s not trick, including the extra credit: just enumerate all the sequences, remember them in an array, sort them by size and output the top 20.

```
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
sub collatz {
my ($start) = @_;
my @seq = $start;
push @seq, ($seq[-1] / 2, 3 * $seq[-1] + 1)[$seq[-1] % 2]
while $seq[-1] != 1;
return @seq
}
my @sizes;
push @sizes, [$_, scalar collatz($_)] for 1 .. 1e6;
say "@$_" for reverse +(sort { $b->[1] <=> $a->[1] } @sizes)[0 .. 19];
```

I was worried about the performance again. The program took 38 seconds to compute the extra credit task which didn’t sound fast. I tried to only keep a heap of the 20 longest sequences instead of storing all of them, but it was in fact even slower. I also compared my solution to Laurent’s one, realising dynamic programming would shave off about 6 seconds (about 15%). I wasn’t sure such a small gain was worth the effort, so I stopped there.

]]>Write a script to rotate the following matrix by given90/180/270 degreesclockwise.[ 1, 2, 3 ] [ 4, 5, 6 ] [ 7, 8, 9 ]For example, if you rotate by 90 degrees then expected result should be like below

[ 7, 4, 1 ] [ 8, 5, 2 ] [ 9, 6, 3 ]

The easiest way to work with multidimensional data in Perl is PDL. Interestingly, I haven’t found a direct method to rotate a matrix in this way.

What I have found, though, was a method to *transpose* a matrix, which means to switch the columns and rows. The result for the sample input is

Unfortunately, it’s not what we want. We need to reverse each line of the result. This can be achieved by calling the `slice`

method with the argument of `[-1, 0]`

which means "return the elements of the first dimension from the last one to the first one”.

```
#!/usr/bin/perl
use warnings;
use strict;
use PDL;
my $matrix = pdl([1, 2, 3],
[4, 5, 6],
[7, 8, 9]);
for my $rotation (0, 90, 180, 270) {
my $times = $rotation / 90;
my $result = $matrix;
$result = $result->transpose->slice([-1, 0]) for 1 .. $times;
print "$rotation:$result";
}
```

Write a script to accept an integer1 <= N <= 5that would print all possible strings of sizeNformed by using only vowels (a, e, i, o, u). The string should follow the following rules:

- ‘
a’ can only be followed by ‘e’ and ‘i’.- ‘
e’ can only be followed by ‘i’.- ‘
i’ can only be followed by ‘a’, ‘e’, ‘o’, and ‘u’.- ‘
o’ can only be followed by ‘a’ and ‘u’.- ‘
u’ can only be followed by ‘o’ and ‘e’.For example, if the given integer

N = 2then script should print the following strings:ae ai ei ia io iu ie oa ou uo ue

A recursive solution similar to last week’s Stepping Numbers came to my mind, but I decided to solve this task differently.

Let’s see how we can replace recursion with a loop. We need to keep an array with the strings to process; each iteration of the loop will generate a new array of extended strings that will be used in the next iteration (or as the result in the last iteration).

```
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
my %next = (
a => [qw[ e i ]],
e => [qw[ i ]],
i => [qw[ a e o u ]],
o => [qw[ a u ]],
u => [qw[ o e ]]);
my $n = shift;
die "Invalid argument" unless ($n // "") =~ /^[1-5]$/;
my @agenda = sort keys %next;
while ($n > length $agenda[0]) {
my @next;
for my $string (@agenda) {
my $last = substr $string, -1;
push @next, map $string . $_, @{ $next{$last} };
}
@agenda = @next;
}
say for @agenda;
```

]]>
Write a script to accept two numbers between 100 and 999. It should then print allStepping Numbersbetween them.A number is called a stepping number if the adjacent digits have a difference of 1. For example, 456 is a stepping number but 129 is not.

The naive approach would be to iterate over all the numbers from 100 to 999 and check the difference between each adjacent digits.

```
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
NUMBER: for my $n (100 .. 999) {
my @digits = split //, $n;
for my $i (1 .. $#digits) {
next NUMBER
unless 1 == abs($digits[$i - 1] - $digits[$i]);
}
say $n;
}
```

In fact, for the given range this is enough. But if we try to print all the stepping numbers of length 7 (1_000_000 .. 9_999_999), it takes more than 10 seconds.

]]> The more efficient way is to generate all the stepping numbers directly. Imagine we start from a single digit. Usually, we can extend the number in two ways: add the digit + 1 as the next digit, or digit - 1 (for 0 and 9, we only have one option). This process can be repeated until the number has the required length.I implemented this technique as a recursive subroutine.

```
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
my $LENGTH = 3;
my @stepping_numbers;
sub prolong {
my (@short) = @_;
my $last = $short[-1];
for my $next (grep $_ >= 0 && $_ <= 9,
$last - 1, $last + 1
) {
if ($LENGTH == @short + 1) {
push @stepping_numbers, join "", @short, $next;
} else {
prolong(@short, $next);
}
}
}
prolong($_) for 1 .. 9;
say for @stepping_numbers;
```

Changing the length to 7 makes almost no change in the running time; it usually finishes under 0.01 seconds.

Suppose there are following coins arranged on a table in a line in random order.£1, 50p, 1p, 10p, 5p, 20p, £2, 2pSuppose you are playing against the computer. Player can only pick one coin at a time from either ends. Find out the lucky winner, who has the larger amounts in total?

Let’s have a look at the coins first. The winner must take the £2, as all the other coins sump up to only £1.88.

If the number of the coins is even, there is a winning strategy for the player who starts the game: if they can take the £2 coin, let them do it. If they can’t, they must prevent the opponent from taking it: if it lies at position 1 or -2, let them **not** take the coin at position 0 or -1, respectively. Otherwise, they can play randomly.

I used Moo to implement the game as it made the code easier to read. Also, I only used pence in the code, to stay in the realm of integers (read Never Use Floats for Money if you haven't read it yet).

The program implements a simple command line game. You can play it against the computer who knows the best strategy. If the computer starts, it always wins. If you start, you can win unless you make a mistake.

Note that I only implemented everything from the point of view of player 1. The method `switch`

switches the players so the situation of player 2 can be analysed in the same way.

Note that the attributes `player1`

and `player2`

are declared with the `init_arg => undef`

. It means you can’t specify the amount of money for the player in the constructor, instead, the default is used, which is zero. Similarly, the `remaining`

attribute contains the remaining (not yet taken) coins; it’s initialised lazily and used `coins`

as the builder, i.e. it’s initialised to the list of the starting coins.

```
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
{ package My::Game;
use Moo;
has [qw[ player1 player2 ]] => (
is => 'rw', default => 0, init_arg => undef);
has coins => (is => 'ro', required => 1);
has remaining => (
is => 'rw', lazy => 1, builder => 'coins');
sub auto {
my ($self) = @_;
if (1 == @{ $self->remaining }
|| $self->remaining->[0] == 200
) {
$self->turn('l');
} elsif ($self->remaining->[-1] == 200
|| $self->remaining->[1] == 200
) {
$self->turn('r');
} else {
$self->turn('l');
};
}
sub turn {
my ($self, $where) = @_;
$where = lc substr $where, 0, 1;
my $pos = { l => 0, r => -1 }->{$where};
$self->player1($self->player1
+ splice @{ $self->remaining }, $pos, 1);
$self->switch;
}
sub switch {
my ($self) = @_;
my $p = $self->player1;
$self->player1($self->player2);
$self->player2($p);
}
sub finished {
! @{ $_[0]->remaining }
}
sub status {
my ($self) = @_;
$self->player1, ', ', $self->player2,
": @{ $self->remaining }";
}
sub result {
my ($self) = @_;
die "Not yet finished" unless $self->finished;
return ('draw', 'Player 1 wins', 'Player 2 wins')[
$self->player1 <=> $self->player2 ]
}
}
use List::Util qw{ shuffle };
my @coins = shuffle(100, 50, 1, 10, 5, 20, 200, 2);
say "@coins";
say "Input 'left' or 'right' (or just 'l' or 'r').";
my $starting_player = 1 + int rand 2;
say "Starting player: $starting_player";
my $game = 'My::Game'->new(coins => \@coins);
$game->auto if 2 == $starting_player;
until ($game->finished) {
say $game->status;
my $where;
do {
chomp( $where = <> );
} until $where =~ /^(l(eft)?|r(ight)?)$/i;
$game->turn($where);
$game->auto unless $game->finished;
}
$game->switch if 2 == $starting_player;
say $game->status, $game->result;
```

]]>
Given an array`@L`

of integers. Write a script to find all uniquetripletssuch thata + b + cis same as the given targetT. Also make surea <= b <= c.Here is wiki page for more information.

Example:

`@L = (-25, -10, -7, -3, 2, 4, 8, 10);`

One such triplet for target 0 i.e. -10 + 2 + 8 = 0.

I hadn’t checked the wiki page before writing my solution; and I hadn’t changed the solution after I read it. Therefore, it presents the naive and inefficient solution that iterates over all the possible triplets (but not starting from 0 in the inner loops to avoid checking the same triplet several times).

]]>```
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
my @L = (-25, -10, -7, -3, 2, 4, 8, 10);
my $target = 0;
for my $i (0 .. $#L - 2) {
for my $j ($i + 1 .. $#L - 1) {
for my $k ( $j + 1 .. $#L) {
say join ' + ', sort { $a <=> $b } @L[$i, $j, $k]
if $target == $L[$i] + $L[$j] + $L[$k];
}
}
}
```

Write a script to display allColourful Numberswith 3 digits.A number can be declared

Colourful Numberwhere all the products of consecutive subsets of digit are different.For example,

263is aColourful Numberb since2, 6, 3, 2×6, 6×3, 2×6×3are unique.

To get all the consecutive subsets, we need to inspect all the substrings (not subsequences, as they don’t have to be consecutive) starting at each position.

Let’s implement it as two nested loops, the outer one looping over the possible lengths of the substring, the inner one looping over the starting positions.

The pattern describing the subset is then an array of zeros before the position and ones starting at position, repeated length times. We can then use grep to map the pattern to the original digits. We can store the product in a hash and at the end, check the number of different products, i.e. the number of keys in the hash. If all the products are unique, the number will equal the number of all the possible substrings.

If the length of the input is *n*, there is **1** substring of length *n*, it starts at position 0 and spans the whole input. For length *n* - 1, there are two substrings, starting at positions 0 and 1; and so on up to length **1** which can start at any position **0** .. *n* - 1. Therefore, there are 1 + 2 + … + *n* possible substrings, which can be expressed as (*n* + 1)*n* / 2 or (*n*^{2} + *n*) / 2.

```
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
use List::Util qw{ product };
sub is_colourful_number {
my ($n) = @_;
my $max_length = length $n;
my %uniq;
my $count = 0;
for my $length (1 .. $max_length) {
for my $pos (0 .. $max_length - $length) {
my @pattern = ((0) x $pos, (1) x $length);
undef $uniq{
product((split //, $n)[ grep $pattern[$_],
0 .. $#pattern ])
};
}
}
return ($max_length ** 2 + $max_length) / 2 == keys %uniq;
}
say for grep is_colourful_number($_), 100 .. 999;
```

]]>
Write a script to merge the given intervals where ever possible.[2,7], [3,9], [10,12], [15,19], [18,22]The script should merge

[2, 7]and[3, 9]together to return[2, 9].Similarly it should also merge

[15, 19]and[18, 22]together to return[15, 22].The final result should be something like below:

[2, 9], [10, 12], [15, 22]

This sounds so similar to PWC 039 I first thought I could solve it in the same way. Unfortunately, Set::IntSpan gives a different result:

```
#!/usr/bin/perl
use warnings;
use strict;
use Set::IntSpan;
my @intervals = ([2, 7], [3, 9], [10, 12], [15, 19], [18, 22]);
my $set = 'Set::IntSpan'->new([@intervals]);
print $set; # 2-12,15-22
```

The reason is that the module only considers integers. There’s no integer between 9 and 10, so the spans 2-9 and 10-12 can be merged into one span 2-12.

]]> Instead of searching CPAN for a module that gives the right output, I decided to implement a solution myself. It turned out to be more complex than I thought.As usually, I started with test cases, trying to capture all the possible arrangements of two or three intervals:

```
#!/usr/bin/perl
use warnings;
use strict;
use Test::More;
sub test {
my ($init, $expected) = @_;
my $i = 'MyInterval'->new;
$i->insert(@$_) for @{ $init };
is_deeply $i, $expected,
join ', ', map do {local $" = ':'; "@$_"}, @$init;
}
test([[1,2]], [[1,2]]);
test([[1,2],[3,4]], [[1,2],[3,4]]);
test([[3,4],[1,2]], [[1,2],[3,4]]);
# 1 2 3 4 5 6
# |-----|
test([[2,5],[1,2]], [[1,5]]); # |-|
test([[2,5],[1,3]], [[1,5]]); # |---|
test([[2,5],[1,5]], [[1,5]]); # |-------|
test([[2,5],[1,6]], [[1,6]]); # |---------|
test([[2,5],[2,3]], [[2,5]]); # |-|
test([[2,5],[2,5]], [[2,5]]); # |-----|
test([[2,5],[2,6]], [[2,6]]); # |------|
test([[2,5],[3,4]], [[2,5]]); # |-|
test([[2,5],[3,5]], [[2,5]]); # |---|
test([[2,5],[3,6]], [[2,6]]); # |-----|
test([[2,5],[5,6]], [[2,6]]); # |-|
test([[1,3],[5,7],[-1,0]], [[-1,0],[1,3],[5,7]]);
test([[1,3],[5,7],[-1,1]], [[-1,3],[5,7]]);
test([[1,3],[5,7],[-1,2]], [[-1,3],[5,7]]);
test([[1,3],[5,7],[-1,3]], [[-1,3],[5,7]]);
test([[1,3],[5,7],[-1,4]], [[-1,4],[5,7]]);
test([[1,3],[5,7],[-1,5]], [[-1,7]]);
test([[1,3],[5,7],[-1,6]], [[-1,7]]);
test([[1,3],[5,7],[-1,7]], [[-1,7]]);
test([[1,3],[5,7],[-1,8]], [[-1,8]]);
test([[1,3],[5,7],[1,2]], [[1,3],[5,7]]);
test([[1,3],[5,7],[1,3]], [[1,3],[5,7]]);
test([[1,3],[5,7],[1,4]], [[1,4],[5,7]]);
test([[1,3],[5,7],[1,5]], [[1,7]]);
test([[1,3],[5,7],[1,6]], [[1,7]]);
test([[1,3],[5,7],[1,7]], [[1,7]]);
test([[1,3],[5,7],[1,8]], [[1,8]]);
test([[1,3],[5,7],[2,2]], [[1,3],[5,7]]);
test([[1,3],[5,7],[2,3]], [[1,3],[5,7]]);
test([[1,3],[5,7],[2,4]], [[1,4],[5,7]]);
test([[1,3],[5,7],[2,5]], [[1,7]]);
test([[1,3],[5,7],[2,6]], [[1,7]]);
test([[1,3],[5,7],[2,7]], [[1,7]]);
test([[1,3],[5,7],[2,8]], [[1,8]]);
test([[1,3],[5,7],[3,3]], [[1,3],[5,7]]);
test([[1,3],[5,7],[3,4]], [[1,4],[5,7]]);
test([[1,3],[5,7],[3,5]], [[1,7]]);
test([[1,3],[5,7],[3,6]], [[1,7]]);
test([[1,3],[5,7],[3,7]], [[1,7]]);
test([[1,3],[5,7],[3,8]], [[1,8]]);
test([[1,3],[5,7],[4,4]], [[1,3],[4,4],[5,7]]);
test([[1,3],[5,7],[4,5]], [[1,3],[4,7]]);
test([[1,3],[5,7],[4,6]], [[1,3],[4,7]]);
test([[1,3],[5,7],[4,7]], [[1,3],[4,7]]);
test([[1,3],[5,7],[4,8]], [[1,3],[4,8]]);
test([[1,3],[5,7],[5,5]], [[1,3],[5,7]]);
test([[1,3],[5,7],[5,6]], [[1,3],[5,7]]);
test([[1,3],[5,7],[5,7]], [[1,3],[5,7]]);
test([[1,3],[5,7],[5,8]], [[1,3],[5,8]]);
test([[1,3],[5,7],[6,6]], [[1,3],[5,7]]);
test([[1,3],[5,7],[6,7]], [[1,3],[5,7]]);
test([[1,3],[5,7],[6,8]], [[1,3],[5,8]]);
test([[1,3],[5,7],[7,7]], [[1,3],[5,7]]);
test([[1,3],[5,7],[7,8]], [[1,3],[5,8]]);
test([[1,3],[5,7],[8,8]], [[1,3],[5,7],[8,8]]);
```

I then tried to implement the following idea: let’s keep the resulting intervals in an array, each interval is represented as a nested array of two elements. When merging a new interval, it should be possible to calculate the indices of the intervals to remove by splice. Unfortunately, there are lots of edge cases.

I proceeded in two steps. In the first step, we identify where the new interval starts and ends. The positions have three different representations: `[in => 2]`

means the start or end lies inside the interval at index 2, `[before => 3]`

means it doesn’t fall into any interval, but before the intervals at index 3; the third possibility is `[after => 4]`

where index 4 corresponds to the last index in the array. For example, if we’re merging [4, 8] into

```
[[1, 2], [3, 4], [6, 7], [9, 10]]
^----------^
```

the positions will be `[in => 1]`

and `[after => 2]`

. In the next step, this will be translated into changing 4 into 8 and removing the element [6, 7].

```
package MyInterval;
sub new { bless [], shift }
sub _where {
my ($self, $n) = @_;
my $pos;
if ($n >= $self->[$#$self][0]) {
$pos = $n > $self->[$#$self][1]
? [after => $#$self]
: [in => $#$self];
} else {
$pos = (grep $n <= $self->[$_][1], 0 .. $#$self)[0];
$pos = $self->[$pos][0] <= $n
? [in => $pos] : [before => $pos];
}
return $pos
}
sub insert {
my ($self, $from, $to) = @_;
unless (@$self) {
@$self = ([$from, $to]);
return
}
my $i = $self->_where($from);
my $j = $self->_where($to);
if ($i->[0] eq 'after') {
push @$self, [$from, $to];
} elsif ($i->[1] == $j->[1]) {
if ('before' eq $j->[0]) {
splice @$self, $j->[1], 0, [$from, $to];
} else {
$self->[ $j->[1] ][1] = $to if 'after' eq $j->[0];
$self->[ $i->[1] ][0] = $from if 'in' ne $i->[0];
}
} else {
my ($x, $y) = ($i->[1], $j->[1] - ('before' eq $j->[0]));
$self->[ $i->[1] ][1] = 'before' ne $j->[0]
? $self->[ $j->[1] ][1]
: $to;
splice @$self, $x + 1, $y - $x if $x < $y;
$self->[$x][0] = $from if $i->[0] eq 'before';
$self->[$x][1] = $to if $j->[0] eq 'after';
}
}
```

My original solution was a bit different and I wasn’t sure it worked correctly. So I decided to implement a different solution and compare the results.

We’ll represent the starts and ends of the intervals as keys in a hash. The values will represent the role of the key: when the key starts an interval, we’ll set its first bit; when it ends an interval, we’ll set its second bit; when it forms an interval of the form `[$n, $n]`

, we’ll set its third bit. For all the numbers *inside* an interval, we’ll set their first two bits.

When generating the output, we just sort the keys and skip those whose first two bits are set. The third bit needs handling only when we aren’t searching for an end of an interval.

```
package MyIntervalHash;
use enum 'BITMASK:' => qw( LEFT RIGHT SINGLE );
sub new { bless {}, shift }
sub insert {
my ($self, $from, $to) = @_;
$self->{$from} |= SINGLE, return if $from == $to;
$self->{$from} |= LEFT;
$self->{$_} = LEFT | RIGHT for $from + 1 .. $to - 1;
$self->{$to} |= RIGHT;
}
sub out {
my ($self) = @_;
my @r;
for my $k (sort { $a <=> $b } keys %$self) {
if (($self->{$k} & (LEFT | RIGHT)) == LEFT) {
push @r, [$k];
} elsif (($self->{$k} & (LEFT | RIGHT)) == RIGHT) {
push @{ $r[-1] }, $k
} elsif ((! @r || 1 != @{ $r[-1] }) && ($self->{$k} == SINGLE)) {
push @r, [$k, $k];
}
}
return \@r
}
```

To compare the two algorithms, I wrote a simple program that generated random lists of intervals, ran both the algorithms and compared the outputs:

```
use Test::More;
use Test::Deep;
use Data::Dumper;
while (1) {
my $l = 1 + int rand 12;
my @intervals = map [sort {$a <=> $b} int rand 20, int rand 20], 1 .. $l;
my $i1 = MyInterval->new;
my $i2 = MyIntervalHash->new;
$i1->insert(@$_), $i2->insert(@$_) for @intervals;
warn Dumper $i1, $i2->out;
cmp_deeply $i1, noclass($i2->out)
or die Dumper \@intervals;
}
```

When there was a different result, the program stopped and I fixed one of the algorithms. It took several iterations of this process to finally fix both the algorithms, I added the failed cases to my test suite:

```
test([[1,2],[5,6],[3,4]], [[1,2],[3,4],[5,6]]);
test([[1,2],[5,6],[2,5]], [[1,6]]);
test([[1,1],[2,2],[3,3]], [[1,1],[2,2],[3,3]]);
test([[0,6],[7,8],[12,19],[3,8]],[[0,8],[12,19]]);
test([[12, 14], [15, 19], [7, 8], [1, 12]],
[[1,14],[15,19]]);
test([[12, 17], [18, 18], [9, 9], [5, 17]],
[[5,17],[18,18]]);
```

Plus, of course, the initial example:

```
test([[2, 7], [3, 9], [10, 12], [15, 19], [18, 22]],
[[2, 9], [10, 12], [15, 22]]);
```

I also wanted to compare the performance of the algorithms. I ran the following benchmark:

```
use Time::HiRes qw{ gettimeofday tv_interval };
say STDERR 'Preparing data...';
my @meta_i = map {
my $l = 1 + int rand 2000;
[ map [sort {$a <=> $b} int rand 20, int rand 20], 1 .. $l]
} 1 .. 10_000;
say STDERR 'Benchmarking...';
for my $class (qw( MyInterval MyIntervalHash )) {
my $t0 = [gettimeofday];
for my $i (1 .. 10_000) {
my @intervals = @{ $meta_i[$i-1] };
my $I = $class->new;
$I->insert(@$_) for @intervals;
$I->out;
}
say $class, ' ', tv_interval($t0);
}
```

On my machine, the former algorithm took 25 seconds, while the latter took 15. Interestingly, the simpler algorithm was faster.

You are given a list,`@L`

, of three or more random integers between 1 and 50. A Noble Integer is an integerNin`@L`

, such that there are exactlyNintegers greater thanNin`@L`

. Output any Noble Integer found in`@L`

, or an empty list if none were found.An interesting question is whether or not there can be multiple Noble Integers in a list.

Let’ start with the interesting question.

Let’s imagine there are two Noble Integers in a list, N_{1} and N_{2}. If they aren't equal, we can assume N_{1} < N_{2}. As N_{1} is noble, there are N_{1} numbers in the list greater than N_{1}. N_{2} is **greater than N _{1}**, so there must be

Let’s start by sorting the input list in descending order. Then loop over the elements and check whether the number of greater numbers corresponds to the number itself. The number of greater numbers is 0 for the first element in the list (it’s the greatest number in the list, so there’s no greater number), we’ll increment it every time a number is different to the previous one (which ensures the algorithm handles repeated numbers correctly).

```
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
sub noble_integer {
my @s = sort { $b <=> $a } @_;
my $c = 0;
my @noble;
for my $i (0 .. $#s) {
push @noble, $s[$i] if $c == $s[$i];
++$c if $s[$i] != ($s[$i + 1] // $s[$i] + 1);
}
return @noble
}
use Test::More;
is_deeply [noble_integer(2, 6, 1, 3)], [2];
is_deeply [noble_integer(2, 2, 6, 1, 3)], [2, 2];
is_deeply [noble_integer(0, 0, 0)], [0, 0, 0];
```

]]>
`$set->(3, 7) for 1 .. $capacity;`

removes all other keys from the cache (improbable for caches with a large capacity, though).]]>