# Perl Weekly Challenge 191.

My solutions (task 1 and task 2 ) to the The Weekly Challenge - 191.

# Task 1: Twice Largest

```
Submitted by: Mohammad S Anwar
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.
Example 1
Input: @list = (1,2,3,4)
Output: -1
The largest in the given list is 4. However 4 is not greater than twice
of every remaining elements.
1 x 2 < 4
2 x 2 > 4
2 x 3 > 4
Example 2
Input: @list = (1,2,0,5)
Output: 1
The largest in the given list is 5. Also 5 is greater than twice of every
remaining elements.
1 x 2 < 5
2 x 2 < 5
0 x 2 < 5
Example 3
Input: @list = (2,6,3,1)
Output: 1
The largest in the given list is 6. Also 6 is greater than twice of every
remaining elements.
2 x 2 < 6
3 x 2 < 6
1 x 2 < 6
Example 4
Input: @list = (4,5,2,3)
Output: -1
The largest in the given list is 5. Also 5 is not greater than twice of every
remaining elements.
4 x 2 > 5
2 x 2 < 5
3 x 2 > 5
```

I guess the inequality in the examples is wrong, as it is not true
that `3 x 2 < 6`

. `<`

should have been `<=`

.

A simple solution is to sort the list and compare the largest element to twice the next largest. This yields a short one-liner:

```
perl -E '@x=sort{$b <=> $a} @ARGV; say "@ARGV -> ", $x[0] >= 2*$x[1]?1:-1' 1 2 3 4
perl -E '@x=sort{$b <=> $a} @ARGV; say "@ARGV -> ", $x[0] >= 2*$x[1]?1:-1' 1 2 0 5
perl -E '@x=sort{$b <=> $a} @ARGV; say "@ARGV -> ", $x[0] >= 2*$x[1]?1:-1' 2 6 3 1
perl -E '@x=sort{$b <=> $a} @ARGV; say "@ARGV -> ", $x[0] >= 2*$x[1]?1:-1' 4 5 2 3
```

Results:

```
1 2 3 4 -> -1
1 2 0 5 -> 1
2 6 3 1 -> 1
4 5 2 3 -> -1
```

The full code is almost identical.

```
1 # Perl weekly challenge 191
2 # Task 1: Twice Largest
3 #
4 # See https://wlmb.github.io/2022/11/14/PWC191/#task-1-twice-largest
5 use v5.36;
6 use List::Util qw(all);
7 use Scalar::Util qw(looks_like_number);
8 die <<"EOF" unless @ARGV;
9 Usage: $0 N1 [N2...]
10 to test if the largest among Ni is at least as large as twice
11 any of the others.
12 EOF
13 die "Only numbers allowed" unless all {looks_like_number($_)} @ARGV;
14 my @x=sort{$b <=> $a} @ARGV;
15 say "@ARGV -> ", $x[0] >= 2*$x[1]?1:-1
```

Example:

```
./ch-1.pl 1 2 3 4
./ch-1.pl 1 2 0 5
./ch-1.pl 2 6 3 1
./ch-1.pl 4 5 2 3
```

Results:

```
1 2 3 4 -> -1
1 2 0 5 -> 1
2 6 3 1 -> 1
4 5 2 3 -> -1
```

# Task 2: Cute List

```
Submitted by: Mohammad S Anwar
You are given an integer, 0 < $n <= 15.
Write a script to find the number of orderings of numbers that form a
cute list.
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
1. $list[$i] is evenly divisible by $i or
2. $i is evenly divisible by $list[$i]
Example
Input: $n = 2
Ouput: 2
Since $n = 2, the list can be made up of two integers only i.e. 1 and 2.
Therefore we can have two list i.e. (1,2) and (2,1).
@list = (1,2) is cute since $list[1] = 1 is divisible by 1 and $list[2] = 2 is divisible by 2.
```

A straightforward solution is to simply generate all permutations,
`grep`

the cute ones and count them. This fits a one-liner.

```
perl -MAlgorithm::Combinatorics=permutations -MList::Util=all -E 'say "$_ -> ", scalar
grep {@x=@$_; all {$x[$_-1]%$_==0||$_%$x[$_-1]==0} 1..@$_} permutations[1..$_] for @ARGV
' `seq 10`
```

Results:

```
1 -> 1
2 -> 2
3 -> 3
4 -> 8
5 -> 10
6 -> 36
7 -> 41
8 -> 132
9 -> 250
10 -> 700
```

