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.