Task — Permutation ranking

You are given a list of integers with no duplicates, eg [0, 1, 2]. Write two functions, permutation2rank() which will take the list and determine its rank (starting at 0) in the set of possible permutations arranged in lexicographic order, and rank2permutation() which will take the list and a rank number and produce just that permutation.

Please checkout this post for more informations and algorithm.

Examples

Example 1:
Given the list [0, 1, 2] the ordered permutations are:

0: [0, 1, 2]
1: [0, 2, 1]
2: [1, 0, 2]
3: [1, 2, 0]
4: [2, 0, 1]
5: [2, 1, 0]

and therefore:
permutation2rank([1, 0, 2]) = 2
rank2permutation([0, 1, 2], 1) = [0, 2, 1]

Analysis

Mohammad kindly point us to an algorithm, and even some sample code. I have to say I didn't find the permutation2rank code too easy to follow, but from the textual description above it I more-or-less did the same in Perl.

The algorithm insists on the permuted set being a set of consecutive integers starting from 0, and while Mohammad doesn't restrict us to that, I think it's good enough for a hot afternoon.

The slightly tricky bit is that as you create a single permutation, your choice of what comes next gets steadily less. So given 0, 1, 2, 3, 4, you've got a choice between 5 options for the first digit of your perm, but only 4 for the next now that you've used up one digit already, and once you get to the 5th digit you've already used up 4 of the 5 and have no choice left for the fifth. So the principle of the algorithm is to calculate the contribution to the rank from each digit, and add them together. If we are given 3, 2, 1, 0 we first calculate where the 3s start, then the offset from there to where the three 2s start, then the offset to where the 3, 2, 1s start - and of course that's also where they finish, because there's only one perm - 3, 2, 1, 0.

I chose to do this slightly differently from the linked article by maintaining an array @ranks. For, say, a six-member perm, @ranks start out like this:

@ranks == [0, 1, 2, 3, 4, 5]

Let's say our given perm is [3, 4, 2, 1, 0]. Where do the perms starting with 3 start in the ranking? Well, after the 3 blocks of 0s, 1s and 2s. If I know (and I do) how big these blocks are, I know that our rank is going to be at least 3 of these big blocks.

Now we come to the second component of the perm which is 4. Now you might think that there will be 4 smaller blocks - the ones starting 3, 0; 3, 1; 3, 2; 3, 3 ... but no! that's not right because there won't be a 3, 3 because we've already used the only 3.

So backtrack a bit. After we did the first block of 3s, we need to eliminate 3 from the rankings and that's where @ranks comes in. After we've used 3, we change @ranks to be:

@ranks == [0, 1, 2, -1, 3, 4]

The second element of our given perm is 4, and it's rank (within the block starting with 3) is $rank[4] - which is 3. It's in the 4th (counting from 0) sub-block after 3, 0; 3,1 and 3,2.

It is rather complex and hard to get your head round, but I hope that helps a bit.

So now we come to rank2permutation. The logic is quite similar: again we are looking at blocks starting with the same 0th, 1st, 2nd ... numbers and deducing where our desired row sits.

I've provided an example where the perm is 15 numbers, ie 0 .. 14. Soon after that we'll run out of integers, but that's for another day.

Try it 

Try running the script with any input. Enter a $perm to find its rank, or enter the size of the array (eg enter 5 for 0, 1, 2, 3, 4) and a $rank to find the corresponding perm.

Perm to rank

Your @perm =

example: 0, 3, 1, 2, 4

Rank to perm

Your $size = 0 ..
example: 5

Your $rank =

example: 18

Script

#!/usr/bin/perl

# Peter Campbell Smith - 2022-07-19
# PWC 174 task 2

use v5.28;
use strict;
use warnings;
use utf8;
binmode(STDOUT, ':utf8');

my (@tests, $test, $rank, $max, $perm);

# permutation must be some ordering of 0 .. $n - 1
@tests = ([1, 0, 2], [0, 2, 3, 1], [7, 3, 1, 0, 2, 6, 4, 5],
    [7, 14, 4, 11, 6, 0, 10, 1, 2, 3, 12, 5, 8, 13, 9],
    [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14]);
    
say qq[\n* Perm to rank *]; 