I wouldn’t dare go beyond n=10 with this code, as it generates all permutations, rapidly filling the memory. But maybe it would work if I employ an iterator.

```
1 # Perl weekly challenge 191
2 # Task 2: Cute List
3 #
4 # See https://wlmb.github.io/2022/11/14/PWC191/#task-2-cute-list
5 use v5.36;
6 use Algorithm::Combinatorics qw(permutations);
7 use List::Util qw(all);
8
9 sub cute($o){ # check @$o is a cute sequence
10 my @o=@$o;
11 return all {$o[$_-1]%$_==0||$_%$o[$_-1]==0} 1..@o;
12 }
13
14 die << "EOF" unless @ARGV;
15 Usage: $0 N1 [N2...]
16 to count the cute orderings of 1..Ni
17 EOF
18 die "Only numbers in the range 1..15 are allowed" unless all {1<=$_<=15} @ARGV;
19 for(@ARGV){
20 my $iter=permutations[1..$_];
21 my $count=0;
22 my $o;
23 cute($o) && ++$count while $o=$iter->next;
24 say "$_ -> $count";
25 }
```

Example:

```
./ch-2.pl `seq 11`
```

Results:

```
1 -> 1
2 -> 2
3 -> 3
4 -> 8
5 -> 10
6 -> 36
7 -> 41
8 -> 132
9 -> 250
10 -> 700
11 -> 750
```

Although the program might run for larger n’s, I would need patience in order to wait for it to finish, as the time scales as n!.

I guess
it would be much faster if I only generate cute sequences, as there
are so few of them, instead of generating all sequences, for which there
are n!, and checking them for cuteness. Thus, I try a new
approach. Given the input `n`

, I build `n`

sets of numbers consisting
of subsets of `1..n`

that are divisors and multiples of `i`

, for
`1<=i<=n`

. Then I use `Set::CrossProduct`

to produce all the tuples
that form the Cartesian product of those sets, and finally choose and count those
tuples that have no repetitions.

```
1 # Perl weekly challenge 191
2 # Task 2: Cute List. Economize memory
3 #
4 # See https://wlmb.github.io/2022/11/14/PWC191/#task-2-cute-list
5 use v5.36;
6 use List::Util qw(all any);
7 use Set::CrossProduct;
8 sub cute($n){ # iterator over cute sequences
9 my @sets;
10 for my $position(0..$n-1){
11 for(1..$n){
12 push @{$sets[$position]}, $_ if ($position+1)%$_==0 || $_%($position+1)==0;
13 }
14 }
15 my $iter=Set::CrossProduct->new([@sets]);
16 return sub {
17 ITER: while(my $tuple=$iter->get()){
18 my @seen;
19 for(@$tuple){
20 next ITER if $seen[$_];
21 ++$seen[$_];
22 }
23 return $tuple;
24 }
25 return;
26 }
27 }
28 die << "EOF" unless @ARGV;
29 Usage: $0 N1 [N2...]
30 to count the cute orderings of 1..Ni
31 EOF
32 die "Only numbers in the range 1..15 are allowed" unless all {1<=$_<=15} @ARGV;
33 for(@ARGV){
34 my $iter=cute($_);
35 my $count=0;
36 ++$count while $iter->();
37 say "$_ -> $count";
38 }
```

It works but it still takes too long. The problem is that I
uselessly generate many sequences that I later throw away. Maybe I could generate
progressively larger sequences cleaning them of repetitions
along the way, throwing useless sequences earlier.
To that end I first build the sets of divisors and multiples
of `i`

for `1<=i<=n`

. Then I use an auxiliary function
to repeatedly combine with the
i-th set the partially built set of cute
sequences, starting with the empty set, removing sequences
with duplicates. The code is much
faster than those above!

