3 files changed, 154 insertions, 0 deletions
diff --git a/challenge-055/dave-jacoby/perl/ch-1.pl b/challenge-055/dave-jacoby/perl/ch-1.pl
new file mode 100755
index 0000000000..8fcebc4e69
--- /dev/null
+++ b/challenge-055/dave-jacoby/perl/ch-1.pl
@@ -0,0 +1,36 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use utf8;
+use feature qw{ fc postderef say signatures state switch };
+no warnings qw{ experimental };
+
+use List::Util qw{ sum0 max };
+
+my $bin  = '010';
+
+my $length = -1 + length $bin;
+my $record;
+
+for my $l ( 0 .. $length ) {
+    for my $r ( $l .. $length ) {
+        my $flipped = flip( $bin, $l, $r );
+        my $sum     = sum0( split //, $flipped );
+        push $record->{$sum}->@*, [ $sum, $l, $r, $flipped ];
+    }
+}
+say qq{Base: $bin};
+say join ' ', qw{ I L R String };
+say '=' x 12;
+for my $bin ( map { $record->{$_}->@* } max keys $record->%* ) {
+    say join ' ', map { $bin->[$_] } 0 .. 3;
+}
+
+sub flip ( $bin, $l, $r ) {
+    for my $n ( $l .. $r ) {
+        substr( $bin, $n, 1 ) = int !substr( $bin, $n, 1 );
+    }
+    return $bin;
+}
+
diff --git a/challenge-055/dave-jacoby/perl/ch-2.pl b/challenge-055/dave-jacoby/perl/ch-2.pl
new file mode 100755
index 0000000000..acf597da41
--- /dev/null
+++ b/challenge-055/dave-jacoby/perl/ch-2.pl
@@ -0,0 +1,60 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use utf8;
+use feature qw{ postderef say signatures state switch };
+no warnings qw{ experimental };
+
+for my $n ( 1 .. 4 ) {
+    for my $arr ( permute_array( [ 1 .. $n ] ) ) {
+        say display($arr) if waves($arr);
+    }
+}
+
+exit;
+
+# Arrayrefs because ease of use.
+# Experimental signatures for the same reason.
+# Using $bitflip = 1 allows me to ignore that
+# for the original call and have the function
+# handle it for the rest.
+# !$bool gives you 1 or '', so to force to 1 or 0
+# we cast as int.
+
+# bitflip 1 means >=
+# bitflip 0 means <=
+
+sub waves ( $array, $bitflip = 1 ) {
+    if ( scalar $array->@* == 1 )                 { return 1 }
+    if ( $bitflip && $array->[0] < $array->[1] )  { return 0 }
+    if ( !$bitflip && $array->[0] > $array->[1] ) { return 0 }
+    my $array2->@* = map { $_ } $array->@*;
+    shift $array2->@*;
+    return waves( $array2, int !$bitflip );
+    return 1;
+}
+
+# display behaves much the same as waves
+
+sub display ( $array, $bitflip = 1 ) {
+    if ( scalar $array->@* == 1 ) { return $array->[0] }
+    my $sign       = $bitflip ? '>=' : '<=';
+    my $array2->@* = map { $_ } $array->@*;
+    my $n          = shift $array2->@*;
+    return qq{$n $sign } . display( $array2, int !$bitflip );
+}
+
+# Return of the permute_array function! Recursion!
+sub permute_array ( $array ) {
+    return $array if scalar $array->@* == 1;
+    my @response = map {
+        my $i        = $_;
+        my $d        = $array->[$i];
+        my $copy->@* = $array->@*;
+        splice $copy->@*, $i, 1;
+        my @out = map { unshift $_->@*, $d; $_ } permute_array($copy);
+        @out
+    } 0 .. scalar $array->@* - 1;
+    return @response;
+}
diff --git a/challenge-055/dave-jacoby/perl/ch-2b.pl b/challenge-055/dave-jacoby/perl/ch-2b.pl
new file mode 100755
index 0000000000..3ac5a32b29
--- /dev/null
+++ b/challenge-055/dave-jacoby/perl/ch-2b.pl
@@ -0,0 +1,58 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use utf8;
+use feature qw{ postderef say signatures state switch };
+no warnings qw{ experimental };
+
+for my $n ( 1 .. 4 ) {
+    for my $arr ( permute_array( [ 1 .. $n ] ) ) {
+        say display($arr) if waves($arr);
+    }
+}
+
+exit;
+
+# iterative solution
+sub waves ( $array ) {
+    my $copy->@* = map { $_ } $array->@*;
+    my $bitflip = 1;
+    my @output;
+    while ( scalar $copy->@* > 1 ) {
+        if ( $bitflip  && $copy->[0] < $copy->[1] ) { return 0 }
+        if ( !$bitflip && $copy->[0] > $copy->[1] ) { return 0 }
+        shift $copy->@*;
+        $bitflip = int !$bitflip;
+    }
+    return 1;
+}
+
+# iterative solution
+sub display ( $array ) {
+    my $copy->@* = map { $_ } $array->@*;
+    my $bitflip  = 1;
+    my $output   = '';
+    while ( scalar $copy->@* > 1 ) {
+        my $sign = $bitflip ? '>=' : '<=';
+        $output .= shift $copy->@*;
+        $output .= qq{ $sign };
+        $bitflip = int !$bitflip;
+    }
+    $output .= shift $copy->@*;
+    return $output;
+}
+
+# Return of the permute_array function! Recursion!
+sub permute_array ( $array ) { 
+    return $array if scalar $array->@* == 1;
+    my @response = map {
+        my $i        = $_;
+        my $d        = $array->[$i];
+        my $copy->@* = $array->@*;
+        splice $copy->@*, $i, 1;
+        my @out = map { unshift $_->@*, $d; $_ } permute_array($copy);
+        @out
+    } 0 .. scalar $array->@* - 1;
+    return @response;
+}