for $test (@tests) {
    $rank = permutation2rank(@$test);
    say qq[\nInput:  \@perm = ] . join(', ', @$test);
    say qq[Output: \$rank = $rank];
}

say qq[\n* Rank to perm *];

@tests = ([2, 2], [3, 3], [7, 37564], [14, 693492952393], [14, 0]);

for $test (@tests) {
    ($max, $rank) = @$test;
    $perm = rank2permutation($max, $rank);
    say qq[\nInput:  \$rank = $rank];
    say qq[Output: \@perm =  $perm]; 
}
    
sub permutation2rank {
    
    my (@p, $n, @fac, @ranks, $i, $rank, $this_rank, $k, $j, $digit, @seen);
        
    # input permutation and count no of elements
    @p = @_;
    $n = scalar @p;
    
    # calculate factorials up to $n - 1 and initialise @ranks
    # see blog for definition of @ranks
    $fac[0] = 1;
    $ranks[0] = 0;
    for $i (1 .. $n) {
        $k = $p[$i - 1];
        $fac[$i] = $fac[$i - 1] * $i;
        $ranks[$i] = $i;
        
        # check valid perm with 1 occurrence of 0 .. $n - 1
        return 'invalid permutation' if ($k < 0 or $k >= $n or $seen[$k]);
        $seen[$k] = 1;
    }
    
    # loop over the components of the permutation and calculate how each contributes to the rank
    $rank = 0;
    for $i (0 .. $n - 1) {
        
        # $ranks[$digit] is the contribution to the ranking of this digit given that 
        # some digits have already been seen and can't be in this ranking position
        $digit = $p[$i];
        
        # so this digit is in $ranks[$digit] block and the block occupies [$n - 1 - $i]! rows
        $this_rank = $ranks[$digit];
        $rank += $this_rank * $fac[$n - 1 - $i];

        # now we mark this digit as having been seen, so can't occur in subsequent positions
        $ranks[$digit] = -1;
        
        # and re-jig @ranks ready for the next digit (see blog)
        $k = 0;
        for $j (0 .. $n - 1) {
            next if $ranks[$j] < 0;
            $ranks[$j] = $k;
            $k ++;
        }       
    }
    return $rank;
}

sub rank2permutation {
    
    my ($n, $rank, @fac, @ranks, @rranks, $k, $perm, $i, $j);
    
    ($n, $rank) = @_;
    $n ++;
    
    # calculate factorials up to $n - 1 and initialise @ranks
    $fac[0] = 1;
    $ranks[0] = 0;
    for $i (1 .. $n - 1) {
        $fac[$i] = $fac[$i - 1] * $i;
        $ranks[$i] = $i;
    }
    
    # loop over the components of the permutation and calculate how each contributes to the rank
    $perm = '';
    for $i (0 .. $n - 1) {
        
        # calc $j = no of blocks, and subtract those from $rank
        $j = int($rank / $fac[$n - 1 - $i]);
        $rank -= $j * $fac[$n - 1 - $i];
        $perm .= qq[$ranks[$j], ];
        $ranks[$j] = -1;
        
        # and re-jig @ranks ready for the next digit
        $k = 0;
        for $j (0 .. $n - 1) {
            next if $ranks[$j] < 0;
            $ranks[$k] = $ranks[$j];
            $k ++;
        }   
    }
    return substr($perm, 0, -2);
}

Output

* Perm to rank *

Input:  @perm = 1, 0, 2
Output: $rank = 2

Input:  @perm = 0, 2, 3, 1
Output: $rank = 3

Input:  @perm = 7, 3, 1, 0, 2, 6, 4, 5
Output: $rank = 37564

Input:  @perm = 7, 14, 4, 11, 6, 0, 10, 1, 2, 3, 12, 5, 8, 13, 9
Output: $rank = 693492952393

Input:  @perm = 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14
Output: $rank = 0

* Rank to perm *

Input:  $rank = 2
Output: @perm =  1, 0, 2

Input:  $rank = 3
Output: @perm =  0, 2, 3, 1

Input:  $rank = 37564
Output: @perm =  7, 3, 1, 0, 2, 6, 4, 5

Input:  $rank = 693492952393
Output: @perm =  7, 14, 4, 11, 6, 0, 10, 1, 2, 3, 12, 5, 8, 13, 9

Input:  $rank = 0
Output: @perm =  0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14