Merge pull request #4332 from simongreen-net/swg-118

sgreen solution to challenge 118

4 files changed, 179 insertions, 2 deletions

diff --git a/challenge-118/sgreen/README.md b/challenge-118/sgreen/README.md
index da8ff3e726..64b6aa2762 100644
--- a/challenge-118/sgreen/README.md
+++ b/challenge-118/sgreen/README.md
@@ -1,3 +1,3 @@
-# The Weekly Challenge 117
+# The Weekly Challenge 118
 
-Solution by Simon Green. [Blog](https://dev.to/simongreennet/weekly-challenge-117-36cn)
+Solution by Simon Green. [Blog](https://dev.to/simongreennet/weekly-challenge-118-4hg9)
diff --git a/challenge-118/sgreen/blog.txt b/challenge-118/sgreen/blog.txt
new file mode 100644
index 0000000000..ed5d2539b3
--- /dev/null
+++ b/challenge-118/sgreen/blog.txt
@@ -0,0 +1 @@
+https://dev.to/simongreennet/weekly-challenge-118-4hg9
diff --git a/challenge-118/sgreen/perl/ch-1.pl b/challenge-118/sgreen/perl/ch-1.pl
new file mode 100755
index 0000000000..eeced91068
--- /dev/null
+++ b/challenge-118/sgreen/perl/ch-1.pl
@@ -0,0 +1,20 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use feature 'say';
+
+sub main {
+    my $number = shift;
+
+    # Sanity check
+    die "You must specify a number\n" unless defined $number;
+    die "The value does not appear to be a positive integer\n" unless $number =~ /^[1-9][0-9]*$/;
+
+    # Turn the value into a binary string
+    my $bin = sprintf '%b', $number;
+
+    say $bin eq reverse($bin) ? 1 : 0;
+}
+
+main(@ARGV);
diff --git a/challenge-118/sgreen/perl/ch-2.pl b/challenge-118/sgreen/perl/ch-2.pl
new file mode 100755
index 0000000000..90294a8db7
--- /dev/null
+++ b/challenge-118/sgreen/perl/ch-2.pl
@@ -0,0 +1,156 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use feature 'say';
+
+use List::Util qw(any uniq);
+
+sub main {
+    my @target_strings = map { lc } @_;
+    die "You must specify one or more chess positions!\n" unless @target_strings;
+
+    # The knight always starts from the top left square.
+    unshift @target_strings, 'a8';
+
+    # Find all the targets on the board (0,0 = bottom left)
+    my $targets = _input_to_targets(@target_strings);
+
+    # Find the intermediate moves for all possible combinations. We only
+    #  need to calculate half of them, as the reverse can be used for going
+    #  the other way.
+    my @intermediates = ();
+    for my $start ( 0 .. $#$targets - 1 ) {
+        foreach my $end ( $start + 1 .. $#$targets ) {
+            my $intermediate_points = _get_intermediate_moves( @$targets[ $start, $end ] );
+            $intermediates[$start][$end] = $intermediate_points;
+            $intermediates[$end][$start] = [ reverse @$intermediate_points ];
+        }
+    }
+
+    # Work through all possible orders of finding the targets
+    my @permutations = _get_permutations( [ 1 .. $#$targets ], [] );
+
+    # Now find the path with the least amount of moves
+    my @least_moves = ();
+    foreach my $permutation (@permutations) {
+        # Each value in the array is x, y, and whether this is the target cell.
+        my @this_path = ( [ @{ $targets->[0] }, 1 ] );
+        foreach my $move ( 1 .. $#$permutation ) {
+            # Add the intermediate moves and then the target cell.
+            push @this_path,
+              map { [ @$_, 0 ] } @{ $intermediates[ $permutation->[ $move - 1 ] ][ $permutation->[$move] ] };
+            push @this_path, [ @{ $targets->[ $permutation->[$move] ] }, 1 ];
+        }
+
+        if ( @least_moves == 0 or @least_moves > @this_path ) {
+            @least_moves = @this_path;
+        }
+    }
+
+    # And now display it
+    say 'The shortest path is ', scalar(@least_moves), ' steps';
+    say join ' » ', map { my $cn = _cn( $_->[0], $_->[1] ); $_->[2] ? "*$cn*" : $cn } @least_moves;
+}
+
+sub _input_to_targets {
+    my @target_strings = @_;
+    my @targets        = ();
+
+    # Check there are no dups
+    die "One or more targets are listed twice!\n" if @target_strings != uniq(@target_strings);
+
+    # Turn all the input strings into positions on the board. a1 (bottom
+    #  left) is (0, 0).
+    foreach my $string (@target_strings) {
+        if ( $string =~ /^([a-h])([1-8])$/i ) {
+            push @targets, [ ord($1) - 97, $2 - 1 ];
+        }
+        else {
+            die "The value '$string' is not a valid chess position!\n";
+        }
+    }
+
+    return \@targets;
+}
+
+sub _get_intermediate_moves {
+    my ( $start, $end )   = @_;
+    my ( $end_x, $end_y ) = @$end;
+
+    # All the possible moves a knight can move. First value is left
+    #  (negative) or right (postive). The second value is up (positive)
+    #  or down (negative).
+    my @deltas = ( [ 2, 1 ], [ 2, -1 ], [ -2, 1 ], [ -2, -1 ], [ 1, 2 ], [ 1, -2 ], [ -1, 2 ], [ -1, -2 ] );
+
+    # Seed the movements with our start points
+    my @moves = ( [$start] );
+
+    # Record which cells have been seen by other movements
+    my @seen = ();
+    $seen[ $start->[0] ][ $start->[1] ] = 1;
+
+    my $solution = undef;
+  FIND: while ( not defined $solution ) {
+        my @new_moves = ();
+
+        # Move in each direction as long as we remain on the board
+        foreach my $move (@moves) {
+            foreach my $delta (@deltas) {
+                my $new_x = $move->[-1][0] + $delta->[0];
+                my $new_y = $move->[-1][1] + $delta->[1];
+
+                if ( $new_x == $end_x and $new_y == $end_y ) {
+                    # We have found the moves from $start to $end
+                    $solution = $move;
+                    last FIND;
+                }
+
+                # Only add this move if we are within the bounds of the
+                #  board AND we haven't already moved to this position
+                #  previously
+                if ( $new_x >= 0 and $new_x <= 7 and $new_y >= 0 and $new_y <= 7 and not $seen[$new_x][$new_y]++ ) {
+                    push @new_moves, [ @$move, [ $new_x, $new_y ] ];
+                }
+            }
+        }
+
+        @moves = @new_moves;
+    }
+
+    # Remove the starting point and return the intermediate moves
+    shift @$solution;
+    return $solution;
+}
+
+sub _cn {
+    # Turn a grid refence to chess notation (0, 0 => a1)
+    my ( $x, $y ) = @_;
+    return chr( $x + 97 ) . ( $y + 1 );
+}
+
+sub _get_permutations {
+    # A little recursive function to generate all permutations of the
+    #  sets of numbers.
+    my ( $remaining, $used ) = @_;
+    my @permutations = ();
+
+    if ( $#$remaining == 0 ) {
+        # We have a new permutation
+        return [ 0, @$used, @$remaining ];
+    }
+
+    for my $i ( 0 .. $#$remaining ) {
+        # Use one of the remaining numbers (in the order of the array),
+        #  any recursively call this function
+        my @new_used      = ( @$used, $remaining->[$i] );
+        my @new_remaining = @$remaining;
+        splice( @new_remaining, $i, 1 );
+        push @permutations, _get_permutations( \@new_remaining, \@new_used );
+    }
+
+    return @permutations;
+
+}
+
+main(@ARGV);