2 files changed, 90 insertions, 0 deletions
diff --git a/challenge-147/e-choroba/perl/ch-1.pl b/challenge-147/e-choroba/perl/ch-1.pl
new file mode 100755
index 0000000000..699dec8487
--- /dev/null
+++ b/challenge-147/e-choroba/perl/ch-1.pl
@@ -0,0 +1,58 @@
+#!/usr/bin/perl
+use warnings;
+use strict;
+use feature qw{ say };
+
+use constant SIZE => 20;
+
+my @primes = (2, 3);
+my %primes;
+@primes{@primes} = ();
+sub add_primes {
+    my ($top) = @_;
+  CANDIDATE:
+    for (my $candidate = $primes[-1] + 2;
+         $candidate <= $top;
+         $candidate += 2
+    ) {
+        for my $prime (@primes) {
+            next CANDIDATE if 0 == $candidate % $prime;
+            last if $prime * $prime > $candidate;
+        }
+        push @primes, $candidate;
+        undef $primes{$candidate};
+    }
+}
+
+sub left_truncatable_primes {
+    my ($should_include_single_digit) = @_;
+    my $candidate = $should_include_single_digit ? 2 : 11;
+    my $step = $candidate % 2 + 1;
+
+    my @left_truncatable;
+  CANDIDATE:
+    while (@left_truncatable < SIZE) {
+        add_primes($candidate);
+        if (exists $primes{$candidate}) {
+            next CANDIDATE unless -1 == index $candidate, '0';
+
+            for my $l (1 .. length($candidate) - 1) {
+                next CANDIDATE unless exists $primes{substr $candidate, $l}
+            }
+            push @left_truncatable, $candidate;
+        }
+    } continue {
+        $candidate += $step;
+        $step = 2;
+    }
+    return @left_truncatable
+}
+
+for my $include_single_digit (1, 0) {
+    my @left_truncatable = left_truncatable_primes($include_single_digit);
+
+    # Wikipedia includes single digit primes, Project Euler excludes them.
+    say +("don't ", "")[$include_single_digit], 'include single digit: ';
+
+    say join ', ', @left_truncatable;
+}
diff --git a/challenge-147/e-choroba/perl/ch-2.pl b/challenge-147/e-choroba/perl/ch-2.pl
new file mode 100755
index 0000000000..b1db853039
--- /dev/null
+++ b/challenge-147/e-choroba/perl/ch-2.pl
@@ -0,0 +1,32 @@
+#!/usr/bin/perl
+use warnings;
+use strict;
+use feature qw{ say };
+
+my @pentagon_numbers;
+my %pentagon_numbers;
+{   my $last = 0;
+    sub add_pentagon_number {
+        ++$last;
+        push @pentagon_numbers, $last * (3 * $last - 1) / 2;
+        undef $pentagon_numbers{ $pentagon_numbers[-1] };
+        return $pentagon_numbers[-1]
+    }
+}
+
+sub pentagon_numbers {
+    while (1) {
+        my $sum = add_pentagon_number();
+        for my $p1 (@pentagon_numbers) {
+            last if $p1 * 2 > $sum;
+
+            my $p2 = $sum - $p1;
+            next unless exists $pentagon_numbers{$p2}
+                     && exists $pentagon_numbers{$p2 - $p1};
+
+            return $p1, $p2
+        }
+    }
+}
+
+say join ' ', pentagon_numbers();