```
1 # Perl weekly challenge 191
2 # Task 2: Cute List. Throw duplicates early.
3 #
4 # See https://wlmb.github.io/2022/11/14/PWC191/#task-2-cute-list
5 use v5.36;
6 use Set::CrossProduct;
7 use List::Util qw(all reduce);
8 sub cute($n){ # generate all cute sequences of length $n
9 my @sets;
10 for my $position(0..$n-1){
11 for(1..$n){ # Build sets of divisors and multiples of $position+1
12 push @{$sets[$position]}, $_ if ($position+1)%$_==0 || $_%($position+1)==0;
13 }
14 }
15 my $x=reduce {cute_aux($a, $b)} [[]], @sets; # combine sets into cute sequences
16 return $x;
17 }
18 sub cute_aux($seqs, $nums){ # combine an ongoing set of cute sequences with a set of numbers
19 my $iter=Set::CrossProduct->new([$seqs, $nums]);
20 my @combined;
21 while(my $tuple=$iter->get){ # Cartesian product of a sequence and a number
22 my @array=@{$tuple->[0]};
23 my $num=$tuple->[1];
24 my @seen;
25 map {$seen[$_]=1} @array; # Seen numbers
26 next if $seen[$num]; # Throw away repetitions
27 push @array, $num; # add number to current sequence
28 push @combined, [@array]; # add sequence to set of ongoing sequences
29 }
30 return [@combined];
31 }
32 die << "EOF" unless @ARGV;
33 Usage: $0 N1 [N2...]
34 to count the cute orderings of 1..Ni
35 EOF
36 die "Only numbers in the range 1..18 are allowed" unless all {1<=$_<=18} @ARGV;
37 say "$_ -> ", scalar @{cute($_)} for(@ARGV);
./ch-2b.pl `seq 18`
```

Results:

```
1 -> 1
2 -> 2
3 -> 3
4 -> 8
5 -> 10
6 -> 36
7 -> 41
8 -> 132
9 -> 250
10 -> 700
11 -> 750
12 -> 4010
13 -> 4237
14 -> 10680
15 -> 24679
16 -> 87328
17 -> 90478
18 -> 435812
```

The program is fast enough and the results small enough that I allowed larger inputs. It took only 12s for n=15 in my laptop, 50s for n=16, 1m for n=17 and 5m for n=18.

Actually, I can make the program somewhat faster by doing my own Cartesian product with a couple of confusing nested reductions and maps.

```
1 # Perl weekly challenge 191
2 # Task 2: Cute List. Throw duplicates early.
3 #
4 # See https://wlmb.github.io/2022/11/14/PWC191/#task-2-cute-list
5 use v5.36;
6 use List::Util qw(all reduce);
7 sub cute($n){ # generate all cute sequences of length $n
8 my @sets;
9 for my $position(0..$n-1){
10 for(1..$n){ # Build sets of divisors and multiples of $position+1
11 push @{$sets[$position]}, $_ if ($position+1)%$_==0 || $_%($position+1)==0;
12 }
13 }
14 my $x=reduce {
15 my @combined =
16 map {
17 my @seq=@$_;
18 map {
19 my @seen;
20 @seen[@seq]=(1)x@seq;
21 $seen[$_]?():[@seq, $_]
22 } @$b
23 }
24 @$a;
25 [@combined];
26 } [[]], @sets; # combine sets into cute sequences
27 return $x;
28 }
29 die << "EOF" unless @ARGV;
30 Usage: $0 N1 [N2...]
31 to count the cute orderings of 1..Ni
32 EOF
33 warn "Numbers beyond 18 will require patience" unless all {1<=$_<=18} @ARGV;
34 say "$_ -> ", scalar @{cute($_)} for(@ARGV);
for i in `seq 18`; do time ./ch-2d.pl $i; done
```

Results (edited, user times):

```
1 -> 1 0m0.007s
2 -> 2 0m0.007s
3 -> 3 0m0.007s
4 -> 8 0m0.006s
5 -> 10 0m0.001s
6 -> 36 0m0.007s
7 -> 41 0m0.007s
8 -> 132 0m0.009s
9 -> 250 0m0.009s
10 -> 700 0m0.023s
11 -> 750 0m0.028s
12 -> 4010 0m0.171s
13 -> 4237 0m0.238s
14 -> 10680 0m0.776s
15 -> 24679 0m2.809s
16 -> 87328 0m10.691s
17 -> 90478 0m14.209s
18 -> 435812 1m10.353s
```

My first attempt above took about 10s for n=10 and its execution time scales as n!. Thus, for n=18 I would expect it to take 10s × 18!/10!=17,643,225,600s=560 years. Bringing that time down to around 1m is somewhat satisfying.

The code above is short enough that it may be compressed into a cryptic 3-liner:

