Beautiful arrangement

You are given a positive integer, $n. 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 .. $n) either of the following is true:

1. $perm[$i] is divisible by $i
2. $i is divisible by $perm[!i]

Examples

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

Analysis

The obvious way to meet this challege is my solution 1, which simply takes all the permutations of 1 .. $n and tests them for being beautiful. It comes up with the same answer as the provided example for $n == 10 in 25 seconds.

For $n in the range 0-8 it takes less than a second, for $n == 9 it takes 3 seconds and for $n == 11 it takes 277 seconds - nearly 5 minutes.

In my solution I have included a couple of optimisations:

• If $i == 1 or $i == $perm[$i] it is not necessary to apply the two conditions, and
• only one of the two conditions is relevant depending on whether $i is greater or less than $perm[$i].

But even so, its execution time rises rather alarmingly as $n increases.

So is there a faster way? I can't immediately think of a way that doen't involve checking every permutation, but I can make a modest improvement - my solution 2.

The basis of solution 2 is that for each $i there are only a few possible values of $perm[$i], which are:

• $i
• any multiples of $i which are <= $n
• any integer divisors of $i including 1

So for example for $n == 10 the only beautiful possibilities are:

$i	$perm[$i]
1	1 .. 10
2	1, 2, 4, 6, 8, 10
3	1, 3, 6, 9
4	1, 2, 4, 8
5	1, 5, 10
6	1, 2, 3, 6
7	1, 7
8	1, 2, 4, 8
9	1, 3, 9
10	1, 2, 5, 10

So when checking a permutation, let's start by checking $perm[7], because that has only two possible values - 1 or 7 - so 80% of perms can be discarded without looking at any further components of the perm.

My solution 2 therefore creates an order for checking the beautifulness of each perm by checking the components in the increasing order of the number of beautiful possibilities: so for
$n == 10 it checks in the order 7, 5, 9, 3, 4, 6, 8, 10, 2. It doesn't need to check 1, because any number is divisible by 1 and 1 can therefore appear anywhere in @perm, and it doesn't need to check the elements where $perm[$i] == $i.

I had rather hoped for a substantial increase in speed by doing that, but in fact it only reduces the time by around 10%. I am guessing that's because the generation of the perms is what takes the bulk of the time.

Perl Weekly’s review

Happy to see the optimisation and discussion around it. Thanks for being the most consistent contributor.

Try it 

I haven't provided a 'try it' for this challenge because the solutions for 2 to 11 are shown in my Output section and any others will take too long for a web page.

⤡

#!/usr/bin/perl

# Blog: http://ccgi.campbellsmiths.force9.co.uk/challenge

use v5.26;    # The Weekly Challenge - 2024-12-16
use utf8;     # Week 300 - task 1 - Beautiful arrangement
use warnings; # Peter Campbell Smith
use Algorithm::Combinatorics 'permutations';
binmode STDOUT, ':utf8';

for (2 .. 11) {
    beautiful_arrangement1($_);
    beautiful_arrangement2($_);
}

sub beautiful_arrangement1 {
    
    my ($n, @array, $iter, $next, $i, $start, @order, @possible, $beautiful);
    
    # initialise
    $n = shift;
    $beautiful = 0;
    $start = time();
    push(@array, $_) for 1 .. $n;
    
    # loop over perms
    $iter = permutations(\@array);
    PERM: while ($next = $iter->next) {
        for $i (1 .. $n) {
            
            # test for ugliness
            unless ($i == $next->[$i - 1]) {
                next PERM unless $i > $next->[$i - 1] 
                    ? $i % $next->[$i - 1] == 0 
                    : $next->[$i - 1] % $i == 0;
            }
        }
        
        # not ugly
        $beautiful ++;
    }
    say qq[\nInput:  \$n = $n];
    say qq[Output1: $beautiful (] . (time() - $start) . qq[ secs)];
}

sub beautiful_arrangement2 {
    
    my ($i, $j, $k, $start, @count, $n, $iter, $next, $m, $beautiful, @possible,
        @order, @array);
    
    # initialise
    $n = shift;
    $beautiful = 0;
    $start = time();
    
    # find possible values of each $array[$i]
    for $i (1 .. $n) {  
        $possible[$i] = '~';
        for $j (1 .. 999) {
            
            # multiples
            if ($i * $j <= $n) {
                $possible[$i] .= $i * $j . '~';
            }
            
            # divisors
            if ($j > 1 and $i / $j >= 1 and $i % $j == 0) {
                $possible[$i] .= $i / $j . '~';
            }
        }
    }
    
    # $count[$i] is the no of possible values at $array[$i]
    for $i (1 .. $n) {
        $count[$i] = ($possible[$i] =~ s|~|~|g) - 1;
    }
    
    # @order is the hardest to easiest order to fill
    for $i (1 .. $n) {
        for $j (1 .. $n) {
            if ($count[$j] == $i) {
                push @order, $j;
            }
        }
    }
    
    # now start as before
    push(@array, $_) for 1 .. $n;
    
    # loop over perms
    $iter = permutations(\@array);
    PERM: while ($next = $iter->next) {
        for $k (0 .. $n - 1) {
            
            # test for ugliness in order of probability
            $i = $order[$k];
            $m = $next->[$i - 1];
            unless ($i == 1 or $i == $m) {
                next PERM unless $i > $m ? $i % $m == 0 : $m % $i == 0;
            }
        }
        
        # not ugly
        $beautiful ++;
    }
    
    say qq[Output2: $beautiful (] . (time() - $start) . qq[ secs)];
}

45 lines of code

Output from script

Input:  $n = 2
Output1: 2 (0 secs)
Output2: 2 (0 secs)

Input:  $n = 3
Output1: 3 (0 secs)
Output2: 3 (0 secs)

Input:  $n = 4
Output1: 8 (0 secs)
Output2: 8 (0 secs)

Input:  $n = 5
Output1: 10 (0 secs)
Output2: 10 (0 secs)

Input:  $n = 6
Output1: 36 (0 secs)
Output2: 36 (0 secs)

Input:  $n = 7
Output1: 41 (0 secs)
Output2: 41 (0 secs)

Input:  $n = 8
Output1: 132 (0 secs)
Output2: 132 (0 secs)

Input:  $n = 9
Output1: 250 (3 secs)
Output2: 250 (2 secs)

Input:  $n = 10
Output1: 700 (25 secs)
Output2: 700 (23 secs)

Input:  $n = 11
Output1: 750 (277 secs)
Output2: 750 (255 secs)