Merge pull request #7118 from jacoby/master

191 and I guess 190

4 files changed, 187 insertions, 0 deletions

diff --git a/challenge-190/dave-jacoby/perl/ch-1.pl b/challenge-190/dave-jacoby/perl/ch-1.pl
new file mode 100644
index 0000000000..9623b328ba
--- /dev/null
+++ b/challenge-190/dave-jacoby/perl/ch-1.pl
@@ -0,0 +1,22 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use experimental qw{ fc say postderef signatures state };
+
+my @input = qw( Perl TPF PyThon raku);
+
+for my $input (@input) {
+    my $output = capital_detect( $input );
+    say <<"END";
+        Input:  \$s = '$input'
+        Output: $output
+END
+}
+
+sub capital_detect ( $input ) {
+    return 1 if $input eq uc $input;
+    return 1 if $input eq lc $input;
+    return 1 if $input eq ucfirst lc $input;
+    return 0;
+}
diff --git a/challenge-190/dave-jacoby/perl/ch-2.pl b/challenge-190/dave-jacoby/perl/ch-2.pl
new file mode 100644
index 0000000000..f4a52f2e65
--- /dev/null
+++ b/challenge-190/dave-jacoby/perl/ch-2.pl
@@ -0,0 +1,43 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use experimental qw{ say postderef signatures state };
+
+use List::Util qw{ uniq };
+
+my @alphabet = ( '_', 'A' .. 'Z' );
+my %n2a      = map { $_ => $alphabet[$_] } 1 .. 26;
+
+my @input = sort { $a <=> $b } qw( 1115 127 919 212 202 2112 );
+for my $i (@input) {
+    my @list = decoded_list($i);
+    my $list = join ', ', @list;
+    say <<"END";
+    Input:  \$s = $i
+    Output: $list
+END
+}
+
+sub decoded_list ( $input ) {
+    my @output;
+    my @list = _make_list($input);
+OUTER: for my $x (@list) {
+        my @x =  grep { /\d/ } split /\D+/, $x;
+        for my $y (@x) { next OUTER if !$n2a{$y} }
+        push @output, join '', map { $n2a{$_} } @x;
+    }
+    return uniq sort @output;
+}
+
+sub _make_list ( $input, $string = '' ) {
+    if ( $input eq '' ) {
+        return ($string);
+    }
+    my $letter = substr( $input, 0, 1 );
+    substr( $input, 0, 1 ) = '';
+    my @output;
+    push @output, _make_list( $input, $string . $letter );
+    push @output, _make_list( $input, $string . ' ' . $letter );
+    return @output;
+}
diff --git a/challenge-191/dave-jacoby/perl/ch-1.pl b/challenge-191/dave-jacoby/perl/ch-1.pl
new file mode 100644
index 0000000000..1b7728fd0d
--- /dev/null
+++ b/challenge-191/dave-jacoby/perl/ch-1.pl
@@ -0,0 +1,31 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use experimental qw{ fc say postderef signatures state };
+
+my @input =
+    ( [ 1, 2, 3, 4 ], [ 1, 2, 0, 5 ], [ 2, 6, 3, 1 ], [ 4, 5, 2, 3 ] );
+
+for my $i (@input) {
+    my $input  = join ', ', $i->@*;
+    my $output = twice_largest($i);
+    say <<"END";
+        Input:  \$s = ($input)
+        Output: $output
+END
+}
+
+sub twice_largest ( $input ) {
+    my @input = $input->@*;
+    for my $n ( @input ) {
+        my $c = 0;
+        my @array = grep { $_ != $n } @input;
+        for my $o (@array) {
+            next if $o == $n;
+            $c++ if $n >= 2 * $o;
+        }
+        return 1 if $c == 3;
+    }
+    return -1;
+}
diff --git a/challenge-191/dave-jacoby/perl/ch-2.pl b/challenge-191/dave-jacoby/perl/ch-2.pl
new file mode 100644
index 0000000000..52989ce172
--- /dev/null
+++ b/challenge-191/dave-jacoby/perl/ch-2.pl
@@ -0,0 +1,91 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use experimental qw{ say postderef signatures state };
+
+use Algorithm::Permute;
+use List::Util qw{ uniq };
+# use Memoize;
+# memoize('test');
+
+# before Memoize:
+# real    0m30.866s
+# user    0m10.766s
+# sys     0m1.016s
+
+# after Memoize:
+# real    1m28.003s
+# user    0m30.375s
+# sys     0m1.672s
+
+# to check your work: https://oeis.org/A320843
+
+my @input = 1 .. 15;
+for my $i (@input) {
+    my @list = cute_list($i);
+    my $list = join ",\n\t", @list;
+    say <<"END";
+    Input:  \$s = $i
+    Output: $list
+END
+}
+
+sub cute_list ( $input ) {
+    my $n;
+    $n->@* = 1 .. $input;
+    my @output = permute($n);
+    return scalar grep { defined } @output;
+}
+
+# this looks like a job for recursion!
+sub permute ( $remaining, $numbers = [] ) {
+    state $hash;
+    my @output;
+    if ( !scalar $remaining->@* ) {
+
+        # say join ' ', $numbers->@*;
+        return 1;
+    }
+    my $i = 1 + scalar $numbers->@*;
+    for my $r ( $remaining->@* ) {
+        next unless test( $i, $r );
+        my $rremaining->@* = grep { $_ != $r } $remaining->@*;
+        my $nnumbers->@*   = ( $numbers->@*, $r );
+        push @output, permute( $rremaining, $nnumbers );
+    }
+    return @output;
+}
+
+sub test ( $i, $j ) {
+    ( $i, $j ) = sort $i, $j;
+    return 0 == $i % $j || 0 == $j % $i ? 1 : 0;
+}
+
+# the call to pre-existing wheels is great. I hopped on the idea of
+# having Algorithm::Permute take the wheel was powerful, but the problem
+# is that it returns all the choices with no discernable order, so if you
+# know, for example, that a value won't fit in the 2nd position, then you
+# can eliminate every choice with that, turning this from an exponential
+# problem into one that's much more solvable.
+
+# which is to say that this is correct but unneccessarily slow.
+sub cute_list_slow ( $input ) {
+    my @output;
+    my @list = 1 .. $input;
+    my $p    = Algorithm::Permute->new( \@list );
+    while ( my @arr = $p->next ) {
+        my @copy = @arr;
+        unshift @arr, 0;
+        my $c = 0;
+        for my $i ( 1 .. -1 + scalar @arr ) {
+            my $j = $arr[$i];
+            next unless 0 == $i % $j || 0 == $j % $i;
+            $c++;
+        }
+        push @output, join ', ', @copy if $c == $input;
+    }
+    return scalar @output;
+    return map { qq{[$_]} } sort @output;
+}
+