2 files changed, 128 insertions, 0 deletions
diff --git a/challenge-249/e-choroba/perl/ch-1.pl b/challenge-249/e-choroba/perl/ch-1.pl
new file mode 100755
index 0000000000..41f1d964ab
--- /dev/null
+++ b/challenge-249/e-choroba/perl/ch-1.pl
@@ -0,0 +1,75 @@
+#!/usr/bin/perl
+use warnings;
+use strict;
+use experimental qw( signatures );
+
+sub equal_pairs_count(@ints) {
+    my %seen;
+    ++$seen{$_} for @ints;
+    return [map $seen{$_} % 2 ? return []
+                              : ([$_, $_]) x ($seen{$_} / 2),
+            keys %seen]
+}
+
+sub equal_pairs_odd(@ints) {
+    my %odd;
+    my @pairs;
+    for my $i (@ints) {
+        if (exists $odd{$i}) {
+            delete $odd{$i};
+            push @pairs, [$i, $i];
+        } else {
+            undef $odd{$i};
+        }
+    }
+    return keys %odd ? [] : \@pairs
+}
+
+
+use Test2::V0 -srand => srand;
+plan 2 + 1;
+
+my $type = 'count';
+*equal_pairs = *equal_pairs_count{CODE};
+for (1, 2) {
+    subtest $type => sub {
+        plan 5;
+
+        is equal_pairs(3, 2, 3, 2, 2, 2),
+            bag { item $_ for [2, 2], [2, 2], [3, 3]; },
+            'Example 1';
+
+        is equal_pairs(1, 2, 3, 4), [], 'Example 2';
+
+
+        is equal_pairs(-1, -1, -2, -2),
+            bag { item $_ for [-1, -1], [-2, -2]; },
+            'Negative numbers';
+
+        is equal_pairs(1, 1, 1, 1, 2, 2, 2, 2),
+            bag { item $_ for [1, 1], [1, 1], [2, 2], [2, 2]; },
+            'More than once';
+
+        is equal_pairs(1, 1, 1, 1, 2, 2, 2, 2, 1),
+            [],
+            'More than once odd';
+    };
+
+    no warnings 'redefine';
+    $type = 'odd';
+    *equal_pairs = *equal_pairs_odd{CODE};
+}
+
+use Benchmark qw{ cmpthese };
+
+my @l = map int rand 1000, 1 .. 100_000;
+is equal_pairs_odd(@l), equal_pairs_count(@l), 'same';
+cmpthese(-3, {
+    odd   => sub { equal_pairs_odd(@l) },
+    count => sub { equal_pairs_count(@l) },
+});
+
+__END__
+        Rate   odd count
+odd   9.97/s    --  -82%
+count 55.5/s  456%    --
diff --git a/challenge-249/e-choroba/perl/ch-2.pl b/challenge-249/e-choroba/perl/ch-2.pl
new file mode 100755
index 0000000000..e498008452
--- /dev/null
+++ b/challenge-249/e-choroba/perl/ch-2.pl
@@ -0,0 +1,53 @@
+#!/usr/bin/perl
+use warnings;
+use strict;
+use feature qw{ say };
+
+use Test2::V0;
+use experimental qw( signatures );
+
+sub DI_string_match($str) {
+    my @p = (0);
+    my $max = 1;
+    my %DISPATCH = (I => sub {
+                        push @p, $max++;
+                    },
+                    D => sub {
+                        $_++ for @p, $max;
+                        push @p, 0;
+                    });
+    $DISPATCH{$_}() for split //, $str;
+    return \@p
+}
+
+{   my %DISPATCH = (D => sub($perm, $i) { $perm->[$i - 1] > $perm->[$i] },
+                    I => sub($perm, $i) { $perm->[$i - 1] < $perm->[$i] });
+    sub matches($s, $perm) {
+        return unless @$perm - 1 == length $s;
+        my %used;
+        @used{@$perm} = ();
+        exists $used{$_} or return for 0 .. length $s;
+
+        for my $i (1 .. length $s) {
+            my $char = substr $s, $i - 1, 1;
+            return unless $DISPATCH{$char}($perm, $i);
+        }
+        return 1
+    }
+}
+
+plan 3 + 5 + 3;
+
+is matches('IDID', [0, 4, 1, 3, 2]), 1, 'matches() correct for Example 1';
+is matches('III', [0, 1, 2, 3]), 1, 'matches() correct for Example 2';
+is matches('DDI', [3, 2, 0, 1]), 1, 'matches() correct for Example 3';
+
+is matches('I', [1, 0]), undef, 'matches() detects wrong order';
+is matches('D', [0, 1]), undef, 'matches() detects wrong order';
+is matches('I', [0, 2]), undef, 'matches() checks the range';
+is matches('III', [0, 1, 2]), undef, 'matches() rejects shorter';
+is matches('III', [0, 1, 2, 3, 4]), undef, 'matches() rejects longer';
+
+is matches('IDID', DI_string_match('IDID')), 1, 'Example 1';
+is matches('III', DI_string_match('III')), 1, 'Example 2';
+is matches('DDI', DI_string_match('DDI')), 1, 'Example 3';