2 files changed, 47 insertions, 1 deletions
diff --git a/challenge-174/wlmb/perl/ch-1.pl b/challenge-174/wlmb/perl/ch-1.pl
index dc84347487..40d5c333bc 100755
--- a/challenge-174/wlmb/perl/ch-1.pl
+++ b/challenge-174/wlmb/perl/ch-1.pl
@@ -1,6 +1,6 @@
 #!/usr/bin/env perl
 # Perl weekly challenge 174
-# Task 1: Disarium numbers
+# Task 1: Disarium numbers. Brute force
 #
 # See https://wlmb.github.io/2022/07/18/PWC174/#task-1-disarium-numbers
 use v5.12;
diff --git a/challenge-174/wlmb/perl/ch-1a.pl b/challenge-174/wlmb/perl/ch-1a.pl
new file mode 100755
index 0000000000..f5d87f47c9
--- /dev/null
+++ b/challenge-174/wlmb/perl/ch-1a.pl
@@ -0,0 +1,46 @@
+#!/usr/bin/env perl
+# Perl weekly challenge 174
+# Task 1: Disarium numbers. Not so brute force
+#
+# See https://wlmb.github.io/2022/07/18/PWC174/#task-1-disarium-numbers
+use v5.36;
+use List::Util qw(sum min);
+use Memoize;
+memoize "power";
+die "Usage: $0 N\nto obtain the first N Disarium numbers\n" unless @ARGV;
+my $want=shift;
+die "There are not that many Disarium numbers\n" if $want > 20;
+die "We are not that patient today\n" if $want==20;
+my $count=1;
+say $count++, ": $_" for(0..min 9, $want);
+for my $N(2..20){ # for each possible length
+    search($N, $N, "", 0, 0);
+}
+sub search ($N, $M, $rightmost, $p_old, $d_old){
+    --$M;
+    my $minmin=power(10,$M-1);
+    for my $right(0..9){ # for each possible rightmost digit
+        last if $count > $want;
+        my $p_new=power($right, $M+1)+$p_old;
+        my $d_new=$right*power(10, $N-$M-1)+$d_old;
+        my $min=($p_new-$d_new+1)/power(10, $N-$M);
+        my $max=($p_new-$d_new+(power(9,$M+1)-9)/8)/power(10, $N-$M);
+        $min=$minmin if $min<$minmin;
+        next if $max<=$min;
+        my $newright="$right$rightmost";
+	if($max-$min < 10){
+	    for($min..$max){
+                my $candidate="$_$newright";
+                say $count++, ": $candidate" if disarium($candidate);
+            }
+        } else {
+            search($N, $M, $newright, $p_new, $d_new);
+        }
+    }
+}
+sub power($x, $y){ $x**$y }
+sub disarium($candidate){
+    my @digits=split "", $candidate;
+    my $powersum=sum map {$digits[$_-1]**$_} (1..@digits);
+    return $powersum==$candidate;
+}