# Perl Weekly Challenge 191.

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

``````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  #
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
``````

``````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  #
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  #
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  #
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  #
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  #
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.

Written on November 14, 2022