Add Perl solution to challenge 018

4 files changed, 187 insertions, 0 deletions

diff --git a/challenge-018/paulo-custodio/README b/challenge-018/paulo-custodio/README
new file mode 100644
index 0000000000..87dc0b2fbd
--- /dev/null
+++ b/challenge-018/paulo-custodio/README
@@ -0,0 +1 @@
+Solution by Paulo Custodio
diff --git a/challenge-018/paulo-custodio/perl/ch-1.pl b/challenge-018/paulo-custodio/perl/ch-1.pl
new file mode 100644
index 0000000000..2108d0164c
--- /dev/null
+++ b/challenge-018/paulo-custodio/perl/ch-1.pl
@@ -0,0 +1,44 @@
+#!/usr/bin/env perl
+
+# Challenge 018
+#
+# Task #1
+# Write a script that takes 2 or more strings as command line parameters and
+# print the longest common substring. For example, the longest common substring
+# of the strings “ABABC”, “BABCA” and “ABCBA” is string “ABC” of length 3.
+# Other common substrings are “A”, “AB”, “B”, “BA”, “BC” and “C”. Please check
+# this wiki page for details.
+
+use strict;
+use warnings;
+use 5.030;
+use List::Util 'all';
+
+say "(", join(", ", map {$_=qq("$_")} longest_substr(@ARGV)), ")";
+
+
+sub longest_substr {
+	my(@strs) = @_;
+	my $longest_len = -1;
+	my %longest;
+	
+	for my $str (@strs) {									# each string
+		for my $s (0 .. length($str)-1) {					# each starting point
+			for my $len (reverse 1 .. length($str)-$s) {	# each substring of str
+				next if $longest_len > $len;				# prune search
+				my $substr = substr($str, $s, $len);
+				next if $longest{$str};						# prune search
+				if (all {/$substr/} @strs) {				# matches all
+					if ($longest_len == $len) {
+						$longest{$substr}=1;
+					}
+					else { # $longest_len < $len
+						%longest = ($substr=>1);
+						$longest_len = $len;
+					}
+				}
+			}
+		}
+	}
+	return sort keys %longest;
+}
diff --git a/challenge-018/paulo-custodio/perl/ch-2.pl b/challenge-018/paulo-custodio/perl/ch-2.pl
new file mode 100644
index 0000000000..dfd2e0a9fc
--- /dev/null
+++ b/challenge-018/paulo-custodio/perl/ch-2.pl
@@ -0,0 +1,117 @@
+#!/usr/bin/env perl
+
+# Challenge 018
+#
+# Task #2
+# Write a script to implement Priority Queue. It is like regular queue except
+# each element has a priority associated with it. In a priority queue, an
+# element with high priority is served before an element with low priority.
+# Please check this wiki page for more informations. It should serve the
+# following operations:
+# 
+# is_empty: check whether the queue has no elements.
+# insert_with_priority: add an element to the queue with an associated priority.
+# pull_highest_priority_element: remove the element from the queue that has the
+# highest priority, and return it. If two elements have the same priority, 
+# then return element added first.
+
+use strict;
+use warnings;
+use 5.030;
+
+# implement a Priority-queue as an ordered list of [priority, list of elements]
+{ 
+	package PQueue;
+	
+	sub new {
+		my($class) = @_;
+		return bless [], $class;
+	}
+	
+	sub is_empty {
+		my($self) = @_;
+		return @$self == 0;
+	}
+	
+	sub insert {
+		my($self, $pri, $elem) = @_;
+		if ($self->is_empty) {					# special case: empty
+			push @{$self}, [$pri, [$elem]];
+		}
+		elsif ($pri < $self->[0][0]) {			# special case: lowest
+			unshift @{$self}, [$pri, [$elem]];
+		}
+		elsif ($pri > $self->[-1][0]) {			# special case: highest
+			push @{$self}, [$pri, [$elem]];
+		}
+		else {
+			for my $i (0 .. $#{$self}) {		# traverse list, search for position
+				if ($self->[$i][0] == $pri) {	# same priority
+					push @{$self->[$i][1]}, $elem;
+					return;
+				}
+				elsif ($self->[$i][0] > $pri) {	# higher
+					splice @$self, $i, 0, [$pri, [$elem]];
+					return;
+				}
+			}
+			die "not reached";
+		}
+	}
+
+	sub pull {
+		my($self) = @_;
+		return if $self->is_empty;
+		my $elem = shift @{$self->[-1][1]};
+		if (@{$self->[-1][1]}==0) {				# bucket now empty
+			pop @$self;
+		}
+		return $elem;
+	}
+}
+
+use Test::More;
+my $q = PQueue->new;
+
+ok $q->is_empty, "is empty";
+ok !defined($q->pull), "pull from empty queue";
+
+# insert same priority
+$q->insert(1, 123);
+ok !$q->is_empty, "is not empty";
+
+$q->insert(1, 456);
+ok !$q->is_empty, "is not empty";
+
+$q->insert(1, 789);
+ok !$q->is_empty, "is not empty";
+
+# pull
+is $q->pull, 123, "got element";
+ok !$q->is_empty, "is not empty";
+
+is $q->pull, 456, "got element";
+ok !$q->is_empty, "is not empty";
+
+is $q->pull, 789, "got element";
+ok $q->is_empty, "is empty";
+
+# insert higher priority
+$q->insert(1, 123);
+$q->insert(1, 456);
+$q->insert(2, 23);
+$q->insert(3, 4);
+
+# insert lower priority
+$q->insert(0, 999);
+$q->insert(0, 998);
+
+is $q->pull, 4, "got element";
+is $q->pull, 23, "got element";
+is $q->pull, 123, "got element";
+is $q->pull, 456, "got element";
+is $q->pull, 999, "got element";
+is $q->pull, 998, "got element";
+ok $q->is_empty, "is empty";
+
+done_testing;
diff --git a/challenge-018/paulo-custodio/test.pl b/challenge-018/paulo-custodio/test.pl
new file mode 100644
index 0000000000..9eff0e95ef
--- /dev/null
+++ b/challenge-018/paulo-custodio/test.pl
@@ -0,0 +1,25 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More;
+use 5.030;
+
+is capture("perl perl/ch-1.pl ABABC BABCA ABCBA"), <<END;
+("ABC")
+END
+
+is capture("perl perl/ch-1.pl ABABCBA BABCACBA ABCBCBA"), <<END;
+("ABC", "CBA")
+END
+
+ok 0==system("perl perl/ch-2.pl");
+
+done_testing;
+
+sub capture {
+	my($cmd) = @_;
+	my $out = `$cmd`;
+	$out =~ s/[ \t\v\f\r]*\n/\n/g;
+	return $out;
+}