Merge pull request #3936 from drbaggy/master

Push changes for benchmarking and tidyness.

2 files changed, 76 insertions, 52 deletions

diff --git a/challenge-109/james-smith/perl/ch-1.pl b/challenge-109/james-smith/perl/ch-1.pl
index 2c38afe0c4..1b89226a6a 100644
--- a/challenge-109/james-smith/perl/ch-1.pl
+++ b/challenge-109/james-smith/perl/ch-1.pl
@@ -5,18 +5,62 @@ use strict;
 use warnings;
 use feature qw(say);
 use Test::More;
+use Benchmark qw(cmpthese);
 
-my @answer = (9999, 0, 0, 0, 2, 0, 5, 0, 6, 3, 7, 0, 15, 0, 9, 8, 14, 0, 20, 0, 21);
+my @answer = qw(9999
+  0  0  0  2  0  5  0  6  3  7
+  0 15  0  9  8 14  0 20  0 21
+);
 
 
-is( chowla($_), $answer[ $_ ] ) foreach 1..20;
+is( chowla_map($_), $answer[ $_ ] ) foreach 1..20;
+is( chowla_for($_), $answer[ $_ ] ) foreach 1..20;
 
 done_testing();
 
-sub my_function {
-  sub chowla {
-    my ($t,$n) = (0,@_);
-    return ( map { (($n%$_) || ($t+=$_)) && () } 2..$n-1 ), $t;
-  }
+## We will quickly run benchmarking...
+## This suggests the for loop to be approximately 40-50%
+## faster than the map solution...
+## It is also 9 characters shorter...
+
+cmpthese(1_000_000, {
+  'Map' => sub { chowla_map($_) foreach 1..20; },
+  'For' => sub { chowla_for($_) foreach 1..20; },
+});
+
+##
+##        Rate  Map  For
+## Map 38670/s   -- -33%
+## For 57670/s  49%   --
+##
+
+sub chowla_map {
+  my ($t,$n) = (0,@_);
+## First attempt - the one-liner is to write this as a map,
+## we add $t at the end which is the value returned
+  ( map { (($n%$_) || ($t+=$_)) && () } 2..$n-1 ), $t;
+}
+
+sub chowla_for {
+  my($t,$n)=(0,@_);
+
+  ## This time we won't write this as a nasty map/reduce solution...
+  ##
+  ## Just a for loop;
+  ##
+  ## Notes:
+  ##  * To allow for an "unless" in a postfix loop, we rewrite this
+  ##    by noting:
+  ##      unless( $condition ) { fun(); }
+  ##    can be rewritten as:
+  ##      ($condition)||($fun())
+  ##  * in perl `foreach` and `for` are synonymous - so we can shorten
+
+  ($n%$_)||($t+=$_) for 2..$n-1;
+
+  ## Now a quick "shortening" - if there is no specific return
+  ## statement - we can just omit the return in the last statement...
+
+  $t;
 }
 
diff --git a/challenge-109/james-smith/perl/ch-2.pl b/challenge-109/james-smith/perl/ch-2.pl
index efbd9fa75a..436e0fca19 100644
--- a/challenge-109/james-smith/perl/ch-2.pl
+++ b/challenge-109/james-smith/perl/ch-2.pl
@@ -44,12 +44,15 @@ use Test::More;
 
 
 say '';
+say 'Assume uniqueness.....';
+say '';
 sep(); show( four_square( 1..7            ) );
 sep(); show( four_square( -2 .. 4 ) );
 sep(); show( four_square( 1,2,3,4,8,9,10  ) );
 sep(); show( four_square( 12,2,7,4,8,9,10 ) );
 sep();
-
+say '';
+say 'No assumptions other than integer values.....';
 say '';
 sep(); show( four_square_non_unique( 1..7            ) );
 sep(); show( four_square_non_unique( -2 .. 4         ) );
@@ -65,10 +68,6 @@ sub sep  { say '----------------------------------------------------------------
 sub show { say "@{$_}" foreach @{$_[0]}; }
 
 sub four_square {
-  my @n1 = @_;
-  my @res;
-  my $t = 0;
-     $t+=$_ foreach @n1;
 
 ## For a start we make the observation that
 ##
@@ -94,23 +93,16 @@ sub four_square {
 ## to split the next inequality info a exists & delete as we can do this in one..
 ##
 ## We push any valid results to the array
-  foreach my $b ( @n1 ) {
-    foreach my $f ( my @n2 = grep { $_ - $b } @n1 ) {
-      ## next if $b > $f; ### Check for order here so that we can get rid of dupes
-      foreach my $d ( my @n3 = grep { $_ - $f } @n2 ) {
-        my $n = $t + $b + $d + $f;  ### really 4n...
-        next if $n & 3;             ### n must be a whole number
-        $n/=4;
-        my %X = map { $_ => 1 } @n3;
-        delete $X{$d};
-        my $a = $n-$b;
-        next unless defined delete $X{$a};
-        my $g = $n-$f;
-        next unless defined delete $X{$g};
-        my $c = $a-$d;
-        next unless defined delete $X{$c};
-        my $e = $g-$d;
-        next unless exists $X{$e};
+
+  my ($t,@n1,@res) = (0,@_);
+  $t+=$_ foreach @n1;
+  foreach my $b (        @n1 ) {
+    foreach my $f (   my @n2 = grep { $_ != $b } @n1 ) {
+      foreach my $d ( my @n3 = grep { $_ != $f } @n2 ) {
+        next if (my $n = $t+$b+$d+$f) & 3; ## Really 4n, n must be int
+        my %X = map { $_ == $d ? () : ($_ => 1) } @n3;
+        next unless defined delete $X{my $a = $n/4-$b} && defined delete $X{my $g = $n/4-$f};
+        next unless defined delete $X{my $c = $a-$d}   &&         exists $X{my $e = $g-$d};
         push @res, [ $a, $b, $c, $d, $e, $f, $g ];
       }
     }
@@ -119,11 +111,6 @@ sub four_square {
 }
 
 sub four_square_non_unique {
-  my @n1 = @_;
-  my %res;
-  my $t = 0;
-     $t+=$_ foreach @n1;
-
 ## Now let us make no assumption about the numbers...
 ## We choose 3 from the list...
 ## We then compute n (and check for no remainder)
@@ -136,27 +123,20 @@ sub four_square_non_unique {
 ##            will end up with 2 entries in the list
 ##            where you swap the equivalent values...
 
-  my $check = "@{[ sort @n1 ]}";
+  my ($t,$check,@n1,%res) = (0,"@{[sort @_]}",@_);
+  $t+=$_ foreach @n1;
   foreach my $i ( 0..@n1-1 ) {
-    my $b = $n1[$i];
-    my @n2 = map { $_ == $i ? () : $n1[$_] } 0..@n1-1;
+    my @n2 = @n1;
+    my $b = splice @n2,$i,1;
     foreach my $j ( 0..@n2-1 ) {
-      my $f  = $n2[$j];
-      my @n3 = map { $_ == $i ? () : $n2[$_] } 0..@n2-1;
+      my @n3 = @n2;
+      my $f = splice @n3,$j,1;
       foreach my $k ( 0..@n3-1 ) {
-        my $d = $n3[$k];
-        my $n = $t + $b + $d + $f;
-        next if $n & 3;
-        $n/=4;
-        my $a = $n-$b;
-        my $g = $n-$f;
-        my $c = $a-$d;
-        my $e = $g-$d;
-        my $val =  "@{[ sort $a,$b,$c,$d,$e,$f,$g ]}";
-        next unless $check eq $val;
-        my $key =  "@{[ $a,$b,$c,$d,$e,$f,$g ]}";
-        next if exists $res{$key};
-        $res{$key} = [ $a, $b, $c, $d, $e, $f, $g ];
+        next if (my $n = $t + $b + (my $d = $n3[$k]) + $f) & 3;
+        my @R = ($n/4-$b,$b,$n/4-$b-$d,$d,$n/4-$f-$d,$f,$n/4-$f);
+        next if exists $res{ my $key = "@R" };
+        next if $check ne "@{[ sort @R ]}";
+        $res{$key} = \@R;
       }
     }
   }