Multiple Perl solutions for week 140, part 2

3 files changed, 147 insertions, 78 deletions

diff --git a/challenge-140/abigail/perl/ch-2.pl b/challenge-140/abigail/perl/ch-2.pl
index b391a00101..91d052e4e5 100644
--- a/challenge-140/abigail/perl/ch-2.pl
+++ b/challenge-140/abigail/perl/ch-2.pl
@@ -18,89 +18,28 @@ use experimental 'lexical_subs';
 #
 
 #
-# A trivial way to solve this is to calculate all numbers
-# m = p * q, 1 <= p <= i, 1 <= q <= j, sort them, and select
-# the kth number from the sorted list.
+# We consider all numbers, starting from 1. For each number $n, we will
+# count how many times it occurs in the multiplication table. This
+# is exactly the numbers of divisor $d, such that $d <= $i and $n / $d <= $j.
+# Then it's just a matter of bookkeepping till we have found the right
+# solution.
 #
-# This takes O (i * j * log (i * j)) time, using O (i * j) memory.
-# Which, for the trivial examples of the challenge is peanuts.
-# But if i and j are large, say 1,000,000, this becomes a problem.
+# Math::Prime::Util has a utility function, fordivisors, which iterates
+# over the divisors of a given number.
 #
-# An alternative way would be scan the table in order, only generating
-# as many numbers are needed:
+# We also have two different solutions:
 #
-#  * Assume i <= j (else, just swap i and j)
+# A naive one, which calculates all numbers p = n * m, 1 <= n <= i, 1 <= m <= j,
+# sorts the list, then selects the nth element. This is on ch-2b.pl.
 #
-#  * Create i pairs. Initialize each pair P_n as [n, 1], 1 <= n <= i.
-#    Each pair corresponds to the column in the multiplication table.
-#    Since the values in a column are sorted, we only need to keep
-#    track of the highest element we haven't descarded yet.
-#  * Store each pair in a heap, ordered on P_n [0] * P_n [1], such
-#    that the pair with the smallest product is on top.
-#  * Let c = 0; while c < k:
-#        + Let Q be the pair on top of the heap.
-#        + Q [1] = Q [1] >= j ? Q [i * j + 1] : Q [1] + 1   [*]
-#        + Restore the heap
-#  * If c == k, then the wanted number is product of the pair at
-#    the top of the heap.
-#
-# [*] If Q [1] >= j, we have reached the bottom of the column, so the
-#     answer we're seeking cannot be in this column. By setting Q [1]
-#     to i * j + 1, it will be larger than the answer we're looking for,
-#     and we'll never consult this column again.
-#
-#  Building the heap is O (i) (trivial in this case, as we can generate
-#  the elements in a sorted way). Restoring the heap takes O (log (i)).
-#  Hence, the total running time is O (i + k * log (i)), using O (i)
-#  memory. 
+# One which goes through the multiplication table in order, avoiding
+# finding divisors of numbers. This is in ch-2a.pl.
 #
 
+use Math::Prime::Util qw [fordivisors];
 
