Merge pull request #1819 from jo-37/contrib

Solutions to challenge 064

2 files changed, 209 insertions, 0 deletions

diff --git a/challenge-064/jo-37/perl/ch-1.pl b/challenge-064/jo-37/perl/ch-1.pl
new file mode 100755
index 0000000000..e39ade65e7
--- /dev/null
+++ b/challenge-064/jo-37/perl/ch-1.pl
@@ -0,0 +1,135 @@
+#!/usr/bin/perl
+
+# Use Dijkstra's algorithm to find a minimum weighted path
+# through a matrix.
+# The algorithm is provided by the "Graph" package.
+# To make use of this implementation, the given matrix has to
+# be transformed into a directed, weighted graph with the 
+# matrix elements as vertices and the valid moves as edges.
+# Each edge is assigned a weight that is the move's target matrix
+# element.
+# Assigning weights to the vertices is not necessary but it
+# simplifies the calculation of minimum path's weight.
+
+use Test2::V0;
+
+use Graph;
+use List::Util qw(reduce);
+
+# Set to true to display intermediate variables
+my $verbose;
+
+# Find minimum path from top left to bottom right in given matrix.
+sub minpath {
+	my $matrix = shift;
+	my $graph = graph($matrix);
+
+	# Get minimum weighted path using Dijkstra's algorithm
+	# from start to end vertex.
+	my @path = $graph->SP_Dijkstra(vertex(0,0),
+		vertex($#$matrix, $#{$matrix->[-1]}));
+
+	print
+		join(' -> ', map "$_:" . $graph->get_vertex_weight($_), @path),
+		"\n" if $verbose;
+
+	# Sum vertex weights in path.
+	reduce {$a + $graph->get_vertex_weight($b)} 0, @path;
+}
+
+# Create a directed weighted graph, allowing only
+# right or down moves in given matrix.
+sub graph {
+	my $matrix = shift;
+	my $out_edges = edges($matrix);
+	my $graph = Graph->new;
+
+	for my $row (0 .. $#$matrix) {
+		for my $col (0 .. $#{$matrix->[$row]}) {
+			next unless defined $matrix->[$row][$col];
+			$graph->add_weighted_edges(&$out_edges($row, $col));
+			$graph->set_vertex_weight(vertex($row, $col),
+				$matrix->[$row][$col]);
+		}
+		print "[",
+			join(', ', map {defined $_ ? sprintf('%2d', $_) : '  '}
+				@{$matrix->[$row]}),
+			"]\n" if $verbose;
+	}
+
+	$graph;
+}
+
+# Generate sub that returns outgoing weighted edges from given vertex
+# for this matrix.
+sub edges {
+	my $matrix = shift;
+
+	sub {
+		my ($row, $col) = @_;
+		my $vertex = vertex($row, $col);
+
+		# Create argument list for "add_weighted_edges" method.
+		# Add edge only if right/down neighbor vertex exists.
+		((defined $matrix->[$row][$col + 1] ?
+			($vertex, vertex($row, $col + 1),
+				$matrix->[$row][$col + 1]) : ()),
+		(defined $matrix->[$row + 1] && defined $matrix->[$row + 1][$col] ?
+			($vertex, vertex($row + 1, $col),
+				$matrix->[$row + 1][$col]) : ()));
+	}
+}
+
+# Create vertex name.
+sub vertex {
+	local $" = ',';
+	"(@_)";
+}
+
+# For testing only:
+# Generate matrix from sub
+sub narray {
+	my $size = shift;
+	my $val = pop;
+	my $na;
+	for my $i (0 .. $size - 1) {
+		$na->[$i] = @_ ?  narray(@_, sub {&$val($i, @_)}) : &$val($i);
+	}
+	$na;
+}
+
+# main
+$verbose = 1;
+
+# example from challenge
+my $example = narray(3, 3, sub {3 * $_[0] + $_[1] + 1});
+is minpath($example), 21, 'example from challenge';
+print "\n";
+
+# walk around a hill
+my $hill = narray(5, 5, sub {$_[0] * (4 - $_[0]) + $_[1] * (4 - $_[1])});
+is minpath($hill), 20, 'around the hill';
+print "\n";
+
+# walk though a valley
+my $valley = narray(5, 5, sub {abs($_[0] - $_[1])}
+);
+is minpath($valley), 4, 'through the valley';
+print "\n";
+
+# walk around holes
+my $hole = narray(5, 5, sub {
+		1 - ($_[1] == 2 ||
+			($_[0] == 0 && $_[1] < 2) ||
+			($_[0] == 4 && $_[1] > 2))
+		});
+undef $hole->[2][2];
+is minpath($hole), 3, 'avoid holes';
+
+done_testing;
+
+#srand;
+# random matrix
+my $rand = narray(3 + int(rand(4)), 3 + int(rand(4)), sub {int(rand(6))});
+print "\nToday's random matrix\n";
+print "minimum sum: ", minpath($rand), "\n";
diff --git a/challenge-064/jo-37/perl/ch-2.pl b/challenge-064/jo-37/perl/ch-2.pl
new file mode 100755
index 0000000000..0bec4d8b68
--- /dev/null
+++ b/challenge-064/jo-37/perl/ch-2.pl
@@ -0,0 +1,74 @@
+#!/usr/bin/perl
+
+use Test2::V0;
+
+# Set to true to display intermediate variables
+my $verbose;
+
+# First arg: string to be split
+# Remaining args: word list
+# Try to split string into words.
+# call: matchwords $S, @W
+sub matchwords {
+	local $_= shift;
+
+	# Generate regex matching and capturing any of the given words.
+	# This will look like qr/(?|(word1)|(word2)|.../
+	my $any = sub {local $" = '|'; qr/(?|@_)/ }->(
+		map "(@{[quotemeta]})",
+		sort {length $b <=> length $a} @_);
+	print "$any\n" if $verbose;
+
+	my @matched;
+	local our @match;
+
+	# Split string into given words, saving captured parts on the way.
+	m/
+		^
+		(?{ @match = () })	# Reset match at start of string.
+		(?:
+			$any			# Match and capture a word.
+							# Save matched word, backtracking-safe.
+			(?{local @match = @match; push @match, $1 })
+		)+
+		$
+							# Full match: Copy matched words
+							# from temporary to persistent variable.
+		(?{ @matched = @match })
+
+	/x;
+
+	@matched;
+}
+
+# Testdata:
+# $S: string to be split
+# @W: words to be used for splitting
+# @R: expected result
+# $C: Comment
+my @testdata = (
+	# [$S, [@W], [@R], $C],
+	['perlweeklychallenge', [qw(weekly challenge perl)],
+		[qw(perl weekly challenge)], '1st example'],
+	['perlandraku', [qw(python ruby haskell)],
+		[], '2nd example'],
+	['startismissing', [qw(is missing)], [], 'start word is missing'],
+	['endismissing', [qw(is end)], [], 'end word is missing'],
+	['middleismissing', [qw(missing middle)], [], 'middle word is missing'],
+	['some.*regex[a-z]inthe?string', [qw(.* [a-z] the? in regex some string)],
+		[qw(some .* regex [a-z] in the? string)],
+		'string and words contain regex meta chars'],
+	['thelongerwordmatches', [qw(long erwordm atch matches longer word the)],
+		[qw(the longer word matches)], 'longer word matches'],
+	['theshorterwordmatches', [qw(shorter erwordm atches match short word the)],
+		[qw(the short erwordm atches)], 'backtrack to shorter word'],
+);
+
+#$verbose = 1;
+
+plan scalar @testdata;
+for my $test (@testdata) {
+	my ($string, $words, $result, $comment) = @$test;
+	my @result = matchwords($string, @$words);
+	is \@result, $result, $comment;
+}