aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--challenge-191/james-smith/README.md289
-rw-r--r--challenge-191/james-smith/blog.txt1
-rw-r--r--challenge-191/james-smith/perl/ch-1.pl69
-rw-r--r--challenge-191/james-smith/perl/ch-2.pl181
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 |
+
generated by cgit (git 2.34.1) at 2026-07-02 23:38:22 +0000