Merge pull request #4335 from polettix/polettix/pwc118

Add polettix's solution to challenge-118

7 files changed, 388 insertions, 14 deletions

diff --git a/challenge-118/polettix/blog.txt b/challenge-118/polettix/blog.txt
new file mode 100644
index 0000000000..153c51bdc2
--- /dev/null
+++ b/challenge-118/polettix/blog.txt
@@ -0,0 +1 @@
+https://github.polettix.it/ETOOBUSY/2021/06/23/pwc118-binary-palindrome/
diff --git a/challenge-118/polettix/blog1.txt b/challenge-118/polettix/blog1.txt
new file mode 100644
index 0000000000..2ed6d851c6
--- /dev/null
+++ b/challenge-118/polettix/blog1.txt
@@ -0,0 +1 @@
+https://github.polettix.it/ETOOBUSY/2021/06/24/pwc118-adventure-of-knight/
diff --git a/challenge-118/polettix/ch-1.input b/challenge-118/polettix/ch-1.input
deleted file mode 100644
index 5b9d9ab1ce..0000000000
--- a/challenge-118/polettix/ch-1.input
+++ /dev/null
@@ -1,14 +0,0 @@
-11, Line Eleven
-1, Line one
-9, Line Nine
-13, Line Thirteen
-2, Line two
-6, Line Six
-8, Line Eight
-10, Line Ten
-7, Line Seven
-4, Line Four
-14, Line Fourteen
-3, Line three
-15, Line Fifteen
-5, Line Five
diff --git a/challenge-118/polettix/perl/ch-1.pl b/challenge-118/polettix/perl/ch-1.pl
new file mode 100644
index 0000000000..ec9462cb5a
--- /dev/null
+++ b/challenge-118/polettix/perl/ch-1.pl
@@ -0,0 +1,17 @@
+#!/usr/bin/env perl
+use 5.024;
+use warnings;
+use experimental qw< postderef signatures >;
+no warnings qw< experimental::postderef experimental::signatures >;
+
+sub binary_palindrome ($N) {
+   die "invalid $N (positive integers are OK)\n"
+      if $N !~ m{\A [1-9]\d* \z}mxs;
+   return unless $N % 2;
+   my ($M, $n) = (0, $N);
+   ($M, $n) = (($M << 1) | ($n & 1), $n >> 1) while $n > 0;
+   return $M == $N;
+}
+
+my @args = @ARGV ? @ARGV : 1 .. 31;
+say $_, ' -> ', binary_palindrome($_) ? 1 : 0 for @args;
diff --git a/challenge-118/polettix/perl/ch-2.pl b/challenge-118/polettix/perl/ch-2.pl
new file mode 100644
index 0000000000..d079d7d3a4
--- /dev/null
+++ b/challenge-118/polettix/perl/ch-2.pl
@@ -0,0 +1,288 @@
+#!/usr/bin/env perl
+use 5.024;
+use warnings;
+use experimental qw< postderef signatures >;
+no warnings qw< experimental::postderef experimental::signatures >;
+use List::Util qw< sum >;
+
+my $input = shift // do {
+   my $default = <<'END';
+      a b c d e f g h
+    8 N * * * * * * * 8
+    7 * * * * * * * * 7
+    6 * * * * x * * * 6
+    5 * * * * * * * * 5
+    4 * * x * * * * * 4
+    3 * x * * * * * * 3
+    2 x x * * * * * * 2
+    1 * x * * * * * * 1
+      a b c d e f g h
+END
+   \$default;
+};
+print_solution(adventure_of_knight(parse_input($input)));
+
+sub adventure_of_knight ($input) {
+
+   # First, analyze the setup to find the minimum distance/path from
+   # every location on the board to every other location, accounting for
+   # the knight way of moving
+   my $max_X = $input->{row_names}->$#*;
+   my $max_Y = $input->{col_names}->$#*;
+   my $analysis = floyd_warshall(
+      distance => sub { 1 },
+      identifier => sub ($node) { join ',', $node->@* },
+      start => $input->{knight},
+      successors => sub ($node) {
+         my ($x, $y) = $node->@*;
+         my @succs;
+         for my $long (-2, +2) {
+            for my $short (-1, +1) {
+               for my $p ([$long, $short], [$short, $long]) {
+                  my ($X, $Y) = ($x + $p->[0], $y + $p->[1]);
+                  push @succs, [$X, $Y]
+                     if ($X >= 0) && ($X <= $max_X)
+                     && ($Y >= 0) && ($Y <= $max_Y);
+               }
+            }
+         }
+         return @succs;
+      },
+   );
+
+   # Second, evaluate the total distance over all possible sequencing of
+   # treasures, keeping the path with the shorter distance. This is not
+   # optimal as the number of treasures grows, but for a fixed number of
+   # treasures at 6 it means that only 720 permutations have to be
+   # considered, which is fair.
+   my $pit = permutations_iterator(items => $input->{treasures});
+   my ($min_distance, @min_path);
+   while (my @path = $pit->()) {
+      unshift @path, $input->{knight};
+      my $distance = sum map {
+         $analysis->{distance}->(@path[$_ - 1, $_]);
+      } 1 .. $#path;
+      ($min_distance, @min_path) = ($distance, @path)
+         if ! defined($min_distance) || $distance < $min_distance;
+   }
+
+   # Last, adapt our finding to provide an array of path sections that
+   # have to be walked in sequence. This is the main part of our output.
+   my @sections = map {
+      my @section = $analysis->{path}->(@min_path[$_ - 1, $_]);
+      shift @section;
+      \@section;
+   } 1 .. $#min_path;
+   return {
+      $input->%*,
+      sections => \@sections,
+   };
+}
+
+sub print_solution ($solution) {
+   my $position_for = sub ($x, $y) {
+      $solution->{col_names}[$x] . $solution->{row_names}[$y];
+   };
+   my @stops = (
+      $position_for->($solution->{knight}->@*) . '.N',
+      map {
+         my @section = map {$position_for->($_->@*)} $_->@*;
+         $section[-1] = $section[-1] . '.x';
+         @section;
+      } $solution->{sections}->@*,
+   );
+   say join ' ', @stops;
+   say scalar(@stops) - 1, ' moves';
+}
+
+sub parse_input ($fof) {
+   my $fh = ref($fof) eq 'GLOB' ? $fof
+      : (! ref($fof) && ($fof eq '-')) ? \*STDIN
+      : do { open my $x, '<', $fof or die 'file...'; $x };
+   my ($knight, @treasures, @row_names, @col_names);
+   while (<$fh>) {
+      s{\A\s+|\s+\z}{}gmxs;
+      my @row = split m{\s+}mxs;
+
+      if (m{\A \s* \d}mxs) {
+         my $i = @row_names;
+         push @row_names, shift @row;
+         pop @row;
+
+         for my $j (0 .. $#row) {
+            my $char = $row[$j];
+            if ($char eq 'N') {
+               die "too many knights\n" if defined $knight;
+               $knight = [$j, $i];
+            }
+            elsif ($char eq 'x') {
+               push @treasures, [$j, $i];
+            }
+            elsif ($char ne '*') {
+               die "invalid character '$char'\n";
+            }
+         }
+      }
+      elsif (! @col_names) {
+         @col_names = @row;
+      }
+   }
+   return {
+      knight => $knight,
+      treasures => \@treasures,
+      row_names => \@row_names,
+      col_names => \@col_names,
+   };
+}
+
+sub floyd_warshall {
+   my %args = (@_ && ref($_[0])) ? %{$_[0]} : @_;
+   my @reqs = qw< distance successors >;
+   exists($args{$_}) || die "missing parameter '$_'" for @reqs;
+   my ($dist, $scs) = @args{@reqs};
+   my $id_of = $args{identifier} || sub { return "$_[0]" };
+   my @q = exists($args{starts}) ? @{$args{starts}}
+      : exists($args{start}) ? ($args{start})
+      : die "missing parameter 'starts' or 'start'";
+   my (%d, %p, %nf); # distances, predecessors
+   while (@q) { # initialization
+      next if exists $nf{my $vi = $id_of->(my $v = shift @q)};
+      for my $w ($scs->($nf{$vi} = $v)) {
+         next if $vi eq (my $wi = $id_of->($w)); # avoid self-edges
+         ($d{$vi}{$wi}, $p{$vi}{$wi}) = ($dist->($v, $w), $vi);
+         push @q, $w unless exists $nf{$wi};
+      }
+      $d{$vi}{$vi} = 0;
+   }
+   my @vs = keys %nf;
+   for my $vi (@vs) {
+      for my $vv (@vs) {
+         next unless exists $p{$vv}{$vi};
+         for my $vw (@vs) {
+            next if (!exists $d{$vi}{$vw}) || (exists($d{$vv}{$vw})
+               && ($d{$vv}{$vw} <= $d{$vv}{$vi} + $d{$vi}{$vw}));
+            $d{$vv}{$vw} = $d{$vv}{$vi} + $d{$vi}{$vw};
+            $p{$vv}{$vw} = $p{$vi}{$vw};
+         }
+         return if $d{$vv}{$vv} < 0; # negative cycle, bail out
+      }
+   }
+   return {
+      has_path => sub {
+         my ($vi, $wi) = map { $id_of->($_) } @_[0, 1];
+         return exists($d{$vi}) && exists($d{$vi}{$wi});
+      },
+      distance => sub {
+         my ($vi, $wi) = map { $id_of->($_) } @_[0, 1];
+         return unless exists($d{$vi}) && exists($d{$vi}{$wi});
+         return $d{$vi}{$wi};
+      },
+      path => sub {
+         my ($fi, $ti) = map { $id_of->($_) } @_[0, 1];
+         return unless exists($d{$fi}) && exists($d{$fi}{$ti});
+         my @path;
+         while ($ti ne $fi) {
+            unshift @path, $nf{$ti};
+            $ti = $p{$fi}{$ti};
+         }
+         unshift @path, $nf{$ti};
+         return wantarray ? @path : \@path;
+      },
+   };
+}
+
+sub permutations_iterator {
+   my %args = (@_ && ref($_[0])) ? %{$_[0]} : @_;
+   my $items = $args{items} || die "invalid or missing parameter 'items'";
+   my $filter = $args{filter} || sub { wantarray ? @_ : [@_] };
+   my @indexes = 0 .. $#$items;
+   my @stack = (0) x @indexes;
+   my $sp = undef;
+   return sub {
+      if (! defined $sp) { $sp = 0 }
+      else {
+         while ($sp < @indexes) {
+            if ($stack[$sp] < $sp) {
+               my $other = $sp % 2 ? $stack[$sp] : 0;
+               @indexes[$sp, $other] = @indexes[$other, $sp];
+               $stack[$sp]++;
+               $sp = 0;
+               last;
+            }
+            else {
+               $stack[$sp++] = 0;
+            }
+         }
+      }
+      return $filter->(@{$items}[@indexes]) if $sp < @indexes;
+      return;
+   }
+}
+
+package PriorityQueue;  # Adapted from https://algs4.cs.princeton.edu/24pq/
+use strict;
+
+sub contains    { return $_[0]->contains_id($_[0]{id_of}->($_[1])) }
+sub contains_id { return exists $_[0]{item_of}{$_[1]} }
+sub is_empty    { return !$#{$_[0]{items}} }
+sub item_of { exists($_[0]{item_of}{$_[1]}) ? $_[0]{item_of}{$_[1]} : () }
+sub new;                # see below
+sub dequeue { return $_[0]->_remove_kth(1) }
+sub enqueue;                # see below
+sub remove    { return $_[0]->remove_id($_[0]{id_of}->($_[1])) }
+sub remove_id { return $_[0]->_remove_kth($_[0]{pos_of}{$_[1]}) }
+sub size      { return $#{$_[0]{items}} }
+sub top       { return $_[0]->size ? $_[0]{items}[1] : () }
+sub top_id    { return $_[0]->size ? $_[0]{id_of}->($_[0]{items}[1]) : () }
+
+sub new {
+   my $package = shift;
+   my $self = bless {((@_ && ref($_[0])) ? %{$_[0]} : @_)}, $package;
+   $self->{before} ||= sub { return $_[0] < $_[1] };
+   $self->{id_of} ||= sub { return ref($_[0]) ? "$_[0]" : $_[0] };
+   my $items = $self->{items} || [];
+   @{$self}{qw< items pos_of item_of >} = (['-'], {}, {});
+   $self->enqueue($_) for @$items;
+   return $self;
+} ## end sub new
+
+sub enqueue {    # insert + update in one... DWIM
+   my ($is, $id) = ($_[0]{items}, $_[0]{id_of}->($_[1]));
+   $_[0]{item_of}{$id} = $_[1];    # keep track of this item
+   my $k = $_[0]{pos_of}{$id} ||= do { push @$is, $_[1]; $#$is };
+   $_[0]->_adjust($k);
+   return $id;
+} ## end sub enqueue
+
+sub _adjust {                      # assumption: $k <= $#$is
+   my ($is, $before, $self, $k) = (@{$_[0]}{qw< items before >}, @_);
+   $k = $self->_swap(int($k / 2), $k)
+     while ($k > 1) && $before->($is->[$k], $is->[$k / 2]);
+   while ((my $j = $k * 2) <= $#$is) {
+      ++$j if ($j < $#$is) && $before->($is->[$j + 1], $is->[$j]);
+      last if $before->($is->[$k], $is->[$j]);    # parent is OK
+      $k = $self->_swap($j, $k);
+   }
+   return $self;
+} ## end sub _adjust
+
+sub _remove_kth {
+   my ($is, $self, $k) = ($_[0]{items}, @_);
+   die 'no such item' if (!defined $k) || ($k <= 0) || ($k > $#$is);
+   $self->_swap($k, $#$is);
+   my $r = CORE::pop @$is;
+   $self->_adjust($k) if $k <= $#$is;    # no adjust for last element
+   my $id = $self->{id_of}->($r);
+   delete $self->{$_}{$id} for qw< item_of pos_of >;
+   return $r;
+} ## end sub _remove_kth
+
+sub _swap {
+   my ($self,  $i,      $j)     = @_;
+   my ($items, $pos_of, $id_of) = @{$self}{qw< items pos_of id_of >};
+   my ($I, $J) = @{$items}[$i, $j] = @{$items}[$j, $i];
+   @{$pos_of}{($id_of->($I), $id_of->($J))} = ($i, $j);
+   return $i;
+} ## end sub _swap
+
+1;
diff --git a/challenge-118/polettix/raku/ch-1.raku b/challenge-118/polettix/raku/ch-1.raku
new file mode 100644
index 0000000000..3d3e17ee8a
--- /dev/null
+++ b/challenge-118/polettix/raku/ch-1.raku
@@ -0,0 +1,12 @@
+#!/usr/bin/env raku
+use v6;
+sub binary-palindrome (Int:D $N where * > 0 --> Bool) {
+   return False if $N %% 2;
+   my ($M, $n) = (0, $N);
+   ($M, $n) = (($M +< 1) +| ($n +& 1), $n +> 1) while $n > 0;
+   return so $M == $N;
+}
+sub MAIN (*@args is copy) {
+   @args = 1 .. 31;
+   put $_, ' -> ', binary-palindrome($_) ?? 1 !! 0 for @args;
+}
diff --git a/challenge-118/polettix/raku/ch-2.raku b/challenge-118/polettix/raku/ch-2.raku
new file mode 100644
index 0000000000..1ea79168aa
--- /dev/null
+++ b/challenge-118/polettix/raku/ch-2.raku
@@ -0,0 +1,69 @@
+#!/usr/bin/env raku
+use v6;
+
+my $knight = (0, 0);
+my @treasures = < 4 2 2 4 1 5 0 6 1 6 1 7 >.map({($^a, $^b)});
+my $optimal = @*ARGS ?? True !! False;
+
+my @path = adventure-of-knight($knight, @treasures, $optimal).flat;
+@path.join(' ').put;
+put @path.end, ' moves';
+
+sub adventure-of-knight ($knight, @treasures, $optimal = False) {
+   sub pos-to-pos ($p) {
+      state @rows = (1..8).reverse;
+      state @cols = 'a' .. 'h';
+      return @cols[$p[0]] ~ @rows[$p[1]];
+   }
+   sub permutation-pass ($knight is copy, @treasures) {
+      return gather {
+         for @treasures -> $treasure {
+            take path-between($knight, $treasure);
+            $knight = $treasure;
+         }
+      }
+   }
+   my ($min_distance, @min_path);
+   for permutations(@treasures) -> @perm {
+      my @path = permutation-pass($knight, @perm).flat;
+      my $distance = @path.map({$_.end}).sum;
+      ($min_distance, @min_path) = ($distance, @path.Slip)
+         if ! defined($min_distance) || $distance < $min_distance;
+      last unless $optimal;
+   }
+   return gather {
+      take pos-to-pos($knight) ~ '.N';
+      for @min_path -> $sequence {
+         my ($first, @rest) = @$sequence; # $first will be ignored
+         my $treasure = @rest.pop;
+         @rest.map({take pos-to-pos($_)});
+         take pos-to-pos($treasure) ~ '.x';
+      }
+   }
+}
+
+sub path-between ($start, $stop) {
+   sub same { ($^a <<->> $^b).map({$_²}).sum == 0 };
+   return () if same($start, $stop);
+   my $visited = SetHash.new();
+   my @queue = (($start,),);
+   while @queue.elems {
+      my $subpath = @queue.shift;
+      my ($x, $y) = @$subpath[*-1];
+      for -2, 2 -> $long {
+         for -1, 1 -> $short {
+            for ($long, $short), ($short, $long) -> $pair {
+               my ($X, $Y) = ($x + $pair[0], $y + $pair[1]);
+               next unless (0 <= $X <= 7) && (0 <= $Y <= 7);
+               my $pos = "$X,$Y";
+               next if $visited{$pos};
+               $visited.set($pos);
+               my $newpath = ($subpath.Slip, ($X, $Y));
+               return $newpath if same(($X, $Y), $stop);
+               push @queue, $newpath;
+            }
+         }
+      }
+   }
+   die 'no way';
+}