Merge pull request #7099 from drbaggy/master

unfutzed I hope

4 files changed, 445 insertions, 95 deletions

diff --git a/challenge-191/james-smith/README.md b/challenge-191/james-smith/README.md
index 53c824322d..6aa5575439 100644
--- a/challenge-191/james-smith/README.md
+++ b/challenge-191/james-smith/README.md
@@ -1,7 +1,7 @@
-[< Previous 188](https://github.com/drbaggy/perlweeklychallenge-club/tree/master/challenge-188/james-smith) |
-[Next 190 >](https://github.com/drbaggy/perlweeklychallenge-club/tree/master/challenge-190/james-smith)
+[< Previous 189](https://github.com/drbaggy/perlweeklychallenge-club/tree/master/challenge-189/james-smith) |
+[Next 191 >](https://github.com/drbaggy/perlweeklychallenge-club/tree/master/challenge-191/james-smith)
 
-# The Weekly Challenge 189
+# The Weekly Challenge 190
 
 You can find more information about this weeks, and previous weeks challenges at:
 
@@ -13,136 +13,235 @@ submit solutions in whichever language you feel comfortable with.
 
 You can find the solutions here on github at:
 
-https://github.com/drbaggy/perlweeklychallenge-club/tree/master/challenge-189/james-smith
+https://github.com/drbaggy/perlweeklychallenge-club/tree/master/challenge-190/james-smith
 
-# Task 1 - Capital Dectection
+# Task 1 - Twice Largest
 
-***You are given a string with alphabetic characters only: `A..Z` and `a..z`. Write a script to find out if the usage of Capital is appropriate if it satisfies at least one of the following rules:***
+***You are given list of integers, `@list`. Write a script to find out whether the largest item in the list is at least twice as large as each of the other items.***
 
 ## Solution
 
-This is relatively simple - there are two cases:
+We can simplify the condition to that the largest number is at least twice the value of the second largest number.
 
- * a string made entirely of captial letters
- * a string characters two onwards are lower case.
+Our naive approach could be to sort the numbers and check `$list[-1] >= 2*$list[-2]`.
 
-OR we can invert it and say that it does not match if we have either
-
- * a lower case followed by an upper case letter
- * two upper case letters followed by a lower case letter.
-
-It is surprising though how we can apply these rules.
-
- * a single regular expression
- * two regular expressions
+```perl
+sub is_double_sort {
+  sub {$_[0]>=2*$_[1]||-1}->(sort {$b<=>$a} @_)
+}
+```
 
-and even then the two parts can be re-ordered...
+But this isn't efficient if the list is large (but how large is large we will find out later) - instead we will just track the two largest numbers.
 
-I will include just two of those here..
+ * We grab the first two numbers, and store the largest one in $f and the other one in $s.
+ * For each other number ($_):
+   * $_ <= $s - ignore do nothing
+   * $s < $_ && $_ <= $f - replace 2nd number $s with $_
+   * $f < $_ - replace 2nd number $s with $f, and replace $f with $_
+ * Return is based on whether `$f >= 2*$s`
 
 ```perl
-## Positive - two regexs
-sub capital_split { $_[0] =~ m{^[a-zA-Z][a-z]*$} || $_[0] =~ m{^[A-Z]+$} ? 1 : 0 }
-## Negatice - one regex
-sub capital_neg1  { $_[0] =~ m{(?:[a-z][A-Z]|[A-Z]{2}[a-z])}             ? 0 : 1 }
+sub is_double {
+  my( $f, $s ) = ( shift, shift );           # First two numbers
+  ( $f, $s ) = ( $s, $f ) if $f < $s;        # Switch if 1st < 2nd
+  $_>$f ? ( ( $f, $s ) = ( $_, $f ) )        # For each number
+        : ( $_ > $s && ( $s = $_ ) ) for @_; #   if > 1st
+                                             #     demote 1st to 2nd
+                                             #     replace 1st
+                                             #   if > 2nd
+                                             #     demote 2nd
+  $f >= 2*$s ? 1 : -1                        # Check condition
+}
 ```
 
-Using real world text - 90%+ lowercase / capitalised lowercase - gives the positive method as the fastest AND splitting the regular expression into two separate parts with the lowercase expression first gives best performance.
+### How large is large
 
-# Task 2 - Decoded list
+Some experiments with a longer and longer list seem to indicate that the breakeven point is about 200 - so sorting lists of less than 200 numbers is more efficient than the perl above, but over 200 the max strategy is best...
 
-***You are given an encoded string consisting of a sequence of numeric characters: 0..9, $s.  Write a script to find the all valid different decodings in sorted order.  Encoding is simply done by mapping A,B,C,D,... to 1,2,3,4,... etc.
+# Task 2 - Cute List
 
-## Solution
+***You are given an integer, `0 < $n <= 15`. Write a script to find the number of orderings of numbers that form a cute list.***
 
-This one as a much more interesting challenge. A first pass gives us a recursive solution.
+***With an input `@list = (1, 2, 3, .. $n)` for positive integer `$n`, an ordering of `@list` is cute if for every entry, indexed with a base of 1, either:***
 
- * If the first characters is between 1 and 9 we decode to A to I and then work out the encodings for the remainder of the string...
- * If the first character is 1 OR the first character is 2 and the second between 0 and 6 then we encode to J to Z and then find all the codings for the rest of the string... 
+ * ***`$list[$i]` is evenly divisible by `$i`***
+ * ***`$i` is evenly divisible by `$list[$i]`***
 
-This gives:
+## Solution
 
-```perl
-sub decoded_rec {
-  return $_[0] eq '' ? '' : $_[0] eq '0' ? () : chr(64 + $_[0]) if 2 > length $_[0];
-  my($f,$s,$r) = split m{}, $_[0], 3;
-  $r ||= '';
-  ( $f      && $s                ? ( map { chr(           $f + 64 ) . $_ } decoded_rec($s.$r) ) : (),
-    $f == 1 || $f == 2 && $s < 7 ? ( map { chr( $f * 10 + $s + 64 ) . $_ } decoded_rec($r   ) ) : () );
-}
-```
+Again this weeks task 2 is a much more interesting challenge. And has a number of different approaches we can find.
 
-We get the first & second characters by splitting the string into characters. We use the three parameter version of split which limits the number of pieces the string is split into.
+ * Do we use recursion - or - interation?
+ * Do we memoize or not? if so what key do we use?
+ * Are there any simple optimizations - how to make the loop fail earlier?
 
-## Every recursive solution can be converted into an iterative solution....
+Firstly - we could use permutations - but this screams out initially at least for recursion.
 
-People say you can take any recursive solution and convert to an iterative solution. This is perfectly true - but often to do it we have to jump through hoops.
+Before we start some observations:
 
-Our first challenge is to enumerate the solutions.
+ * We can pre-compute which numbers can be at which position to give us an array like:
 
-The initial thought is that at each stage we have two decisions - choose one letter or choose two letters. So we can think of this a purely binary.
+   * `[1,2,3,4,5,6,7]`, `[1,2,4,6]`, `[1,3,6]`, `[1,2,4]`, `[1,5]`, `[1,2,3,6]`, `[1,7]`
 
-From `0 .. 2^(n-1)-1` we use a bit mask to chose whether to chose one or two digits. Until we get to the end of the string.
+ * When we search we can re-order the lists to fill in numbers from the short lists first
 
-```perl
-sub decoded_nonrec {
-  my @res;
-  O: for my $s ( 0 .. 1 << length $_[0]-1 ) {
-    my($n,$res,$x) = ($_[0],'');
-    while($n) {
-      #warn "** $n";
-        $s & 1  ? ( ($x = substr $n,0,1,'') eq '0' ? (next O) : ($res .= chr $x + 64) )
-      : $n < 10 ? (next O)
-      :           ( ($x = substr $n,0,2,'') < 10 || $x > 26 ? (next O) : ($res .= chr $x + 64) );
-      $s>>=1, $n eq '' && ( $s ? next O : last );
-    }
-    unshift @res, $res;
-  }
-  sort @res
-}
-```
+   * `[1,5]`, `[1,7]`, `[1,3,6]`, `[1,2,4]`, `[1,2,4,6]`, `[1,2,3,6]`, `[1,2,3,4,5,6,7]`
 
-Now this is much worse than the recursive solution? Why? Well for a lot of the routes we get to the end of the string before we have looped through all the *bits* of the index - because we shift off two digits on many occassions. So? how can we improve?
+ * As a bonus - this reduces the search space further as the last list will ALWAYS contain
+   a valid digit. So we always know that will return a single value. This allows us the
+   shortenings (#1 & #10)
 
-Well first we note that the number of solutions for n digits is the sum of the number of solutions for n-1 & n-2 digits. This sequence is just the Fibonacci sequence.
+ * Our keys are all integers and less than 64. We can therefore use a bit mask as the keys
+   for the cache... {#9 & #11)
 
-Firstly this indicates why we are much slower than the first solution.. The number of valid loops is `f(n-1)/2^n-1` which for 10 digits is approximately 10% of those tried...
+   Already placed `2`, `4`, `7` they key would be `10010100`
 
-So we then look to see if we can use the fibonnaci sequence to help decode the strings...
+ * Using a cache can greatly reduce the number of calls (at the expense of memory) see
+   #0 & #7. Note we use the `//=` operator here rather than the '||=' as a 0 value
+   being cached is as important as a non-zero value and `//=` is a defined check
+   rather than a check for true {which `0` would faile}
 
-For a given index from `0 .. fib(n)-1` we look to see if the number is below `fib(n-1)` if it is we chose 1 digit o/w we choose 2. In the later case we reduce the index by `fib(n-1)` we repeate this for `n-2` etc....
+ * #2, #3 & #4 use a similar {but sort of inverted logic} to a schwartzian transform,
+   which we carry over a variable which is important for the sort as a value in an
+   array ref only to throw it away with an extra `map`.
 
-We have some cases where we can speed performance up, e.g. if we find a `0` we know for the next `fib(k)` they will always fail so we can jump ahead. The same goes for two digits if we get a value of more than 26.
+ * #8 - we steal `sum0` from `List::Util` but we could equally write our own - to
+   avoid the library `sub sum0 { my $t=0; $t+=$_ for @_; $t }`
 
-This gives us the following code... Note we iterate backwards and `unshift` rather than forwards and `push`...
+These observations lead us to the following code...
 
 ```perl
-sub decoded_nonrec_fib {
-  my($s,$l,@res,$t,$k,$n,$res,$x) = ( $fib[length $_[0]], length $_[0] );
-  O: for (;$s>0;) {
-    ($t,$k,$n,$res) = ($s,$l,$_[0],'');
-    while( $n ) {
-      $t <= $fib[--$k]
-    ? (
-        ($x = substr $n,0,1,'') ? ($res.=chr $x+64) : ($s-=$fib[$k+1],next O)
-      )
-    : $n < 10 ? ($s-=$fib[$k+1],next O)
-    : ( ($x = 0+substr $n,0,2,'') < 10 || $x > 26 ? ($s-=$fib[$k-1],next O) : ($t-=$fib[$k],$res .= chr $x + 64,$k--) );
-    }
-    $s--;
-    unshift @res, $res;
-  }
-  @res
+my %cache;
+
+sub cute {
+    ## (0) Clear cache...
+  %cache=();
+    ## (1) If n is 1 short cut and return 1
+  $_[0]==1 ? 1 : _cute_count( 0,
+      ## (2) Just keep the lists
+    map  { $_->[1] }
+      ## (3) Sort so the shortest lists are first - then sort by integer
+    sort { @{$a->[1]} <=> @{$b->[1]} ||
+             $a->[0]  <=>   $b->[0]
+         }
+      ## (4) Find all values between 1 & n which are either a factor or
+      ##     multiple. Store each as pair, of the number + all values.
+    map  {[ ($a=$_), [
+           grep { !( $_%$a && $a%$_ ) } 1 .. $_[0]
+         ] ]}
+      ## (5) Looping over 1 to n
+         1 .. $_[0]
+  )
 }
-```
-
-## Performance
 
-Using the recursive routine as the benchmark. The `2^n` iterative solution is much less efficient - for the test set I'm using with 10 digit numbers it is about 10% efficient (as given by the ration of fibonacci number to 2^n) - the fibonacci approach gives us an efficieny of out 95%...
+sub _cute_count {
+  ## (6) We shift of the index number of seen numbers
+  ##     and also the next group of possible numbers...
+  my( $seen, $next ) = ( shift, shift );
+    ## (7) If we have already computed the value return...
+    ## (8) otherwise we loop over the values possible in the
+    ##     "nth" position (this is loose as they aren't ordered directly)
+    ##     by " but by the count {we are only counting so don't need to
+    ##     produce numbers}
+  $cache{$seen} //= sum0 map {
+    ## (9) We sum up the value for each value in this list which hasn't
+    ##     been seen (and return it!)
+      ($seen & 1<<$_) ? 0
+    ## (10) If there is only 1 number left in the list we count 1
+    ##     (as all numbers can be in the last position)
+    : @_ < 2          ? 1
+    ## (11) o/w we call this method again after knocking out the number
+    :                   _cute_count( $seen | 1<<$_ , @_ )
+  } @{$next}
+}
+    ## Note we don't use a string as a key - but use a bit mast -
+    ## #9 & #11 using "|" to set a bit & "&" to check it has
+    ## been set.
+```
 
-So I believe recursion wins out - I would say that if the number became very large - the fibonacci approach may eventually win out - because with all iterative (indexed) solutions you can stream the valid words and not have the recursion overhead.
+or without comments:
 
-***Note:** Just tested this theory on my small (1G RAM) test box:*
+```perl
+sub cute {
+  %cache=();
+  $_[0]==1 ? 1 : _cute_count( 0,
+    map  { $_->[1] }
+    sort { @{$a->[1]} <=> @{$b->[1]} ||
+             $a->[0]  <=>   $b->[0]
+         }
+    map  {[ ($a=$_), [
+           grep { !( $_%$a && $a%$_ ) } 1 .. $_[0]
+         ] ]}
+         1 .. $_[0]
+  )
+}
 
- * For 30 x "1" - recursion takes around 14 seconds vs 21 seconds for the fibonacci approach
- * For 33 x "1" - the finonacci approach takes 66 seconds [ on par with the approx 1.6x time increase per number ] vs around 320 seconds for the recursive approach.
+sub _cute_count {
+  my( $seen, $next ) = ( shift, shift );
+  $cache{$seen} //= sum0 map {
+      ($seen & 1<<$_) ? 0
+    : @_ < 2          ? 1
+    :                   _cute_count( $seen | 1<<$_ , @_ )
+  } @{$next}
+}
+```
+### Performance
+
+We compared this algorithm with various ones with ordering and without we have the following timings:
+
+| Method                      | Rate    | Gain |
+| :-------------------------- | ------: | ---: |
+| No-cache, no-ordering trick |  1.19/s |      |
+| No-cache, ordering trick    |  7.29/s |   6x |
+| Cache, no-ordering trick    |  17.4/s |  15x |
+| Cache, ordering trick       |  97.0/s |  80x |
+
+The difference expands rapdily as N increases - for `n=20` the optimal solution takes around 0.162 seconds - where the non-optimal solution 96, for an approximately `600x` speed up - this is approx `12x` for the ordering trick & `50x` for the cacheing.
+
+### Timings for increasing `$N`
+
+The original challenge asked us to compute values up to `n=15` - the cumulative time for this is between 1.05 and 1.30 seconds. We can continue on to `n=30` taking around 19 seconds.
+
+The script finally crashes after `n=39` (with a count of around 5.5 trillion) - when the cache memory usage exceeds 7GBytes (the capacity of the machine) and starts to swap. {Note although this machine has more memory it also has a slower processor - so the times are approximately 30% longer than on the box used for the timings above}
+
+| ind |             Count | Time loop  | Cumul time |
+| --: | ----------------: | ---------: | ---------: |
+|   1 |                 1 |   0.000010 |   0.000011 |
+|   2 |                 2 |   0.000018 |   0.000076 |
+|   3 |                 3 |   0.000016 |   0.000105 |
+|   4 |                 8 |   0.000022 |   0.000136 |
+|   5 |                10 |   0.000028 |   0.000175 |
+|   6 |                36 |   0.000067 |   0.000251 |
+|   7 |                41 |   0.000085 |   0.000346 |
+|   8 |               132 |   0.000177 |   0.000533 |
+|   9 |               250 |   0.000241 |   0.000790 |
+|  10 |               700 |   0.000493 |   0.001299 |
+|  11 |               750 |   0.000601 |   0.001916 |
+|  12 |             4,010 |   0.001535 |   0.003466 |
+|  13 |             4,237 |   0.001722 |   0.005206 |
+|  14 |            10,680 |   0.002893 |   0.008116 |
+|  15 |            24,679 |   0.005721 |   0.013854 |
+|  16 |            87,328 |   0.009010 |   0.022884 |
+|  17 |            90,478 |   0.010208 |   0.033113 |
+|  18 |           435,812 |   0.020486 |   0.053620 |
+|  19 |           449,586 |   0.023270 |   0.076913 |
+|  20 |         1,939,684 |   0.078741 |   0.155676 |
+|  21 |         3,853,278 |   0.125847 |   0.281549 |
+|  22 |         8,650,900 |   0.173449 |   0.455045 |
+|  23 |         8,840,110 |   0.224917 |   0.680006 |
+|  24 |        60,035,322 |   0.359825 |   1.039877 |
+|  25 |        80,605,209 |   0.511679 |   1.551599 |
+|  26 |       177,211,024 |   0.663506 |   2.215148 |
+|  27 |       368,759,752 |   1.033414 |   3.248616 |
+|  28 |     1,380,348,224 |   2.533999 |   5.782659 |
+|  29 |     1,401,414,640 |   2.951694 |   8.734403 |
+|  30 |     8,892,787,136 |  10.241124 |  18.975582 |
+|  31 |     9,014,369,784 |  11.076978 |  30.052606 |
+|  32 |    33,923,638,848 |  13.505877 |  43.558524 |
+|  33 |    59,455,553,072 |  20.499038 |  64.057609 |
+|  34 |   126,536,289,568 |  23.903329 |  87.960986 |
+|  35 |   207,587,882,368 |  57.064045 | 145.025074 |
+|  36 | 1,495,526,775,088 |  99.565625 | 244.590748 |
+|  37 | 1,510,769,105,288 | 109.442520 | 354.033321 |
+|  38 | 3,187,980,614,208 | 134.032712 | 488.066089 |
+|  39 | 5,415,462,995,568 | 175.846131 | 663.912274 |
diff --git a/challenge-191/james-smith/blog.txt b/challenge-191/james-smith/blog.txt
new file mode 100644
index 0000000000..20f7375119
--- /dev/null
+++ b/challenge-191/james-smith/blog.txt
@@ -0,0 +1 @@
+https://github.com/drbaggy/perlweeklychallenge-club/tree/master/challenge-191/james-smith
diff --git a/challenge-191/james-smith/perl/ch-1.pl b/challenge-191/james-smith/perl/ch-1.pl
new file mode 100644
index 0000000000..a088573409
--- /dev/null
+++ b/challenge-191/james-smith/perl/ch-1.pl
@@ -0,0 +1,69 @@
+#!/usr/local/bin/perl
+
+use strict;
+
+use warnings;
+use feature qw(say);
+use Test::More;
+use Benchmark qw(cmpthese timethis);
+use Data::Dumper qw(Dumper);
+
+my $N = 200_000;
+
+my @Q = qw( 55    5   50  100   58   32   24   86   88   28   82   72   19   35   34   38   53   73   96   31   37   74   75   83   23   22   81   61   49   59    7   33   80   20   43   90   98    6    8   57   70   47   36   92   21    1   67   63   27   42    2   52   62   95   99   91   10   84    9   39   85   79   16   46   97   15   87   78   77   25   54   12   13   64   94   48   17   51   26   45   66   18   11   56   29   65   40   60   76   69   14    4   44   41   68   30   89    3   93   71
+);
+#print join ', ', map { rand <=> rand } 1..100; exit;
+
+my @TESTS = (  [
+ [ [1,2,3,4], -1 ],
+ [ [1,2,0,5],  1 ],
+ [ [2,6,3,1],  1 ],
+ [ [4,5,2,3], -1 ],
+],
+[
+ [ [1,2,3,4,1,2,3,4], -1 ],
+ [ [1,2,0,5,1,2,0,1],  1 ],
+ [ [2,6,3,1,2,3,3,1],  1 ],
+ [ [4,5,2,3,4,5,2,3], -1 ],
+],
+[
+  [ [@Q,200],  1 ],
+  [ [@Q,199], -1 ],
+],
+[
+  [ [@Q,@Q,200],  1 ],
+  [ [@Q,@Q,199], -1 ],
+],
+[
+  [ [@Q,@Q,@Q,@Q,200],  1 ],
+  [ [@Q,@Q,@Q,@Q,199], -1 ],
+],
+);
+
+for my $T ( @TESTS ) {
+  is( is_double( @{$_->[0]} ), $_->[1] ) for @{$T};
+  is( is_double_sort( @{$_->[0]} ), $_->[1] ) for @{$T};
+}
+done_testing();
+for my $T ( @TESTS ) {
+  cmpthese( -1, {
+    'max'  => sub { is_double(     @{$_->[0]}) for @{$T} },
+    'sort' => sub { is_double_sort(@{$_->[0]}) for @{$T} },
+  });
+}
+
+sub is_double {
+  my( $f, $s ) = ( shift, shift );           # First two numbers
+  ( $f, $s ) = ( $s, $f ) if $f < $s;        # Switch if 1st < 2nd
+  $_>$f ? ( ( $f, $s ) = ( $_, $f ) )        # For each number
+        : ( $_ > $s && ( $s = $_ ) ) for @_; #   if > 1st
+                                             #     demote 1st to 2nd
+                                             #     replace 1st
+                                             #   if > 2nd
+                                             #     demote 2nd
+  $f >= 2*$s|| -1                            # Check condition
+}
+
+sub is_double_sort {
+  sub {$_[0]>=2*$_[1]||-1}->(sort {$b<=>$a} @_)
+}
diff --git a/challenge-191/james-smith/perl/ch-2.pl b/challenge-191/james-smith/perl/ch-2.pl
new file mode 100644
index 0000000000..e2b47e0d1c
--- /dev/null
+++ b/challenge-191/james-smith/perl/ch-2.pl
@@ -0,0 +1,181 @@
+#!/usr/local/bin/perl
+
+use strict;
+
+use warnings;
+use feature qw(say);
+use Test::More;
+use Benchmark qw(cmpthese timethis);
+use Data::Dumper qw(Dumper);
+use List::Util qw(sum0);
+use Time::HiRes qw(time);
+
+my %cache;
+my @RES = (0,
+                  1,                 2,                 3,                 8,              10, # 1- 5
+                 36,                41,               132,               250,             700, # 6-10
+                750,             4_010,             4_237,            10_680,          24_679, #11-15
+             87_328,            90_478,           435_812,           449_586,       1_939_684, #16-20
+          3_853_278,         8_650_900,         8_840_110,        60_035_322,      80_605_209, #21-25
+        177_211_024,       368_759_752,     1_380_348_224,     1_401_414_640,   8_892_787_136, #26-30
+      9_014_369_784,    33_923_638_848,    59_455_553_072,   126_536_289_568, 207_587_882_368, #31-35
+  1_495_526_775_088, 1_510_769_105_288, 3_187_980_614_208, 5_415_462_995_568,                  #36-39
+);
+my $N   = 25; # N up to 20 works with all methods...
+## We will use memoization to improve performance!!
+
+is( cute(                    $_ ), $RES[$_] ) for 1..$N;
+is( cute_no_order(          $_ ), $RES[$_] ) for 1..$N;
+is( cute_no_cache(          $_ ), $RES[$_] ) for 1..$N;
+is( cute_no_order_no_cache( $_ ), $RES[$_] ) for 1..$N;
+
+done_testing();
+
+#my $t1 = my $t0 = time; (printf "%3d\t%15d\t%10.6f\t%10.6f\n", $_, cute($_), time-$t0, time-$t1),$t0=time for 1..50;
+
+## A quick bit of prep - for each position we want to keep a list
+## of possible digits.
+## Then for ultimate perforance we sort them into a list in
+## size order - so start with the position with least possible numbers
+## and work up!!
+
+cmpthese( -5 , {
+  'cache-order'        => sub { cute($_) for 1..$N },
+  'cache-no-order'     => sub { cute_no_order($_) for 1..$N },
+  'no-cache-order'     => sub { cute_no_cache($_) for 1..$N },
+  'no-order-no-cache'  => sub { cute_no_order_no_cache($_) for 1..$N },
+});
+
+sub cute {
+    ## Clear cache...
+  %cache=();
+    ## If n is 1 short cut and return 1
+  $_[0]==1 ? 1 : _cute_count( 0,
+      ## Just keep the lists
+    map  { $_->[1] }
+      ## Sort so the shortest lists are first - then sort by integer
+    sort { @{$a->[1]} <=> @{$b->[1]} || $a->[0]  <=>   $b->[0] }
+      ## Find all values between 1 & n which are either a factor or
+      ## multiple. Store each as pair, of the number + all values.
+    map  {[ ($a=$_) => [ grep { !( $_%$a && $a%$_ ) } 1 .. $_[0] ] ] }
+      ## Looping over 1 to n
+    1 .. $_[0]
+  )
+}
+
+sub _cute_count {
+  my( $seen, $next ) = ( shift, shift );
+    ## If we have already computed the value return...
+    ## otherwise we loop over the values possible in the
+    ## "nth" position (this is loose as they aren't ordered directly)
+    ## by " but by the count {we are only counting so don't need to
+    ## produce numbers}
+    ## We sum up the value for each value in this list which hasn't
+    ## been seen we return.
+    ## If there is only 1 number left in the list we count 1
+    ##   (as all numbers can be in the last position)
+    ## o/w we call this method again after knocking out the number
+  $cache{$seen} //= sum0 map { ($seen & 1<<$_) ? 0 : @_ < 2 ? 1 :
+                      _cute_count( $seen | 1<<$_ , @_ ) } @{$next}
+    ## Note we don't use a string as a key - but use a bit mast -
+    ## using "|" to set a bit & "&" to check it has been set.
+}
+
+sub cute_no_cache {
+  my $N = shift;
+  my @map = ( 0, map  { $a=$_; [ grep { ! ( $_%$a && $a%$_ ) } 1..$N ] } 1..$N );
+  _cute_count_no_cache( 0,
+    map { $map[$_] }
+    sort { @{$map[$a]} <=> @{$map[$b]} || $a <=> $b }
+    1..$N
+  );
+}
+
+
+sub cute_no_order_no_cache {
+  my $N = shift;
+  my @map = ( 0, map  { $a=$_; [ grep { ! ( $_%$a && $a%$_ ) } 1..$N ] } 1..$N );
+  return _cute_count_no_cache( 0,
+    map { $map[$_] }
+    1..$N
+  );
+}
+
+
+sub cute_no_order {
+  my $N = shift;
+  my @map = ( 0, map  { $a=$_; [ grep { ! ( $_%$a && $a%$_ ) } 1..$N ] } 1..$N );
+  %cache=();
+  return _cute_count_no_order( 0, map { $map[$_] } 1..$N);
+}
+
+## $seen is bit flag of seen numbers  { as we know that $n is low < 63 we can use this trick! }
+## $next is the next list of numbers to try
+## @_    the remaining lists of numbers to try
+sub _cute_count_no_cache {
+  my( $seen, $next ) = ( shift, shift );
+  my @nos = grep { !( $seen & 1<<$_ ) } @{$next};
+  @_ ? sum0 map { _cute_count_no_cache( $seen | 1<<$_ , @_ ) } @nos
+     : scalar @nos;
+}
+
+sub _cute_count_no_order {
+  my( $seen, $next ) = ( shift, shift );
+  return $cache{$seen} if exists $cache{$seen};
+  my @nos = grep { !( $seen & 1<<$_ ) } @{$next};
+  return $cache{$seen} = @_
+     ? sum0 map { _cute_count_no_order( $seen | 1<<$_ , @_ ) } @nos
+     : scalar @nos;
+}
+
+## @_    the remaining lists of numbers to try
+__END__
+
+## Performance
+
+The original challenge asked us to compute values up to `n=15` - the cumulative time for this is between 1.05 and 1.30 seconds. We can continue on to `n=30` taking around 19 seconds.
+
+The script finally crashes after `n=39` (with a count of around 5.5 trillion) - when the cache memory usage exceeds 7GBytes (the capacity of the machine) and starts to swap.
+
+| ind |             Count | Time loop  | Cumul time |
+| --: | ----------------: | ---------: | ---------: |
+|   1 |                 1 |   0.000010 |   0.000011 |
+|   2 |                 2 |   0.000018 |   0.000076 |
+|   3 |                 3 |   0.000016 |   0.000105 |
+|   4 |                 8 |   0.000022 |   0.000136 |
+|   5 |                10 |   0.000028 |   0.000175 |
+|   6 |                36 |   0.000067 |   0.000251 |
+|   7 |                41 |   0.000085 |   0.000346 |
+|   8 |               132 |   0.000177 |   0.000533 |
+|   9 |               250 |   0.000241 |   0.000790 |
+|  10 |               700 |   0.000493 |   0.001299 |
+|  11 |               750 |   0.000601 |   0.001916 |
+|  12 |             4,010 |   0.001535 |   0.003466 |
+|  13 |             4,237 |   0.001722 |   0.005206 |
+|  14 |            10,680 |   0.002893 |   0.008116 |
+|  15 |            24,679 |   0.005721 |   0.013854 |
+|  16 |            87,328 |   0.009010 |   0.022884 |
+|  17 |            90,478 |   0.010208 |   0.033113 |
+|  18 |           435,812 |   0.020486 |   0.053620 |
+|  19 |           449,586 |   0.023270 |   0.076913 |
+|  20 |         1,939,684 |   0.078741 |   0.155676 |
+|  21 |         3,853,278 |   0.125847 |   0.281549 |
+|  22 |         8,650,900 |   0.173449 |   0.455045 |
+|  23 |         8,840,110 |   0.224917 |   0.680006 |
+|  24 |        60,035,322 |   0.359825 |   1.039877 |
+|  25 |        80,605,209 |   0.511679 |   1.551599 |
+|  26 |       177,211,024 |   0.663506 |   2.215148 |
+|  27 |       368,759,752 |   1.033414 |   3.248616 |
+|  28 |     1,380,348,224 |   2.533999 |   5.782659 |
+|  29 |     1,401,414,640 |   2.951694 |   8.734403 |
+|  30 |     8,892,787,136 |  10.241124 |  18.975582 |
+|  31 |     9,014,369,784 |  11.076978 |  30.052606 |
+|  32 |    33,923,638,848 |  13.505877 |  43.558524 |
+|  33 |    59,455,553,072 |  20.499038 |  64.057609 |
+|  34 |   126,536,289,568 |  23.903329 |  87.960986 |
+|  35 |   207,587,882,368 |  57.064045 | 145.025074 |
+|  36 | 1,495,526,775,088 |  99.565625 | 244.590748 |
+|  37 | 1,510,769,105,288 | 109.442520 | 354.033321 |
+|  38 | 3,187,980,614,208 | 134.032712 | 488.066089 |
+|  39 | 5,415,462,995,568 | 175.846131 | 663.912274 |
+