Merge pull request #4814 from choroba/ech127

Solve 127: Disjoint Sets & Conflict Intervals by E. Choroba

2 files changed, 174 insertions, 0 deletions

diff --git a/challenge-127/e-choroba/perl/ch-1.pl b/challenge-127/e-choroba/perl/ch-1.pl
new file mode 100755
index 0000000000..e6661175ff
--- /dev/null
+++ b/challenge-127/e-choroba/perl/ch-1.pl
@@ -0,0 +1,19 @@
+#!/usr/bin/perl
+use warnings;
+use strict;
+
+sub disjoint_sets {
+    my ($s1, $s2) = @_;
+    my %set;
+    @set{@$s1} = ();
+    delete @set{@$s2};
+
+    # Check that nothing was removed, i.e. the number of keys stays the same.
+    return (@$s1 == keys %set) ? 1 : 0
+}
+
+use Test2::V0;
+plan 2;
+
+is disjoint_sets([1, 2, 5, 3, 4], [4, 6, 7, 8, 9]), 0, 'Example 1';
+is disjoint_sets([1, 3, 5, 7, 9], [0, 2, 4, 6, 8]), 1, 'Example 2';
diff --git a/challenge-127/e-choroba/perl/ch-2.pl b/challenge-127/e-choroba/perl/ch-2.pl
new file mode 100755
index 0000000000..15fb9cb97b
--- /dev/null
+++ b/challenge-127/e-choroba/perl/ch-2.pl
@@ -0,0 +1,155 @@
+#!/usr/bin/perl
+use warnings;
+use strict;
+use feature qw{ say };
+
+{   package Interval::Conflict::Naive;
+
+    sub new { bless [], shift }
+
+    sub add {
+        my ($self, $interval) = @_;
+        @$self = sort { $a <=> $b } @$self, @$interval;
+    }
+
+    sub is_conflicting {
+        my ($self, $interval) = @_;
+        for my $i (0 .. $#$self) {
+            return 1
+                if $interval->[0] <= $self->[$i]
+                && $self->[$i] <= $interval->[1];
+
+            my ($start, $edge) = @{ ([$i, 0], [$i - 1, 1])[$i % 2] };
+            return 1
+                if $self->[$start] <= $interval->[$edge]
+                && $interval->[$edge] <= $self->[ $start + 1 ];
+        }
+        return 0
+    }
+}
+
+{   package Interval::Conflict::Binary;
+    use parent -norequire => 'Interval::Conflict::Naive';
+
+    sub add {
+        my ($self, $interval) = @_;
+        my $i = $self->_locate($interval->[0]);
+        splice @$self, $i, 0, @$interval;
+    }
+
+    sub is_conflicting {
+        my ($self, $interval) = @_;
+        my $i = $self->_locate($interval->[0]);
+        return 0 if $i > $#$self;
+
+        $i -= $i % 2;
+        return 1
+            if $interval->[0] <= $self->[$i]
+            && $self->[$i] <= $interval->[1];
+
+        my ($start, $edge) = @{ ([$i, 0], [$i - 1, 1])[$i % 2] };
+        return 1
+            if $self->[$start] <= $interval->[$edge]
+            && $interval->[$edge] <= $self->[ $start + 1 ];
+
+        return 0
+    }
+
+    sub _locate {
+        my ($self, $value) = @_;
+
+        my ($from, $to) = (0, $#$self);
+        while ($to - $from > 1) {
+            my $middle = int(($from + $to) / 2);
+            if ($value < $self->[$middle]) {
+                $to = $middle;
+            } else {
+                $from = $middle;
+            }
+        }
+
+        my $r;
+        if (@$self && $value <= $self->[$from]) {
+            $r = $from;
+        } else {
+            $r = $to < 0 ? 0
+                         : $to + ($self->[-1] < $value);
+        }
+
+        return $r
+    }
+}
+
+sub conflict_intervals {
+    my ($class, @intervals) = @_;
+    my $il = $class->new;
+    my @conflicts;
+    for my $interval (@intervals) {
+        if ($il->is_conflicting($interval)) {
+            push @conflicts, $interval;
+        } else {
+            $il->add($interval);
+        }
+    }
+    return \@conflicts
+}
+
+use Test2::V0;
+plan 3;
+
+my $class;
+sub test {
+    conflict_intervals($class, @_);
+}
+
+for my $c ('Interval::Conflict::Naive',
+           'Interval::Conflict::Binary',
+) {
+    subtest $c => sub {
+        plan 7;
+        $class = $c;
+
+        is test([1, 4], [3, 5], [6, 8], [12, 13], [3, 20]),
+            [[3, 5], [3, 20]],
+            'Example 1';
+
+        is test([3, 4], [5, 7], [6, 9], [10, 12], [13, 15]),
+            [[6, 9]],
+            'Example 2';
+
+        is test([10, 12], [1, 3], [8, 11], [2, 4],
+                [2, 11], [0, 1], [12, 14], [4, 9], [0, 15]),
+                    [[8, 11], [2, 4], [2, 11], [0, 1], [12, 14], [0, 15]],
+                    'Cover all';
+
+        is test([2, 4], [6, 8], [10, 12], [14, 16], [5, 13]),
+            [[5, 13]],
+            'Cover some';
+
+        is test([2, 4], [1, 5]),
+            [[1, 5]],
+            'Cover single';
+
+        is test([2, 5], [3, 4]),
+            [[3, 4]],
+            'Inside';
+
+        is test([2, 5], [2, 5], [6, 8], [6, 7], [9, 11], [10, 11]),
+            [[2, 5], [6, 7], [10, 11]],
+            'Exact';
+    };
+}
+
+use Benchmark qw{ cmpthese };
+
+say {*STDERR} 'seed ', srand($$ + time);
+my @L = map { my $x = int rand 1000; [$x, $x + 1 + int rand 10] } 1 .. 2000;
+
+is conflict_intervals('Interval::Conflict::Naive', @L),
+    conflict_intervals('Interval::Conflict::Binary', @L),
+    "naive same as binary";
+
+cmpthese(-3, {
+    naive  => sub { conflict_intervals('Interval::Conflict::Naive', @L) },
+    binary => sub { conflict_intervals('Interval::Conflict::Binary', @L) },
+});