Perl Weekly Challenge 300.

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

Task 1: Beautiful Arrangement

Submitted by: Mohammad Sajid Anwar
You are given a positive integer, $int.

Write a script to return the number of beautiful arrangements that you can construct.

A permutation of n integers, 1-indexed, is considered a beautiful arrangement
if for every i (1 <= i <= n) either of the following is true:

1. perm[i] is divisible by i
2. i is divisible by perm[i]
Example 1
Input: $n = 2
Output: 2

1st arrangement: [1, 2]
    perm[1] is divisible by i = 1
    perm[2] is divisible by i = 2
2nd arrangement: [2, 1]
    perm[1] is divisible by i = 1
    i=2 is divisible by perm[2] = 1
Example 2
Input: $n = 1
Output: 1
Example 3
Input: $n = 10
Output: 700

A simple, though maybe very inneficient solution, is to generate all permutations, grep the beautiful arrangements and count them. This yields a one-liner.

Examples:

time perl -MPDL -MAlgorithm::Combinatorics=permutations -E '
for (@ARGV){say "$_ -> ", 0+grep{$n=$_->xvals+1;(($_%$n==0)|($n%$_==0))->all}map {pdl($_)} permutations([1..$_]);}
' 2 1 10

Results:

2 -> 2
1 -> 1
10 -> 700
real  2m14.406s
user  2m12.354s
sys   0m1.920s

The problem with this solution is that the number of permutations of n elements grows as n!, so the time taken grows extremely fast, as n grows. An alternative is to build the permutations step by step, discarding ugly ones early. This could be done recursively in a two-liner.

Examples:

time perl -E '
sub b($n, @a){return 1 unless @a;my $c=0;for(0..@a-1){next if $n%$a[$_]&&$a[$_]%$n;$c+=
b($n+1,@a[0..$_-1,$_+1..@a-1]);}return $c;} say "$_ -> ", b(1, 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
real    0m0.021s
user    0m0.020s
sys     0m0.000s

This example ran thousands of times faster.

By memoizing the recursive routine, it gains another several orders of magnitude and I can go to much higher values of n:

time perl -MMemoize -E '
memoize b;sub b($n, @a){return 1 unless @a;my $c=0;for(0..@a-1){next if $n%$a[$_]&&$a[$_]%$n;
$c+=b($n+1,@a[0..$_-1,$_+1..@a-1]);}return $c;}say "$_ -> ", b(1, 1..$_) for @ARGV;
' `seq 25`

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
19 -> 449586
20 -> 1939684
21 -> 3853278
22 -> 8650900
23 -> 8840110
24 -> 60035322
25 -> 80605209
real    1m51.595s
user    1m50.227s
sys     0m1.264s

I base the full code in the last two-liner:

 1  # Perl weekly challenge 300
 2  # Task 1:  Beautiful Arrangement
 3  #
 4  # See https://wlmb.github.io/2024/12/15/PWC300/#task-1-beautiful-arrangement
 5  use v5.36;
 6  use Memoize;
 7  die <<~"FIN" unless @ARGV;
 8      Usage: $0 N1 N2...
 9      to count beatiful sequences made up of numbers 1..Ni
10      FIN
11  
12  sub beautiful($index, @remaining){
13      return 1 unless @remaining; # the empty sequence is beautiful
14      my $count=0;
15      for(0..@remaining-1){
16          next if $index%$remaining[$_] && $remaining[$_]%$index; # fail unless one divides the other
17          $count += beautiful($index+1,@remaining[0..$_-1,$_+1..@remaining-1]); # count beautiful subsequences
18      }
19      return $count;
20  }
21  
22  memoize 'beautiful';
23  for (@ARGV){
24      say "$_ -> ", beautiful(1, 1..$_);
25  }

Example:

time ./ch-1.pl `seq 25`

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
19 -> 449586
20 -> 1939684
21 -> 3853278
22 -> 8650900
23 -> 8840110
24 -> 60035322
25 -> 80605209
real    1m52.740s
user    1m51.240s
sys     0m1.252s

Task 2: Nested Array

Submitted by: Mohammad Sajid Anwar
You are given an array of integers, @ints of length n containing permutation of the numbers
in the range [0, n - 1].

Write a script to build a set, set[i] = ints[i], ints[ints[i]], ints[ints[ints[i]]], ...,
subjected to the following rules:

1. The first element in set[i] starts with the selection of elements ints[i].
2. The next element in set[i] should be ints[ints[i]], and then ints[ints[ints[i]]], and so on.
3. We stop adding right before a duplicate element occurs in set[i].
Return the longest length of a set set[i].

Example 1
Input: @ints = (5, 4, 0, 3, 1, 6, 2)
Output: 4

ints[0] = 5
ints[1] = 4
ints[2] = 0
ints[3] = 3
ints[4] = 1
ints[5] = 6
ints[6] = 2

One of the longest sets set[k]:
set[0] = {ints[0], ints[5], ints[6], ints[2]} = {5, 6, 2, 0}
Example 2
Input: @ints = (0, 1, 2)
Output: 1

All the sets set[i] are cyclic, in the sense that starting in any of its elements j we come back to j in the same number of steps as starting in any other element k. Thus, after examining an element, we don’t have to examine it again. We can make a hash of already seen elements. While we find unseen elements we can add them to a set. When we get to a seen element we can save the size of the current set and proceed with the next element. The result is the maximum of the saved numbers. The result fits a one-liner.

Example 1:

perl -MList::Util=max -E '
@i=@ARGV;for(@i){@a=();$x=$_;while(!$s{$x}++){push@a, $x;$x=$i[$x];}push(@b,0+@a)}say "@i -> ",max @b;
' 5 4 0 3 1 6 2

Results:

5 4 0 3 1 6 2 -> 4

Example 2:

perl -MList::Util=max -E '
@i=@ARGV;for(@i){@a=();$x=$_;while(!$s{$x}++){push@a, $x;$x=$i[$x];}push(@b,0+@a)}say "@i -> ",max @b;
' 0 1 2

Results:

0 1 2 -> 1

The full code is similiar, but calculates the maximum on the fly and adds a few tests.

 1  # Perl weekly challenge 300
 2  # Task 2:  Nested Array
 3  #
 4  # See https://wlmb.github.io/2024/12/15/PWC300/#task-2-nested-array
 5  use v5.36;
 6  die <<~"FIN" unless @ARGV;
 7      Usage: $0 N0 N1...Nm
 8      to find the maximum cycle from the permutation N0...Nm of the numbers 0,1,...m
 9      FIN
10  my %all;
11  $all{$_}++ for @ARGV;
12  for(0..@ARGV-1){ # check the input is indeed a permutation
13      die "Not a permutation" unless $all{$_};
14  }
15  my $max=0;
16  my %seen;
17  for(@ARGV){
18      my @set;
19      my $current=$_; # make a copy
20      while(!$seen{$current}++){
21          push @set, $current;
22          $current=$ARGV[$current];
23      }
24      $max=@set if $max<@set;
25  }
26  say "@ARGV -> $max";

Examples:

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

Results:

5 4 0 3 1 6 2 -> 4
0 1 2 -> 1
Written on December 15, 2024