```
perl -MList::Util=reduce -E 'sub c($n){my @s; for $p(0..$n-1){for(1..$n){push @{$s[$p]},
$_ if ($p+1)%$_==0 || $_%($p+1)==0;}} $x=reduce{my @c=map{my @s=@$_; map{my @z;@z[@s]=(1)x@s;
$z[$_]?():[@s,$_]} @$b}@$a;[@c];}[[]], @s;$x} say "$_ -> ", 0+@{c($_)} for(@ARGV);
' `seq 15`
```

Results:

```
1 -> 1
2 -> 2
3 -> 3
4 -> 8
5 -> 10
6 -> 36
7 -> 41
8 -> 132
9 -> 250
10 -> 700
11 -> 750
12 -> 4010
13 -> 4237
14 -> 10680
15 -> 24679
```

Instead of building all cute sequences, I try my luck with nested
iterators. A subroutine `cute`

prepares a list of valid numbers for
each position of a cute sequence and uses a closure to build an
ancilliary subroutine that produces iterators for each position. Each
iterator needs an iterator for the following position, which is
obtained through a recursive call. I build a
trivial iterator for the position beyond the last that returns an
empty result when first called and then is exhausted.

Each iterator
chooses a number for the corresponding position in the sequence, initializes and drains
the next iterator before choosing the next number corresponding to its
position. Finalle, `cute`

uses this ancilliary routine to return an
iterator for the first position.

```
1 # Perl weekly challenge 191
2 # Task 2: Cute List. Nested iterators.
3 #
4 # See https://wlmb.github.io/2022/11/14/PWC191/#task-2-cute-list
5 use v5.36;
6 use List::Util qw(all reduce);
7
8 sub listit(@set){ # iterator that returns the elements of a set
9 sub { return shift @set }
10 }
11
12 sub cute($n){ # return an iterator to generate all cute sequences of length $n
13 my @sets;
14 for my $position(0..$n-1){
15 for(1..$n){ # Build sets of divisors and multiples of $position+1
16 push @{$sets[$position]}, $_ if ($position+1)%$_==0 || $_%($position+1)==0;
17 }
18 }
19 my $aux;
20 $aux = # closure for an ancilliary iterator constructor
21 sub ($pos) { # Returns an iterator for position $pos
22 #The iterator returns a cute subsecuence and a hash of seen values
23 # Return a trivial iterator if beyond end
24 return # trivial iterator beyond position
25 sub { state $n=0; return $n++? ():([],{})} if $pos >=@sets;
26 my @set=@{$sets[$pos]};
27 my $it=$aux->($pos+1); # Iterator for next position
28 my $candidates=listit(@set); # iterator for candidates
29 my ($cute, $seen)=$it->(); # initial cute subsequence
30 sub {
31 while(1){
32 while(my $candidate=$candidates->()){
33 return([$candidate, @$cute], {$candidate, 1, %$seen})
34 unless $seen->{$candidate};
35 }
36 ($cute, $seen)=$it->() or return (); # next subsequence or return
37 $candidates=listit(@set); # reinitalize iterator for candidates
38 }
39 }
40 };
41 $aux->(0); # return iterator for full sequence
42 }
43
44 die << "EOF" unless @ARGV;
45 Usage: $0 N1 [N2...]
46 to count the cute orderings of 1..Ni
47 EOF
48 warn "Numbers beyond 20 will require patience" unless all {1<=$_<=20} @ARGV;
49 for(@ARGV){
50 my $count=0;
51 my $it=cute($_);
52 ++$count while $it->(); # count cute sequences
53 say "$_-> $count"; # report
54 }
55
```

Example:

```
for i in `seq 21`; do time ./ch-2c.pl $i; done
```

Results:

```
1-> 1 0m0.007s
2-> 2 0m0.005s
3-> 3 0m0.004s
4-> 8 0m0.004s
5-> 10 0m0.004s
6-> 36 0m0.004s
7-> 41 0m0.004s
8-> 132 0m0.008s
9-> 250 0m0.010s
10-> 700 0m0.013s
11-> 750 0m0.018s
12-> 4010 0m0.069s
13-> 4237 0m0.080s
14-> 10680 0m0.207s
15-> 24679 0m0.514s
16-> 87328 0m1.905s
17-> 90478 0m2.150s
18-> 435812 0m11.182s
19-> 449586 0m11.629s
20-> 1939684 0m51.666s
21-> 3853278 1m53.391s
```

This version was fun to program and is the fastest so far, and doesn’t consume memory. For n=20 my original program would have taken around 1: 10s × 20!/10!=6.7Ts=212 millennia, and with this program it took less than a minute.