site.base_url }}/">The Bear's Den -->

The Bear's Den

Enter at your own risk

20 December 2024 Challenge 300

The Beautiful, The Cute and The Nested

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

Solution

This task sounds familiar. Indeed, there was task 2 in week 191:

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]

Reproducing my comments from week 191:

Do not count the number of cute lists but calculate it instead. A cute list may be regarded as a complete matching between the numbers from \(1\) to \(N\) and the \(N\) slots in the list. A number is permitted in a slot, if the corresponding element in the adjacency matrix is one. The number of perfect matchings in an unweighted bipartite graph defined by its adjacency matrix \(A\) equals the permanent of \(A\).

For a cute list the adjacency matrix \(A\) is defined by: \(a_{ij} = \begin{cases} 1 & \text{ if } i \text{ is divisible by } j \text{ or } j \text{ is divisible by } i \\ 0 & \text{ otherwise} \end{cases}\)

Calculating the permanent of a matrix is rather expensive. Though the results from the implementation in ch-2.pl from week 191 are not too bad, they fall behind Maxima’s “permanent” function. Thus trying harder.

The Maxima manual states the permanent would be implemented using the “Johnson-Gentleman tree minor algorithm”. Some web research revealed an article by Gentleman and Johnson about the calculation of determinants using a non-recursive unbalanced tree approach. This principle may be trivially applied to permanents, too. The article is mainly about the complexity of such a class of algorithms and does not go into details about an implementation.

Tried to implement the idea described in the article and to optimize it as far as possible. Almost could catch up with Maxima.

There are some benchmarks from week 191 that I cannot reproduce with current versions of perl and Maxima anymore:

N This Maxima
28 6:15 min / 3.9 GB 5:06 min / 1.9 GB
29 ? crashes
30 20:45 min / 9.8 GB -

The Maxima implementation seems to have changed. Running time shoots through the roof for N > 26 now. Current benchmark:

N This Maxima
25 26 s / 450 MB 16 s / 650 MB
26 57 s / 1 GB 46 s / 650 MB
27 2:05 min / 1.9 GB 9:30 min / 1 GB
28 5:26 min / 4.3 GB 22:29 min / 2 GB
29 12:26 min / 7.6 GB ?

References:

use strict;
use warnings;
use experimental 'signatures';

sub count_cute ($n) {
    # Build the adjacency matrix A for a "cute list" of size N.
    my @a;
    for my $i (0 .. $n - 1) {
        for my $k (0 .. $n - 1) {
            my $v = 0 + (!(($i + 1) % ($k + 1)) || !(($k + 1) % ($i + 1)));
            $a[$i][$k] = $v;
        }
    }

    # Find the number of cute lists.
    permanent_01(\@a);
}

# An attempt to implement the "Johnson-Gentleman tree minor algorithm":
# This is a non-recursive approach that avoids the re-examination of
# minors appearing in recursive approaches.  It does not split the task
# of calculating a determinant/permanent into smaller tasks but instead
# builds the whole result by extending from single elements.  This takes
# a lot of memory for larger matrices.  Restricting to matrices having
# only zeroes and ones as elements.
#
sub permanent_01 ($a) {
    my $node;
    my $last = $#$a;
    my $sel;

    # Nodes are key-value pairs where the keys are integers with bits
    # set for the selected rows forming a minor matrix and the
    # corresponding sub-permanent as values.

    # Build the first node, consisting of the non-zero elements of the
    # first column.
    for my $i (0 .. $last) {
        $node->{1 << $i} = 1 if $a->[0][$i];
    }

    # Loop over the remaining columns.
    for my $i (1 .. $last) {
        my $next;
        # Loop over all minors of the previous node. These have a size
        # of $i x $i
        for my $minor (keys %$node) {
            # Loop over all rows.  Process only nonzero elements.  Get
            # the selector for the current row and check if it is
            # already part of the current minor or add the minor's part
            # to the next larger minor extended by the current row
            # otherwise.  Avoiding any multiplications here as all
            # elements are zero or one - though the impact is very low.
            $a->[$i][$_] && (($sel = 1 << $_) & $minor && next ||
#            ($next->{$minor | $sel} += $a->[$i][$_] * $node->{$minor}))
            ($next->{$minor | $sel} += $node->{$minor}))
            for 0 .. $last;
        }
        $node = $next;
    }

    # At the end, there is only one value left - the permanent of the
    # whole matrix.
    (values %$node)[0];
}

See the full solution to task 1.

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

Solution

In this task we are asked for the maximum length of a cycle in the given permutation.

Not following the recipe from Wiki, but identifying all cycles in a single process instead.

Given the permutation \(p = (p_1,\ldots,p_n)\) we may build the corresponding permutation matrix \(P = (p_{ij})\) where

\[p_{ij} = \begin{cases} 1 & \text{ if } p_i = j \\ 0 & \text { otherwise } \end{cases}\]

We build

\[M_k = \sum_{i=0}^k P^i\]

as the sum of the powers of \(P\) with \(P^0 = \operatorname{Id}\).

We have \(m_{ij}^k > 0\) if \(i\) is mapped to \(j\) when \(p\) is applied up to \(k\) times. As soon as all columns in \(M\) contain at least one entry \(m_{ij}^k > 1\), we have detected all cycles and take \(k - 1\) as the maximum cycle length.

use strict;
use warnings;
use PDL;
use PDL::NiceSlice;

sub nested {
    my $l = long @_;
    my $pn = identity($l);
    my $m = $pn->copy;
    my $p = $pn($l)->sever;;
    my $c;
    $c++, $m += ($pn = $pn x $p) while 2 > min $m->maxover;

    $c;
}

See the full solution to task 2.

If you have a question about this post or if you like to comment on it, feel free to open an issue in my github repository.