THE WEEKLY CHALLENGE – PERL & RAKU #51
TASK #1
3 Sum
Given an array @L of integers. Write a script to find all unique triplets such that a + b + c is same as the given target T. Also make sure a <= 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.
Method
When dealing with the 3SUM problem, in some way we will need to in the end evaluate all possible combinations of the array for a solution. Trivially, in three nested loops, this can be performed in cubic time. But that explodes pretty quickly, and we can do better; the challenge becomes to get that number down. One way to accomplish this is to refine the search space by better utilizing the information gained when we determine whether a given triplet of values satisfies the conditions. When we evaluate whether
a + b + c = T
we can instead determine whether the result is greater than, less than, or equal to T, and perform different actions based on the cases. For example, if the sum is already too high, no solution will present itself by increasing any of the values, so those possiblities can be immediately determined to fail without further evaluation and we can move on.
To proactively prune unproductive possibilities1, the input must first be sorted. This will allow us to intelligently adjust the indexes within the input array to grow or shrink the sum until an equality is either reached or found impossible. We fix the “a” variable to the lower end of the array, starting at index 0, and assign “b” and “c” from the indexes of the lower and upper bounds of the remaining range. When testing a given set of indices, if the sum comes out higher than the target, we reduce the index of the upper bound until it points to a lower value for “c”. If the sum is lower, we increase the index for “b” until it points to a higher value. If we find an equality, that value of “c” will be the only solution for the given “b”, so “b” index is incremented, and the value of “c” will then be too high for a higher value of “b”, so it is also decremented. Thus for any given “a” index, the list of elements after it is only iterated through once per element, although the actual movement is sometimes from the lower bound, sometimes from the upper, towards the center.
When the upper and lower bounds meet, the index for the value for “a” is incremented and the process repeated until either “a”, “b”, and “c” are set to the last three elements in the input array, or “a” is greater than the target. In this way we have still assessed every possible combination, but eliminated enough logically, to the point where we need not do any computation on them at all, to bring the complexity back into quadratic time.
Because scalar @list if often referenced yet never changes, we memoize this to save a little computation. It helped enough with the absurdly large test data set I ginned up to glean performance2 that I left it in.
1yes, of course that was fun to write
2100000 random elements between -1000..1000, ~500000 unique solutions. Trying to find the sweet spot between taking a long time and segfaulting.
Perl Solution
[colincrain@boris:~/Code/PWC]$ perl 51_1_tripleplay.pl
-9971, 230, 9741
-9971, 290, 9681
-9971, 1156, 8815
-9971, 1278, 8693
-9971, 2501, 7470
-9971, 2517, 7454
-9971, 3725, 6246
-9971, 3985, 5986
-9971, 4271, 5700
-9971, 4909, 5062
...use warnings;
use strict;
use feature ":5.26";
## ## ## ## ## MAIN:
## 1000 random elements between -9999..10000
my @L;
while (my $line = <DATA>) {
chomp $line;
push @L, split /, /, $line;
};
## nominally 0, but this can be changed easily here
my $TARGET = 0;
my @list = sort {$a <=> $b} @L;
my $length = scalar @L;
my @output;
for my $idx ( 0..$length - 2) {
## if a, the smallest value, is greater than the target value, no more
## solutions are possible and we are done
last if $list[$idx] > $TARGET;
## if a is a duplicate of the previous search, short-circuit to the next
## value
next if ($idx > 0 && $list[$idx] == $list[$idx-1]);
my $a = $list[$idx];
my $low = $idx + 1;
my $high = $length - 1;
while ( $low < $high ) {
## if b is a duplicate of the previous search, increment the index and
## short-circuit
if ($low > $idx+1 && $list[$low] == $list[$low-1]){
$low++;
next;
}
## if c is a duplicate of the previous search, decrement the index and
## short-circuit
if ($high < $length - 1 && $list[$high] == $list[$high+1]) {
$high--;
next;
}
my $b = $list[$low];
my $c = $list[$high];
## on success note to output, increment the start index and decrement
## the end so as not to duplicate searches
if ($a + $b + $c == $TARGET) {
push @output, [$a, $b, $c];
$low++;
$high--;
}
## if we are already above target shift the end element down and start
## again
elsif ($a + $b + $c > $TARGET) {
$high--;
}
## else try the next internal candidate
else {
$low++;
}
}
}
say join ', ', $_->@* for @output;
__DATA__
-9971, -9946, -9916, -9903, -9859, -9853, -9840, -9835, -9834, -9817
-9813, -9754, -9737, -9737, -9722, -9688, -9632, -9629, -9601, -9570
-9562, -9533, -9509, -9485, -9459, -9452, -9449, -9444, -9417, -9402
-9379, -9351, -9302, -9275, -9219, -9218, -9216, -9215, -9174, -9156
-9134, -9119, -9115, -9079, -9055, -9040, -9023, -8998, -8998, -8983
-8924, -8909, -8880, -8879, -8854, -8844, -8796, -8742, -8620, -8607
-8585, -8581, -8569, -8558, -8550, -8545, -8533, -8519, -8519, -8470
-8439, -8431, -8405, -8382, -8348, -8323, -8310, -8299, -8233, -8232
-8228, -8226, -8199, -8183, -8128, -8124, -8119, -8117, -8091, -8088
-8082, -8070, -8038, -8020, -8009, -8003, -7990, -7974, -7961, -7929
-7921, -7911, -7894, -7892, -7878, -7852, -7825, -7815, -7810, -7808
-7795, -7768, -7761, -7753, -7704, -7701, -7697, -7688, -7668, -7654
-7642, -7600, -7577, -7563, -7556, -7548, -7546, -7522, -7508, -7468
-7459, -7452, -7449, -7432, -7407, -7406, -7404, -7380, -7332, -7290
-7280, -7237, -7222, -7221, -7220, -7215, -7199, -7190, -7185, -7161
-7137, -7115, -7095, -7092, -7077, -7045, -7023, -7003, -6971, -6950
-6932, -6882, -6876, -6821, -6807, -6804, -6733, -6715, -6711, -6680
-6674, -6658, -6649, -6634, -6615, -6595, -6591, -6555, -6536, -6508
-6491, -6489, -6470, -6464, -6450, -6445, -6420, -6414, -6373, -6363
-6326, -6316, -6201, -6199, -6177, -6134, -6127, -6122, -6114, -6059
-6056, -6054, -6050, -6046, -6026, -6023, -6003, -6000, -5959, -5933
-5897, -5852, -5839, -5817, -5754, -5751, -5748, -5741, -5706, -5705
-5652, -5588, -5572, -5561, -5551, -5524, -5396, -5379, -5358, -5348
-5331, -5328, -5323, -5311, -5233, -5185, -5152, -5148, -5144, -5140
-5120, -5051, -5023, -5014, -5007, -4991, -4984, -4979, -4927, -4914
-4875, -4872, -4850, -4838, -4832, -4832, -4828, -4826, -4820, -4795
-4789, -4782, -4735, -4731, -4730, -4691, -4684, -4680, -4649, -4603
-4575, -4537, -4519, -4510, -4417, -4416, -4411, -4385, -4357, -4334
-4325, -4296, -4213, -4180, -4177, -4150, -4112, -4103, -4042, -4012
-3986, -3966, -3953, -3951, -3937, -3929, -3809, -3777, -3766, -3760
-3758, -3682, -3666, -3664, -3657, -3610, -3606, -3595, -3584, -3565
-3516, -3499, -3488, -3434, -3433, -3413, -3408, -3399, -3374, -3365
-3354, -3346, -3336, -3329, -3281, -3273, -3251, -3241, -3224, -3209
-3199, -3197, -3196, -3173, -3170, -3153, -3144, -3143, -3124, -3096
-3090, -3055, -3052, -3049, -2983, -2973, -2958, -2952, -2899, -2872
-2863, -2860, -2855, -2851, -2782, -2759, -2756, -2693, -2662, -2608
-2608, -2543, -2508, -2499, -2473, -2445, -2433, -2405, -2340, -2293
-2212, -2201, -2198, -2184, -2160, -2156, -2155, -2151, -2141, -2130
-2095, -2086, -2075, -2070, -2066, -2062, -2037, -2035, -2024, -2011
-1988, -1975, -1968, -1957, -1943, -1934, -1933, -1918, -1915, -1913
-1906, -1905, -1893, -1889, -1850, -1829, -1817, -1774, -1749, -1725
-1723, -1678, -1634, -1624, -1619, -1618, -1612, -1569, -1555, -1524
-1523, -1512, -1503, -1495, -1470, -1432, -1402, -1382, -1375, -1300
-1269, -1255, -1223, -1216, -1175, -1169, -1163, -1161, -1158, -1157
-1156, -1121, -1113, -1082, -1075, -1073, -1061, -1055, -1027, -992
-985, -984, -977, -925, -876, -863, -861, -842, -801, -737
-726, -686, -677, -670, -658, -657, -652, -646, -640, -616
-589, -584, -578, -565, -560, -549, -536, -506, -489, -486
-429, -404, -401, -392, -380, -352, -346, -310, -287, -286
-280, -240, -240, -201, -162, -162, -153, -135, -94, -77
-74, -58, -50, -43, 33, 64, 93, 99, 105, 107
136, 152, 159, 165, 176, 214, 230, 277, 290, 313
332, 382, 400, 404, 435, 438, 454, 463, 468, 468
472, 499, 512, 513, 542, 543, 590, 605, 613, 655
690, 702, 741, 763, 790, 796, 826, 840, 891, 909
919, 933, 936, 939, 1000, 1012, 1019, 1030, 1057, 1085
1089, 1101, 1106, 1114, 1115, 1132, 1156, 1179, 1184, 1196
1196, 1203, 1206, 1207, 1229, 1230, 1233, 1237, 1276, 1278
1291, 1303, 1344, 1344, 1373, 1466, 1470, 1526, 1527, 1534
1546, 1550, 1580, 1603, 1621, 1629, 1671, 1708, 1716, 1731
1738, 1742, 1765, 1766, 1779, 1840, 1856, 1870, 1871, 1891
1945, 1951, 1970, 2009, 2014, 2022, 2028, 2038, 2058, 2067
2085, 2105, 2110, 2113, 2117, 2138, 2155, 2168, 2179, 2183
2186, 2228, 2230, 2241, 2261, 2276, 2281, 2394, 2449, 2479
2479, 2482, 2486, 2487, 2501, 2517, 2618, 2668, 2683, 2688
2709, 2724, 2760, 2786, 2790, 2823, 2828, 2879, 2908, 2909
2922, 2947, 3010, 3019, 3045, 3087, 3097, 3162, 3250, 3311
3319, 3332, 3378, 3405, 3416, 3430, 3460, 3496, 3530, 3589
3659, 3661, 3704, 3716, 3725, 3726, 3734, 3771, 3773, 3785
3791, 3812, 3830, 3836, 3884, 3890, 3908, 3912, 3958, 3962
3979, 3985, 3987, 4028, 4033, 4035, 4061, 4062, 4128, 4136
4175, 4194, 4198, 4266, 4271, 4290, 4297, 4321, 4326, 4424
4470, 4489, 4506, 4552, 4559, 4583, 4667, 4715, 4730, 4781
4782, 4784, 4834, 4860, 4879, 4884, 4893, 4909, 4918, 4923
4941, 4993, 5062, 5079, 5106, 5121, 5131, 5160, 5167, 5178
5217, 5245, 5250, 5251, 5260, 5294, 5299, 5339, 5352, 5369
5371, 5376, 5383, 5385, 5402, 5417, 5451, 5472, 5475, 5484
5558, 5558, 5562, 5572, 5573, 5574, 5578, 5580, 5585, 5588
5592, 5631, 5638, 5700, 5702, 5727, 5750, 5772, 5814, 5842
5848, 5852, 5855, 5858, 5897, 5926, 5942, 5975, 5985, 5986
6037, 6050, 6095, 6123, 6130, 6147, 6167, 6183, 6192, 6204
6246, 6263, 6294, 6295, 6301, 6306, 6394, 6433, 6485, 6510
6514, 6516, 6532, 6585, 6623, 6634, 6635, 6661, 6671, 6685
6728, 6729, 6744, 6765, 6780, 6783, 6807, 6808, 6808, 6888
6889, 6914, 6988, 7035, 7040, 7079, 7080, 7087, 7104, 7152
7160, 7160, 7177, 7271, 7322, 7361, 7385, 7402, 7406, 7409
7426, 7428, 7454, 7465, 7470, 7502, 7512, 7627, 7642, 7686
7701, 7703, 7724, 7727, 7748, 7764, 7819, 7843, 7881, 7884
7915, 7932, 7974, 7983, 7988, 8004, 8025, 8032, 8044, 8064
8065, 8086, 8126, 8132, 8133, 8146, 8161, 8177, 8242, 8267
8291, 8344, 8390, 8401, 8416, 8435, 8443, 8449, 8521, 8524
8535, 8545, 8545, 8554, 8560, 8586, 8592, 8596, 8637, 8647
8651, 8675, 8681, 8693, 8714, 8718, 8724, 8740, 8770, 8779
8781, 8786, 8815, 8823, 8837, 8849, 8866, 8888, 8891, 8894
8950, 9007, 9009, 9011, 9034, 9085, 9094, 9117, 9125, 9154
9186, 9195, 9232, 9239, 9253, 9259, 9270, 9295, 9302, 9325
9325, 9326, 9329, 9340, 9369, 9396, 9424, 9455, 9457, 9479
9511, 9514, 9535, 9568, 9591, 9607, 9614, 9617, 9633, 9637
9667, 9681, 9703, 9735, 9737, 9741, 9774, 9774, 9775, 9784
9786, 9818, 9823, 9829, 9851, 9854, 9871, 9912, 9926, 9928
Raku Solution
With Raku, the logic can be implemented by switching on the results of the <=> operator, which returns “Less”, “Same”, or “More”. This can quite succinctly be accomplished using a given/when construct and specifying fall though behavior with proceed.
sub MAIN () {
my @L = -25, -10, -7, -3, 2, 4, 8, 10;
my $TARGET = 0;
my @list = @L.sort({$^a <=> $^b});
my $idx;
my @output;
for 0..@list.elems - 2 -> $idx {
## if a is greater than the target, no more solutions are possible so exit
last if @list[$idx] > $TARGET;
## increment the index until a contains a new value
next if ($idx > 0 && @list[$idx] == @list[$idx-1]);
my $a = @list[$idx];
my $low = $idx + 1;
my $high = @list.elems - 1;
while $low < $high {
## increment the index until b contains a new value
if ($low > $idx+1 && @list[$low] == @list[$low-1]) {
$low++;
next;
}
## increment the index until c contains a new value
if ($high < @list.elems - 1 && @list[$high] == @list[$high+1]) {
$high--;
next;
}
my $b = @list[$low];
my $c = @list[$high];
given $a + $b + $c <=> $TARGET {
when /Less|Same/ { $low++; proceed }
when /More|Same/ { $high--; proceed }
when /Same/ { @output.push: [$a, $b, $c]; }
}
}
}
say $_.list.join( ', ' ) for @output;
}TASK #2
Colourful Number
Write a script to display all Colorful Numbers with 3 digits.
“A number can be declared a Colorful Number when all the products of consecutive subsets of digits are different.”
For example, 263 is a Colorful Number since 2, 6, 3, 2×6, 6×3, 2x6x3 are unique.
Method
For this challenge, we’re structurally dealing with the values of individual digits that make up a three digit number and recombining them in different ways. We can extract these digits mathematically, but this being Perl it’s easy to treat the candidate number as a string and use split to extract the individual values all at once. Once we have the digits, the particular recombinations studied match a fixed set of variations, which can be enumerated as a list. Mapping this list to hash keys will overwrite duplicate keys, so if we have 6 keys, we have unique values, and the number is determined sufficiantly flashy to be declared colorful. At no point do we ever care as to what the values actually are, we only want to know whether they’re unique.
Perl Solution
[colincrain@boris:~/Code/PWC]$ perl 51_2_colorful.pl
234
235
237
238
239
243
245
246
247
249
253
254
256
257
...use warnings;
use strict;
use feature ":5.26";
## ## ## ## ## MAIN:
for (100..999) {
say $_ if colorful3($_);
}
## ## ## ## ## SUBS:
sub colorful3 {
my $number = shift;
my ($hundreds, $tens, $ones) = split //, $number;
my %products = map { $_ => 1 } ($hundreds, $tens, $ones, $hundreds * $tens,
$tens * $ones, $hundreds * $tens * $ones);
keys %products == 6 ? 1 : 0;
}
Raku Solution
In Raku when we treat the candidate number as a string and use comb to extract the individual chars into an array all at once. Once we have the digits, we can use .combinations(1..*) to make combinations length 1, 2 … whatever length, being the various subsets that can be created from the original set of digits. Applying the product reduction metaoperator to these lists (flattened with |) yields the products of various combinations in the criteria.
I originally used the hash key trick to determine whether the individual elements of the array are unique, a very Perlish way of going about things. There’s nothing wrong with that, but in Raku we have access to a .unique routine, which when given a list returns a Sequence of unique elements in that list. If we cast this to the Array type and compare it to the original Array with eqv, we can quite effectively determine uniqueness.
sub MAIN () {
for (100..999) {
my @products = $_.comb.combinations(1..*).map({[*] |$_});
.say if @products.unique.Array eqv @products;
}
}
Programming Excursions in Perl and Raku 