2 files changed, 96 insertions, 0 deletions
diff --git a/challenge-143/wlmb/perl/ch-1.pl b/challenge-143/wlmb/perl/ch-1.pl
new file mode 100755
index 0000000000..80c20d3932
--- /dev/null
+++ b/challenge-143/wlmb/perl/ch-1.pl
@@ -0,0 +1,73 @@
+#!/usr/bin/env perl
+# Perl weekly challenge 143
+# Task 1: calculator
+#
+# See https://wlmb.github.io/2021/12/13/PWC143/#task-1-calculator
+use v5.12;
+use warnings;
+use Scalar::Util qw(looks_like_number);
+use Try::Tiny;
+my $original_string;
+my $previous;
+my $current;
+my $token;
+foreach (@ARGV){
+    try {
+        $original_string=$previous=$current=$_;
+        token();
+        my $result=expression();
+        die "Extra characters: $previous\n" if defined $token->[0];
+        say "$original_string=$result";
+    }
+    catch {
+        warn $_;
+    };
+}
+
+sub token {
+    $previous=$current;
+    $token=[$1,$1], return if $current=~s{^\s*([()*/+-])}{}; # symbol
+    $token=['N',$1], return
+        if $current=~s{^\s*([^()*/+\-\t\n ]*)}{}
+           and looks_like_number($1); # number?
+    $token=[undef,undef], return if $current=~/^\s*$/; # nothing
+    die "Unrecognizable input: $previous\n";
+}
+
+sub expression {
+    my $result=term();
+    while(1){
+        my $op=$token->[0];
+        last unless defined $op && $op=~m{[+-]};
+        token();
+        $result+=term(),next if $op eq '+';
+        $result-=term(),next if $op eq '-';
+    }
+    return $result;
+}
+
+sub term {
+    my $result=simple();
+    while(1){
+        my $op=$token->[0];
+        last unless defined $op && $op=~m{[*/]};
+        token();
+        $result*=simple(),next if $op eq '*';
+        $result/=simple(),next if $op eq '/';
+    }
+    return $result;
+}
+sub simple {
+    my $op=$token->[0];
+    my $val=$token->[1];
+    die "Unrecognized expression: $previous\n" unless defined $op && $op=~/[-+(N]/;
+    token();
+    return -simple() if $op eq '-'; # unary -
+    return simple() if $op eq '+';  # unary +
+    return $val if $op eq 'N';      # number
+    my $result=expression();        # parenthesized expression
+    $op=$token->[0];                # closing parenthesis should follow
+    die "Unbalanced parenthesis: $previous\n" unless defined $op and $op eq ')';
+    token();
+    return $result;
+}
diff --git a/challenge-143/wlmb/perl/ch-2.pl b/challenge-143/wlmb/perl/ch-2.pl
new file mode 100755
index 0000000000..f1deb04daa
--- /dev/null
+++ b/challenge-143/wlmb/perl/ch-2.pl
@@ -0,0 +1,23 @@
+#!/usr/bin/env perl
+# Perl weekly challenge 143
+# Task 1: Stealthy number
+#
+# See https://wlmb.github.io/2021/12/13/PWC143/#task-2-stealthy-number
+use v5.12;
+use warnings;
+use PDL;
+use PDL::NiceSlice;
+foreach my $N(@ARGV){
+    my $Q=sqrt($N); # largest possible small divisor
+    my $s=(sequence($Q)+1);
+    my $d=$s->where($N % $s == 0); # list of divisors<=$Q
+    my $c=$d->cat($d(*)); # cartesian product of divisors
+    my $mask=$d+$N/$d==($d+$N/$d+1)->(*);
+    # Get pairs of divisors that obey the stealthy condition
+    my $d2=$c->whereND(($d+$N/$d)==($d+$N/$d+1)->(*));
+    my $out=$d2->nelem?1:0;
+    say "\nInput: $N Output: ", $out;
+    say "since ", $_((0)),"+",$N/$_((0)),
+        "==",$_((1)),"+",$N/$_((1)),"+1"
+        foreach $d2->transpose->dog;
+}