Merge pull request #2269 from ccntrq/challenge-077

Challenge 077

2 files changed, 161 insertions, 0 deletions

diff --git a/challenge-077/alexander-pankoff/perl/ch-1.pl b/challenge-077/alexander-pankoff/perl/ch-1.pl
new file mode 100644
index 0000000000..7f4c798667
--- /dev/null
+++ b/challenge-077/alexander-pankoff/perl/ch-1.pl
@@ -0,0 +1,70 @@
+#!/usr/bin/env perl
+use v5.20;
+use utf8;
+use strict;
+use warnings;
+use autodie;
+use feature qw(say signatures);
+no warnings 'experimental::signatures';
+
+use List::Util qw(reduce sum0);
+
+# You are given a positive integer $N.
+#
+# Write a script to find out all possible combination of Fibonacci Numbers required to get $N on addition.
+#
+# You are NOT allowed to repeat a number. Print 0 if none found.
+
+my ($N) = @ARGV;
+
+my @combinations = possible_fibonacci_combinations($N);
+
+my $out =
+  @combinations
+  ? join( "\n", map { join( " + ", @$_ ) . ' = ' . $N } @combinations )
+  : '0';
+
+say $out;
+
+sub possible_fibonacci_combinations($n) {
+    my @fibs = fibs_up_to($n);
+    return grep { sum0(@$_) == $n } subsequences(@fibs);
+}
+
+# returns the sequence of fibbonacci numbers smaller or equal to $n
+sub fibs_up_to($n) {
+    take_while( sub { $_[0] < $n }, mk_fib_gen() );
+}
+
+# returns a generator for the fibbonacci sequence.
+# Note: The generated sequence will start at Fib(2)=1.
+#       Fib(0) = 0 and Fib(1) = 1 are skipped
+sub mk_fib_gen() {
+    sub() {
+        state $second_to_last = 0;
+        state $last           = 1;
+
+        my $fib = $last + $second_to_last;
+        $second_to_last = $last;
+        $last           = $fib;
+
+        return $fib;
+      }
+}
+
+# given a list this will return all non empty subsequences
+sub subsequences(@list) {
+    return unless @list;
+    my ( $head, @rest ) = @list;
+    return [$head] unless @rest;
+
+    my $other = reduce { [ $b, [ $head, @$b ], @$a ] }[ [$head] ],
+      subsequences(@rest);
+    return @$other;
+}
+
+# repeatedly run $generator to generate a sequence of results where $cond holds
+sub take_while ( $cond, $generator ) {
+    my $x = $generator->();
+    return $cond->($x) ? ( $x, take_while( $cond, $generator ) ) : ();
+}
diff --git a/challenge-077/alexander-pankoff/perl/ch-2.pl b/challenge-077/alexander-pankoff/perl/ch-2.pl
new file mode 100644
index 0000000000..f2a43994cc
--- /dev/null
+++ b/challenge-077/alexander-pankoff/perl/ch-2.pl
@@ -0,0 +1,91 @@
+#!/usr/bin/env perl
+use v5.20;
+use utf8;
+use strict;
+use warnings;
+use autodie;
+use feature qw(say signatures);
+no warnings 'experimental::signatures';
+
+use List::Util qw(
+  all
+  any
+  max
+  min
+);
+
+# You are given m x n character matrix consists of O and X only.
+#
+# Write a script to count the total number of X surrounded by O only. Print 0 if none found.
+
+my ($file) = @ARGV;
+
+my $fh;
+if ($file) {
+    open( $fh, '<', $file );
+}
+else {
+    $fh = *STDIN;
+}
+
+my $matrix      = parse_input($fh);
+my @lonely_xses = lonely_xses($matrix);
+
+say scalar @lonely_xses;
+if ( $ENV{DEBUG} ) {
+    say "Lonely X found at Row "
+      . ( $_->[0] + 1 ) . ' Col '
+      . ( $_->[1] + 1 ) . '.'
+      for @lonely_xses;
+}
+
+exit 0;
+
+sub lonely_xses($matrix) {
+    return grep {
+        all { $matrix->[ $_->[0] ][ $_->[1] ] eq 'O' } neighbors( $matrix, $_ );
+    } x_positions($matrix);
+
+}
+
+sub x_positions($matrix) {
+    return
+      grep { $matrix->[ $_->[0] ][ $_->[1] ] eq 'X' }
+      combinations( [ 0 .. $#{$matrix} ], [ 0 .. $#{ $matrix->[0] } ] );
+}
+
+sub neighbors ( $matrix, $pos ) {
+    my ( $row, $col ) = @$pos;
+    my @neighbor_rows =
+      ( max( 0, $row - 1 ) .. min( $row + 1, $#{$matrix} ) );
+    my @neighbor_cols =
+      ( max( 0, $col - 1 ) .. min( $col + 1, $#{ $matrix->[0] } ) );
+
+    grep { $_->[0] != $row || $_->[1] != $col }
+      combinations( \@neighbor_rows, \@neighbor_cols );
+}
+
+sub combinations ( $a, $b ) {
+    map {
+        my $x = $_;
+        map { [ $x, $_ ] } @$b;
+    } @$a;
+}
+
+sub parse_input($fh) {
+    chomp( my @lines = <$fh> );
+    my $length;
+    my @rows = map {
+        my $line = $_;
+        return () if $line !~ m/\S/;
+        $line =~ m/^\s*\[\s*(.*?)\s*\]\s*$/;
+        die "cannot parse $line" unless $1;
+        my @os_and_xses = split( /\s+/, $1 );
+        die "invalid input in $line" if any { $_ ne 'O' && $_ ne 'X' } @os_and_xses;
+        $length //= @os_and_xses;
+        die "column count not uniform" unless @os_and_xses == $length;
+        \@os_and_xses;
+    } @lines;
+
+    return \@rows;
+}