Add solutions for the Perl Weekly Challenge 077

4 files changed, 200 insertions, 0 deletions

diff --git a/challenge-077/polettix/perl/ch-1.pl b/challenge-077/polettix/perl/ch-1.pl
new file mode 100644
index 0000000000..5de293dab6
--- /dev/null
+++ b/challenge-077/polettix/perl/ch-1.pl
@@ -0,0 +1,97 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use English qw< -no_match_vars >;
+use autodie;
+
+main(shift || 1);
+
+sub main {
+   my ($n) = @_;
+
+   # compute the "basic" Zeckendorf decomposition of $n
+   my $lk = lekkerkerker($n);
+
+   # compute a "reasonable" decomposition into possible non-overlapping
+   # components
+   my @components;
+   for my $i (reverse 0 .. $#{$lk->{indexes}}) {
+      my $index = $lk->{indexes}[$i];
+      my $low_index = $i ? $lk->{indexes}[$i - 1] : 0;
+      my $alts = alternatives($index, $low_index);
+      push @components, $alts;
+   }
+
+   # compute all possible arrangements, reject those with overlaps and
+   # print the others
+   nested_loops_recursive(
+      \@components,
+      sub {
+         my @lineup;
+         my %seen;
+         my $sum = 0;
+         for my $constituent (@_) {
+            for my $i (@$constituent) {
+               return if $seen{$i}++;
+               my $fi = $lk->{fibo}[$i];
+               push @lineup, $fi;
+               $sum += $fi;
+            }
+         }
+         die "sum mismatch ($sum vs $n)\n" unless $n == $sum;
+         my $lineup = join ' + ', sort {$a <=> $b} @lineup;
+         print {*STDOUT} "$lineup = $sum\n";
+      }
+   );
+}
+
+sub lekkerkerker {
+   my ($n) = @_;
+   my @fibo = (1, 2);
+   push @fibo, $fibo[-2] + $fibo[-1] while $fibo[-1] < $n;
+   my $i = $#fibo;
+   my @indexes;
+   while ($n > 0) {
+      --$i while $fibo[$i] > $n;
+      unshift @indexes, $i;
+      $n -= $fibo[$i];
+   }
+   return {
+      fibo => \@fibo,
+      indexes => \@indexes,
+   };
+}
+
+# split an input index into the Fibonacci array into possible alternative
+# index sets representing the same Fibonacci number in alternative ways,
+# down to a lower index $il
+sub alternatives {
+   my ($i, $il) = @_;
+   my @item = ($i);
+   my @retval = ([$i]);
+   while ($i > $il + 1) {
+      pop @item;
+      push @item, $i - 1, $i - 2;
+      push @retval, [@item];
+      $i -= 2;
+   }
+   return \@retval;
+}
+
+# simplified from
+# https://github.polettix.it/ETOOBUSY/2020/07/28/nested-loops-recursive/
+sub nested_loops_recursive {
+   my ($dims, $cb, $accumulator) = @_;
+   $accumulator = [] unless defined $accumulator;
+   my $level = @{$accumulator};
+   if ($level == @{$dims}) { # fire callback!
+      $cb->(@{$accumulator});
+      return;
+   }
+   for my $item (@{$dims->[$level]}) {
+      push @{$accumulator}, $item;
+      nested_loops_recursive($dims, $cb, $accumulator);
+      pop @{$accumulator};
+   }
+   return;
+}
diff --git a/challenge-077/polettix/perl/ch-2.1.txt b/challenge-077/polettix/perl/ch-2.1.txt
new file mode 100644
index 0000000000..f6034dc2f3
--- /dev/null
+++ b/challenge-077/polettix/perl/ch-2.1.txt
@@ -0,0 +1,3 @@
+[ O O X ]
+[ X O O ]
+[ X O O ]
diff --git a/challenge-077/polettix/perl/ch-2.2.txt b/challenge-077/polettix/perl/ch-2.2.txt
new file mode 100644
index 0000000000..723198205d
--- /dev/null
+++ b/challenge-077/polettix/perl/ch-2.2.txt
@@ -0,0 +1,4 @@
+[ O O X O ]
+[ X O O O ]
+[ X O O X ]
+[ O X O O ]
diff --git a/challenge-077/polettix/perl/ch-2.pl b/challenge-077/polettix/perl/ch-2.pl
new file mode 100644
index 0000000000..1a87da4d58
--- /dev/null
+++ b/challenge-077/polettix/perl/ch-2.pl
@@ -0,0 +1,96 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use English qw< -no_match_vars >;
+use autodie;
+
+main(@ARGV);
+
+sub main {
+   my ($filename) = @_;
+   my $fh;
+   open $fh, '<', $filename if defined $filename;
+   print {*STDOUT} count_solitaries($fh || \*STDIN), "\n";
+}
+
+# We will keep the "previous" line (initialized with all 'O' chars)
+# and the "current" line. At each iteration, we can complete the count
+# for the previous line and start counting for the current one. The last
+# line will be counted after the loop iterating over the input.
+sub count_solitaries {
+   my ($fh) = @_;
+
+   # this will keep track of the two lines. $lines[0] is the "previous"
+   # and $lines[1] is the "current
+   my @lines;
+
+   # same for counts of items around
+   my @counts;
+
+   # handy variable to initialize counts in each iteration
+   my @zeros;
+
+   # return value
+   my $n_solitaries = 0;
+
+   while (<$fh>) {
+      my @line = split m{\s+}mxs ;
+
+      # some initialization, only done at the first iteration actually
+      if (! @zeros) {
+         @zeros = (0) x @line;
+         @counts = [@zeros];
+         @lines  = [('O') x @line];
+      }
+
+      # now we can put the "current" stuff
+      push @counts, [@zeros];
+      push @lines,  \@line;
+
+      # the actual counting is performed by a "workhorse" function, so that
+      # we can also call it later for the last line
+      $n_solitaries += _count_solitaries(\@lines, \@counts);
+      shift @lines;
+      shift @counts;
+   }
+
+   # we still miss the count for the last line, so we call the workhorse
+   # function once again
+   return $n_solitaries + _count_solitaries(\@lines, \@counts);
+}
+
+# workhorse function, performs one single sweep updating the counts for
+# the previous and the current lines. It returns the number of solitaire
+# items for the previous line, because they're final at this stage.
+sub _count_solitaries {
+   my ($lines, $counts) = @_;
+
+   # in the last call we are only left with the last "previous" line, so
+   # we skip the sweeping part.
+   if (@$lines > 1) {
+      # we avoid the beginning and the ending chars because they are
+      # brackets, so the column index iterator $i starts at 1 and ends
+      # one before the last
+      for my $i (1 .. $#{$lines->[1]} - 1) {
+         # $j iterates over the three column indexes affected by $i
+         for my $j ($i - 1 .. $i + 1) {
+            # this is the previous line affecting the current count
+            $counts->[1][$j]++ if $lines->[0][$i] eq 'X';
+
+            # this is the current line affecting the previous and the
+            # current counts
+            if ($lines->[1][$i] eq 'X') {
+               $counts->[0][$j]++;
+               $counts->[1][$j]++; # self-counting is OK
+            }
+         }
+      }
+   }
+
+   # the previous line/counts are over now, we can count how many
+   # solitaires were there. 'grep' in scalar context returns a count.
+   return scalar grep {
+      $lines->[0][$_] eq 'X' &&  # a solitaire is a 'X' character...
+      $counts->[0][$_] == 1;     # with a 1 count (i.e. only itself)
+   } 1 .. $#{$lines->[0]} - 1;
+}