Challenge 7 problem 2 by Jaldhar H. Vyas

2 files changed, 198 insertions, 0 deletions

diff --git a/challenge-007/jaldhar-h-vyas/perl5/ch-2.pl b/challenge-007/jaldhar-h-vyas/perl5/ch-2.pl
new file mode 100755
index 0000000000..86d4ea98e8
--- /dev/null
+++ b/challenge-007/jaldhar-h-vyas/perl5/ch-2.pl
@@ -0,0 +1,113 @@
+#!/usr/bin/perl
+use warnings;
+use strict;
+use 5.010;
+use English qw/ -no_match_vars /;
+
+sub usage {
+    print <<"-USAGE-";
+    Usage:
+    $PROGRAM_NAME <list> <startWord> <endWord>
+
+    <list>       a list of words, one per line.
+    <startWord>  must be all lower case.
+    <endWord>    must be all lower case and the same length as startWord.
+-USAGE-
+
+    exit(1);
+}
+
+# Reads a list of words, throws out the ones that are not the right length or
+# contain non-alphabetical characters, makes them lower case and then returns
+# this list.
+sub words {
+    my ($list, $length) = @_;
+    open my $wordList, '<', $list or die "$list: $!\n";
+    local $RS;
+    my $contents = <$wordList>;
+    close $wordList;
+    return [ sort 
+           map { lc }
+           grep { /^[[:alpha:]]+$/ }
+           grep { length == $length }
+           split /\n/,
+           $contents ];
+}
+
+# makes and returns an undirected graph where the nodes are words and the edges
+# are other words that differ by one letter only.
+sub graph {
+    my ($words) = @_;
+    my %buckets;
+    my %graph;
+
+    for my $word (@{$words}) {
+        for my $i (0 .. (length $word) - 1) {
+            my $bucket = $word;
+            substr $bucket, $i, 1, '_';
+            push @{$buckets{$bucket}}, $word;
+        }
+    } 
+
+    while (my ($bucket, $neighbors)  = each %buckets) {
+        for my $perm (map{ my $x = $_; map { [$x, $_] } @{$neighbors} }
+        @{$neighbors}) {
+            if ($perm->[0] ne $perm->[1]) {
+                $graph{$perm->[0]}->{$perm->[1]} = undef;
+                $graph{$perm->[1]}->{$perm->[0]} = undef;
+            }
+        }
+    }
+
+    return \%graph;
+}
+
+# Does a breadth-first search of the word graph returning the path from the
+# start word to the end word if there is one.
+sub traverse {
+    my ($graph, $startWord, $endWord) = @_;
+    my %visited;
+    my @ladder = ();
+    my @queue = ([$startWord]);
+
+    while (scalar @queue) {
+        my $path = shift @queue;
+        my $vertex = @{$path}[-1];
+        if ($vertex eq $endWord) {
+            return @{$path};
+        }
+
+        for my $v (keys %{$graph->{$vertex}}) {
+            if (!exists $visited{$v}) {
+                $visited{$v} = undef;
+                my @next = @{$path};
+                push @next, $v;
+                push @queue, \@next;
+            }
+        }
+    }
+}
+
+# The function that finds the word ladder with signature required by the spec
+sub find_shortest_ladder {
+    my ($word1, $word2, $wordlist) = @_;
+    return traverse(graph($wordlist), $word1, $word2);
+}
+
+if (scalar @ARGV < 3) {
+    usage();
+}
+
+my $list = $ARGV[0];
+my $startWord = $ARGV[1];
+my $endWord = $ARGV[2];
+
+if ($startWord !~ /^[[:lower:]]+$/ || $endWord !~ /^[[:lower:]]+$/ ||
+length $startWord != length $endWord) {
+    usage();
+}
+
+say join(
+    q{ }, 
+    find_shortest_ladder($startWord, $endWord, words($list, length $startWord))
+);
diff --git a/challenge-007/jaldhar-h-vyas/perl6/ch-2.p6 b/challenge-007/jaldhar-h-vyas/perl6/ch-2.p6
new file mode 100755
index 0000000000..fa8cff461c
--- /dev/null
+++ b/challenge-007/jaldhar-h-vyas/perl6/ch-2.p6
@@ -0,0 +1,85 @@
+#!/usr/bin/perl6
+
+# Reads a list of words, throws out the ones that are not the right length or
+# contain non-alphabetical characters, makes them lower case and then returns
+# this list.
+sub words(Str $list, Int $length) {
+    return $list.IO.lines
+        .grep({  /^<:alpha>+$/ })
+        .grep({ .chars == $length })
+        .map({ .lc })
+        .sort;
+}
+
+# makes and returns an undirected graph where the nodes are words and the edges
+# are other words that differ by one letter only.
+sub graph (*@words) {
+    my Array %buckets;
+    my SetHash %graph;
+
+
+    for @words -> $word {
+        for 0 .. $word.chars - 1 -> $i {
+            (my $bucket = $word).substr-rw($i, 1) = '_';
+            %buckets{$bucket}.push($word);
+        }
+    } 
+
+    for %buckets.kv -> $bucket, @neighbors {
+        for @neighbors X @neighbors -> $perm {
+            if $perm[0] !~~ $perm[1] {
+                %graph{$perm[0]}{$perm[1]} = True;
+                %graph{$perm[1]}{$perm[0]} = True;
+            }
+        }
+    }
+
+    return %graph;
+}
+
+# Does a breadth-first search of the word graph returning the path from the
+# start word to the end word if there is one.
+sub traverse(SetHash %graph, Str $startWord) {
+    my %visited;
+    my Str @ladder;
+    my @queue = «$startWord»;
+    %visited{$startWord} = True;
+
+    while @queue.elems {
+        my @path = @queue.shift.flat;
+        my $vertex = @path[*-1];
+        take $vertex, @path;
+
+        for %graph{$vertex}.keys -> $v {
+            if !%visited{$v} {
+                %visited{$v} = True;
+                @queue.push((my @next = @path).push($v));
+            }
+        }
+    }
+}
+
+# The function that finds the word ladder with signature required by the spec
+sub find_shortest_ladder(Str $word1, Str $word2, *@wordlist) {
+    for gather traverse(graph(@wordlist), $word1) -> ($vertex, @path) {
+        if ($vertex ~~ $word2) {
+            return @path;
+        }
+    }
+}
+
+sub MAIN(
+    Str $list,      #= a list of words, one per line.
+    Str $startWord, #= must be all lower case.
+    Str $endWord    #= must be all lower case and the same length as startWord.
+    where {
+        $startWord ~~ /^<:lower>+$/ &&
+        $endWord ~~ /^<:lower>+$/ &&
+        $startWord.chars == $endWord.chars
+    }
+) {
+    find_shortest_ladder($startWord, $endWord, words($list, $startWord.chars))
+        .join(' ')
+        .say;
+}
+