Merge pull request #431 from PerlMonk-Athanasius/branch-for-challenge-018

Perl 5 & 6 solutions to Tasks 1 & 2 of Challenge #018

6 files changed, 526 insertions, 0 deletions

diff --git a/challenge-018/athanasius/perl5/MyPriorityQueue.pm b/challenge-018/athanasius/perl5/MyPriorityQueue.pm
new file mode 100644
index 0000000000..d3c1d77f7f
--- /dev/null
+++ b/challenge-018/athanasius/perl5/MyPriorityQueue.pm
@@ -0,0 +1,80 @@
+#!perl
+
+################################################################################
+=comment
+
+Perl Weekly 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 [ https://en.wikipedia.org/wiki/Priority_queue |wiki page] for more
+informations. It should serve the following operations:
+
+  1) *is_empty*: check whether the queue has no elements.
+
+  2) *insert_with_priority*: add an element to the queue with an associated
+      priority.
+
+  3) *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.
+
+=cut
+################################################################################
+
+#--------------------------------------#
+# Copyright © 2019 PerlMonk Athanasius #
+#--------------------------------------#
+
+package MyPriorityQueue;
+
+use strict;
+use warnings;
+use List::Priority;
+
+sub new
+{
+    my ($class, $reverse) = @_;
+
+    my $self =
+       {
+           implementation   => List::Priority->new,
+           reverse_priority => $reverse // 0,
+       };
+
+    return bless $self, $class;
+}
+
+sub is_empty
+{
+    my ($self) = @_;
+
+    return $self->{implementation}->size == 0;
+}
+
+sub insert_with_priority
+{
+    my ($self, $priority, $scalar) = @_;
+
+    my  $result = $self->{implementation}->insert($priority, $scalar);
+
+    $result eq '1' or die $result;
+}
+
+sub pull_highest_priority_element
+{
+    my ($self) = @_;
+
+    # If the queue is empty, undef will be returned
+
+    return $self->{reverse_priority} ? $self->{implementation}->shift :
+                                       $self->{implementation}->pop;
+}
+
+################################################################################
+1;
+################################################################################
diff --git a/challenge-018/athanasius/perl5/ch-1.pl b/challenge-018/athanasius/perl5/ch-1.pl
new file mode 100644
index 0000000000..2b8333e160
--- /dev/null
+++ b/challenge-018/athanasius/perl5/ch-1.pl
@@ -0,0 +1,99 @@
+#!perl
+
+################################################################################
+=comment
+
+Perl Weekly 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
+[ https://en.wikipedia.org/wiki/Longest_common_substring_problem |wiki page] for
+details.
+
+=cut
+################################################################################
+
+#--------------------------------------#
+# Copyright © 2019 PerlMonk Athanasius #
+#--------------------------------------#
+
+use strict;
+use warnings;
+use Const::Fast;
+use Set::Scalar;
+
+const my $USAGE => "\nUSAGE: perl $0 <string-1> <string-2> [ <string-3..n> ]\n";
+
+MAIN:
+{
+    @ARGV >= 2 or die $USAGE;
+
+    my   @sets;
+    push @sets, get_substrings($_) for (@ARGV);
+
+    # The set of common substrings is the intersection of all the substring sets
+
+    my $common_substrings = $sets[0];
+       $common_substrings = $common_substrings * $sets[$_] for 1 .. $#sets;
+
+    if ($common_substrings->is_empty)
+    {
+        print  "\nNo common substrings found\n";
+    }
+    elsif (scalar (my @solutions = get_solutions($common_substrings)) == 1)
+    {
+        printf "\nThe longest common substring is: \"%s\"\n", $solutions[0];
+    }
+    else
+    {
+        printf "\nThe %d longest common substrings are: %s\n",
+                scalar @solutions, join(', ', map { qq["$_"] } sort @solutions);
+    }
+}
+
+sub get_substrings
+{
+    my ($string)    = @_;
+    my  $substrings = Set::Scalar->new;
+    my  $max_index  = length($string) - 1;
+
+    for my $start_index (0 .. $max_index)
+    {
+        for my $length (1 .. $max_index - $start_index + 1)
+        {
+            $substrings->insert(substr $string, $start_index, $length);
+        }
+    }
+
+    return $substrings;
+}
+
+sub get_solutions
+{
+    my ($substrings) = @_;
+    my  @sorted      = sort { length $b <=> length $a } $substrings->elements;
+    my  @solutions   = shift  @sorted;
+    my  $max_length  = length $solutions[0];
+
+    while (my $element = shift @sorted)
+    {
+        if (length($element) == $max_length)
+        {
+            push @solutions, $element;
+        }
+        else
+        {
+            last;
+        }
+    }
+
+    return @solutions;
+}
+
+################################################################################
diff --git a/challenge-018/athanasius/perl5/ch-2.pl b/challenge-018/athanasius/perl5/ch-2.pl
new file mode 100644
index 0000000000..48b1d9e0b5
--- /dev/null
+++ b/challenge-018/athanasius/perl5/ch-2.pl
@@ -0,0 +1,88 @@
+#!perl
+
+################################################################################
+=comment
+
+Perl Weekly 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 [ https://en.wikipedia.org/wiki/Priority_queue |wiki page] for more
+informations. It should serve the following operations:
+
+  1) *is_empty*: check whether the queue has no elements.
+
+  2) *insert_with_priority*: add an element to the queue with an associated
+      priority.
+
+  3) *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.
+
+=cut
+################################################################################
+
+#--------------------------------------#
+# Copyright © 2019 PerlMonk Athanasius #
+#--------------------------------------#
+
+use strict;
+use warnings;
+use lib qw( . );
+use MyPriorityQueue;
+
+MAIN:
+{
+    print "\n";
+
+    # (1) Larger number = higher priority
+
+    my $pq = MyPriorityQueue->new;
+       $pq->insert_with_priority( 4, 'over');
+       $pq->insert_with_priority( 8, 'quick');
+       $pq->insert_with_priority(12, 'REMOVE');
+       $pq->insert_with_priority( 5, 'jumped');
+       $pq->insert_with_priority( 0, '--Snoopy');
+       $pq->insert_with_priority( 3, 'the');
+       $pq->insert_with_priority( 7, 'brown');
+       $pq->insert_with_priority( 2, 'unfortunate');
+       $pq->insert_with_priority(11, 'The');
+       $pq->pull_highest_priority_element;
+       $pq->insert_with_priority( 1, 'dog.');
+       $pq->insert_with_priority( 7, 'fox');
+
+    extract_and_display($pq);
+
+    # (2) Lower number = higher priority
+
+       $pq = MyPriorityQueue->new(1);
+       $pq->insert_with_priority(-1, 'more');
+       $pq->insert_with_priority( 2, 'way');
+       $pq->insert_with_priority( 6, '--Perl');
+       $pq->insert_with_priority( 0, 'than');
+       $pq->insert_with_priority( 5, 'it.');
+       $pq->insert_with_priority(-2, 'REMOVE');
+       $pq->insert_with_priority( 2, 'to');
+       $pq->insert_with_priority( 1, 'one');
+       $pq->insert_with_priority( 7, 'motto');
+       $pq->pull_highest_priority_element;
+       $pq->insert_with_priority( 4, 'do');
+       $pq->insert_with_priority(-2, "There's");
+
+    extract_and_display($pq);
+}
+
+sub extract_and_display
+{
+    my  ($pq) = @_;
+    my   @elements;
+    push @elements, $pq->pull_highest_priority_element until $pq->is_empty;
+
+    print join(' ', @elements), "\n";
+}
+
+################################################################################
diff --git a/challenge-018/athanasius/perl6/MyPriorityQueue.pm6 b/challenge-018/athanasius/perl6/MyPriorityQueue.pm6
new file mode 100644
index 0000000000..2fbe576368
--- /dev/null
+++ b/challenge-018/athanasius/perl6/MyPriorityQueue.pm6
@@ -0,0 +1,69 @@
+################################################################################
+=begin comment
+
+Perl Weekly 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 [ https://en.wikipedia.org/wiki/Priority_queue |wiki page] for more
+informations. It should serve the following operations:
+
+  1) *is_empty*: check whether the queue has no elements.
+
+  2) *insert_with_priority*: add an element to the queue with an associated
+      priority.
+
+  3) *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.
+
+=end comment
+################################################################################
+
+#--------------------------------------#
+# Copyright © 2019 PerlMonk Athanasius #
+#--------------------------------------#
+
+class MyPriorityQueue
+{
+	use Heap;
+
+	has Heap $!heap;
+
+	submethod BUILD(Bool :$reverse = False)
+	{
+		$!heap = $reverse ?? Heap[-*<order>].new
+						  !! Heap[ *<order>].new;
+	}
+
+	method is_empty(--> Bool)
+	{
+		return !?$!heap;
+	}
+
+	method insert_with_priority(Int:D $priority, Any:D $element)
+	{
+		$!heap.push: { order => $priority,
+					   datum => $element, };
+	}
+
+	method pull_highest_priority_element(--> Any)
+	{
+		my Any $element;
+
+		unless self.is_empty()
+		{
+			my %top = $!heap.pop;
+
+			$element = %top< datum >;
+		}
+
+		return $element;
+	}
+}
+
+################################################################################
diff --git a/challenge-018/athanasius/perl6/ch-1.p6 b/challenge-018/athanasius/perl6/ch-1.p6
new file mode 100644
index 0000000000..fbbfdc6c87
--- /dev/null
+++ b/challenge-018/athanasius/perl6/ch-1.p6
@@ -0,0 +1,105 @@
+use v6;
+
+################################################################################
+=begin comment
+
+Perl Weekly 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
+[ https://en.wikipedia.org/wiki/Longest_common_substring_problem |wiki page] for
+details.
+
+=end comment
+################################################################################
+
+#--------------------------------------#
+# Copyright © 2019 PerlMonk Athanasius #
+#--------------------------------------#
+
+sub MAIN
+(
+    Str:D $string1,
+	Str:D $string2,
+		 *@strings3-n
+)
+{
+    my @strings = $string1, $string2;
+       @strings.append: @strings3-n;
+
+    my @sets;
+       @sets.push: get-substrings($_) for @strings;
+
+    # The set of common substrings is the intersection of all the substring sets
+
+    my Set $common-substrings = @sets[0];
+           $common-substrings = $common-substrings ∩ @sets[$_]
+                for 1 .. @sets.elems - 1;
+
+    if $common-substrings.elems == 0
+    {
+        say "\nNo common substrings found";
+    }
+    elsif (my @solutions = get-solutions($common-substrings)) == 1
+    {
+        say "\nThe longest common substring is: \"{ @solutions[0] }\"";
+    }
+    else
+    {
+        say "\nThe { @solutions.elems } longest common substrings are: ",
+             @solutions.sort.map({ qq["$_"] }).join(', ');
+    }
+}
+
+sub get-substrings
+(
+    Str:D $string
+--> Set:D
+)
+{
+    my      @substrings;
+    my UInt $max-index = $string.chars - 1;
+
+    for 0 .. $max-index -> UInt $start-index
+    {
+        for 1 .. ($max-index - $start-index + 1) -> UInt $length
+        {
+            @substrings.push: $string.substr($start-index, $length);
+        }
+    }
+
+    return @substrings.Set;
+}
+
+sub get-solutions
+(
+    Set:D $substrings
+--> List:D
+)
+{
+    my @sorted     = $substrings.keys.sort({ $^b.chars cmp $^a.chars });
+    my @solutions  = @sorted.shift;
+    my $max-length = @solutions[0].chars;
+
+    while (my $element = @sorted.shift)
+    {
+        if $element.chars == $max-length
+        {
+            @solutions.push: $element;
+        }
+        else
+        {
+            last;
+        }
+    }
+
+    return @solutions;
+}
+
+################################################################################
diff --git a/challenge-018/athanasius/perl6/ch-2.p6 b/challenge-018/athanasius/perl6/ch-2.p6
new file mode 100644
index 0000000000..2737dc4ea6
--- /dev/null
+++ b/challenge-018/athanasius/perl6/ch-2.p6
@@ -0,0 +1,85 @@
+use v6;
+
+################################################################################
+=begin comment
+
+Perl Weekly 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 [ https://en.wikipedia.org/wiki/Priority_queue |wiki page] for more
+informations. It should serve the following operations:
+
+  1) *is_empty*: check whether the queue has no elements.
+
+  2) *insert_with_priority*: add an element to the queue with an associated
+      priority.
+
+  3) *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.
+
+=end comment
+################################################################################
+
+#--------------------------------------#
+# Copyright © 2019 PerlMonk Athanasius #
+#--------------------------------------#
+
+use lib < . >;
+use MyPriorityQueue;
+
+sub MAIN()
+{
+	say '';
+
+    # (1) Larger number = higher priority
+
+    my $pq = MyPriorityQueue.new(:reverse(True));
+       $pq.insert_with_priority( 4, 'over');
+       $pq.insert_with_priority( 8, 'quick');
+       $pq.insert_with_priority(12, 'REMOVE');
+       $pq.insert_with_priority( 5, 'jumped');
+       $pq.insert_with_priority( 0, '--Snoopy');
+       $pq.insert_with_priority( 3, 'the');
+       $pq.insert_with_priority( 7, 'brown');
+       $pq.insert_with_priority( 2, 'unfortunate');
+       $pq.insert_with_priority(11, 'The');
+       $pq.pull_highest_priority_element;
+       $pq.insert_with_priority( 1, 'dog.');
+       $pq.insert_with_priority( 7, 'fox');
+
+	extract-and-display($pq);
+
+    # (2) Lower number = higher priority
+
+       $pq = MyPriorityQueue.new;
+       $pq.insert_with_priority(-1, 'more');
+       $pq.insert_with_priority( 2, 'way');
+       $pq.insert_with_priority( 6, '--Perl');
+       $pq.insert_with_priority( 0, 'than');
+       $pq.insert_with_priority( 5, 'it.');
+       $pq.insert_with_priority(-2, 'REMOVE');
+       $pq.insert_with_priority( 2, 'to');
+       $pq.insert_with_priority( 1, 'one');
+       $pq.insert_with_priority( 7, 'motto');
+       $pq.pull_highest_priority_element;
+       $pq.insert_with_priority( 4, 'do');
+       $pq.insert_with_priority(-2, "There's");
+
+	extract-and-display($pq);
+}
+
+sub extract-and-display(MyPriorityQueue:D $pq)
+{
+    my @elements;
+       @elements.push: $pq.pull_highest_priority_element until $pq.is_empty;
+			
+    say join(' ', @elements);
+}
+
+################################################################################