Merge pull request #6311 from jacoby/master

170 Done

2 files changed, 100 insertions, 0 deletions

diff --git a/challenge-170/dave-jacoby/perl/ch-1.pl b/challenge-170/dave-jacoby/perl/ch-1.pl
new file mode 100644
index 0000000000..b21ba4224f
--- /dev/null
+++ b/challenge-170/dave-jacoby/perl/ch-1.pl
@@ -0,0 +1,51 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use experimental qw{ say postderef signatures state };
+
+use List::Util qw{ product uniq };
+
+$| = 1;
+map { primorial($_) } 0 .. 9;
+
+sub primorial ( $n ) {
+    my @primes = primes($n);
+    my $primes = join 'x', @primes;
+    my $p      = product @primes;
+    say <<"END";
+        P($n) = $p ($primes)
+END
+}
+
+sub primes ( $i ) {
+    state $primes;
+    $primes->[0] = 1;
+
+    if ( !defined $primes->[$i] ) {
+        my $iter = make_iterator( $primes->[-1] );
+        while ( my $p = $iter->() ) {
+            next unless is_prime($p);
+            push $primes->@*, $p;
+            $primes->@* = uniq $primes->@*;
+            last if defined $primes->[$i];
+        }
+    }
+    return $primes->@[ 0 .. $i ];
+}
+
+sub is_prime ($n) {
+    die "Bad number $n" unless length $n;
+    return 0 if $n == 0;
+    return 0 if $n == 1;
+    for ( 2 .. sqrt $n ) { return 0 unless $n % $_ }
+    return 1;
+}
+
+sub make_iterator($n) {
+    return sub {
+        state $v = $n;
+        return $v++;
+    }
+}
+
diff --git a/challenge-170/dave-jacoby/perl/ch-2.pl b/challenge-170/dave-jacoby/perl/ch-2.pl
new file mode 100644
index 0000000000..bd3d21c103
--- /dev/null
+++ b/challenge-170/dave-jacoby/perl/ch-2.pl
@@ -0,0 +1,49 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use experimental qw{ say postderef signatures state };
+
+my @pairs;
+push @pairs, [ [ [ 1, 2 ], [ 3, 4 ] ], [ [ 5, 6 ], [ 7, 8 ] ], ];
+push @pairs,
+    [
+    [ [ 1, 1, 1 ], [ 2, 2, 2 ], [ 3, 3, 3 ] ],
+    [ [ 7, 8, 9 ], [ 3, 4, 5 ], [ 5, 6, 7 ] ],
+    ];
+push @pairs, [ [ [ 9, 0, 2 ], [ 9, 0, 1 ] ], [ [ 1, 2, 3 ], [ 9, 8, 7 ] ], ];
+
+for my $m (@pairs) {
+    my @matrices = $m->@*;
+    my @out      = kronecker(@matrices);
+    say '';
+    say join "\n", map { join "\t", $_->@* } @out;
+    say '';
+}
+
+exit;
+
+sub kronecker ( $ma, $mb ) {
+    my @output;
+    my $ax = -1 + scalar $ma->@*;
+    my $ay = -1 + scalar $ma->[0]->@*;
+    my $bx = -1 + scalar $mb->@*;
+    my $by = -1 + scalar $mb->[0]->@*;
+
+    for my $x1 ( 0 .. $ax ) {
+        for my $x2 ( 0 .. $bx ) {
+            my $x = ( 1 + $bx ) * $x1 + $x2;
+            for my $y1 ( 0 .. $ay ) {
+                for my $y2 ( 0 .. $by ) {
+                    my $y  = ( 1 + $by ) * $y1 + $y2;
+                    my $v1 = $ma->[$x1][$y1];
+                    my $v2 = $mb->[$x2][$y2];
+                    my $v  = $v1 * $v2;
+                    $output[$x][$y] = $v;
+                }
+            }
+        }
+    }
+
+    return @output;
+}