-sub prod  ($pair)  {$$pair [0] * $$pair [1]}
-sub left  ($index) {2 * $index + 1}
-sub right ($index) {2 * $index + 2}
-
-sub make_heap ($i) {[map {[$_, 1]} 1 .. $i]}
-sub rebalance ($heap, $index = 0) {
-    my $index1 = left  $index;    # Left  child
-    my $index2 = right $index;    # Right child
-    return if $index1 > $#$heap;  # No children, so we're done.
-    my $p = prod $$heap [$index];
-    #
-    # Find the smallest of the children
-    #
-    my $p1 = prod $$heap [$index1];
-    if ($index2 <= $#$heap) {
-        my $p2 = prod $$heap [$index2];
-        #
-        # Right child is smaller than left child, so right child wins
-        #
-        if ($p2 < $p1) {
-            $p1 = $p2;
-            $index1 = $index2;
-        }
-    }
-    #
-    # Now, $p1 is the smallest child, and on index $index1.
-    # If the smallest child is smaller than the current element,
-    # swap, and recurse. Else, we're done.
-    #
-    if ($p1 < $p) {
-        @$heap [$index, $index1] = @$heap [$index1, $index];
-        rebalance ($heap, $index1);
-    }
+MAIN: while (<>) {
+    my ($n, $i, $j, $k) = (0, split);
+    fordivisors {$_ <= $i && $n / $_ <= $j && !-- $k && say $n} ++ $n
+           while $k >= 1;
 }
-
-
-while (<>) {
-    my ($i, $j, $k) = split;
-    ($j, $i) = ($i, $j) if $j < $i;
-    my $heap = make_heap ($i);
-    while ($k -- > 1) {
-        $$heap [0] [1] = $$heap [0] [1] >= $j ? $i * $j + 1
-                                              : $$heap [0] [1] + 1;
-        rebalance ($heap);
-    }
-    say prod $$heap [0];
-}
-
diff --git a/challenge-140/abigail/perl/ch-2a.pl b/challenge-140/abigail/perl/ch-2a.pl
new file mode 100644
index 0000000000..bc3ef6f151
--- /dev/null
+++ b/challenge-140/abigail/perl/ch-2a.pl
@@ -0,0 +1,98 @@
+#!/opt/perl/bin/perl
+
+use 5.032;
+
+use strict;
+use warnings;
+no  warnings 'syntax';
+
+use experimental 'signatures';
+use experimental 'lexical_subs';
+
+#
+# See https://theweeklychallenge.org/blog/perl-weekly-challenge-140/#TASK2
+#
+
+#
+# Run as: perl ch-2a.pl < input-file
+#
+
+#
+# This solution scans the multiplication table in order, only generating
+# as many numbers are needed:
+#
+#  * Assume i <= j (else, just swap i and j)
+#
+#  * Create i pairs. Initialize each pair P_n as [n, 1], 1 <= n <= i.
+#    Each pair corresponds to the column in the multiplication table.
+#    Since the values in a column are sorted, we only need to keep
+#    track of the highest element we haven't descarded yet.
+#  * Store each pair in a heap, ordered on P_n [0] * P_n [1], such
+#    that the pair with the smallest product is on top.
+#  * Let c = 0; while c < k:
+#        + Let Q be the pair on top of the heap.
+#        + Q [1] = Q [1] >= j ? Q [i * j + 1] : Q [1] + 1   [*]
+#        + Restore the heap
+#  * If c == k, then the wanted number is product of the pair at
+#    the top of the heap.
+#
+# [*] If Q [1] >= j, we have reached the bottom of the column, so the
+#     answer we're seeking cannot be in this column. By setting Q [1]
+#     to i * j + 1, it will be larger than the answer we're looking for,
+#     and we'll never consult this column again.
+#
+#  Building the heap is O (i) (trivial in this case, as we can generate
+#  the elements in a sorted way). Restoring the heap takes O (log (i)).
+#  Hence, the total running time is O (i + k * log (i)), using O (i)
+#  memory. 
+#
+
+
+sub prod  ($pair)  {$$pair [0] * $$pair [1]}
+sub left  ($index) {2 * $index + 1}
+sub right ($index) {2 * $index + 2}
+
+sub make_heap ($i) {[map {[$_, 1]} 1 .. $i]}
+sub rebalance ($heap, $index = 0) {
+    my $index1 = left  $index;    # Left  child
+    my $index2 = right $index;    # Right child
+    return if $index1 > $#$heap;  # No children, so we're done.
+    my $p = prod $$heap [$index];
+    #
+    # Find the smallest of the children
+    #
+    my $p1 = prod $$heap [$index1];
+    if ($index2 <= $#$heap) {
+        my $p2 = prod $$heap [$index2];
+        #
+        # Right child is smaller than left child, so right child wins
+        #
+        if ($p2 < $p1) {
+            $p1 = $p2;
+            $index1 = $index2;
+        }
+    }
+    #
+    # Now, $p1 is the smallest child, and on index $index1.
+    # If the smallest child is smaller than the current element,
+    # swap, and recurse. Else, we're done.
+    #
+    if ($p1 < $p) {
+        @$heap [$index, $index1] = @$heap [$index1, $index];
+        rebalance ($heap, $index1);
+    }
+}
+
+
+while (<>) {
+    my ($i, $j, $k) = split;
+    ($j, $i) = ($i, $j) if $j < $i;
+    my $heap = make_heap ($i);
+    while ($k -- > 1) {
+        $$heap [0] [1] = $$heap [0] [1] >= $j ? $i * $j + 1
+                                              : $$heap [0] [1] + 1;
+        rebalance ($heap);
+    }
+    say prod $$heap [0];
+}
+
diff --git a/challenge-140/abigail/perl/ch-2b.pl b/challenge-140/abigail/perl/ch-2b.pl
new file mode 100644
index 0000000000..c85a59dd4c
--- /dev/null
+++ b/challenge-140/abigail/perl/ch-2b.pl
@@ -0,0 +1,32 @@
+#!/opt/perl/bin/perl
+
+use 5.032;
+
+use strict;
+use warnings;
+no  warnings 'syntax';
+
+use experimental 'signatures';
+use experimental 'lexical_subs';
+
+#
+# See https://theweeklychallenge.org/blog/perl-weekly-challenge-140/#TASK2
+#
+
+#
+# Run as: perl ch-2b.pl < input-file
+#
+
+#
+# Trivial solution. Will easily out of memory.
+#
+# We'll calculate all number n * m, 1 <= n <= i, 1 <= m <= j, sort them,
+# and then take the kth element.
+#
+
+while (<>) {
+    my ($i, $j, $k) = split;
+    say +(sort {$a <=> $b} map {my $l = $_; map {$_ * $l} 1 .. $j} 1 .. $i)
+         [$k - 1];
+}
+