Maximise greatness

You are given an array of integers, @nums. Write a script to find of permutation @perm of @nums that gives the maximum possible greatness. Greatness is the number of elements where $perm[$i] > $nums[$i] for all $i.

Examples

Example 1
Input: @nums = (1, 3, 5, 2, 1, 3, 1)
Output: 4
One possible permutation: (2, 5, 1, 3, 3, 1, 1) which 
returns 4 greatness as below:
nums[0] < perm[0]
nums[1] < perm[1]
nums[3] < perm[3]
nums[4] < perm[4]

Example 2
Input: @ints = (1, 2, 3, 4)
Output: 3
One possible permutation: (2, 3, 4, 1) which 
returns 3 greatness as below:
nums[0] < perm[0]
nums[1] < perm[1]
nums[2] < perm[2]

Analysis

The obvious way to do this is to use one of the permutations modules to generate all the permutations of @nums and test each of them for greatness. That works, but gets increasingly slow as the size of @nums - call it $n - increases.

But there is a better way.

Let's make two observations:

• The maximum possible greatness is $n - 1. That is because there can never be a member of @perms that is greater than the largest member of @nums. Similarly, there can never be a member of @nums that is smaller than the smallest member of @perms. So while it may be possible to arrange $n - 1 members of @perms so that they are less than the corresponding member of @nums, you will then be left with the largest member of @nums and the smallest member of @perms, which are clearly not 'great'.
• The other observation is that the order of the members in @nums is not significant. If we reorder @nums, it will still have the same set of permutations and the same number of nums/perms pairs will show greatness.

So, in the light of the above, let's first sort @nums into ascending order. And let's for now assume that all the members of @nums are distinct, that is with no number duplicated. So here's an example, once we've sorted it:

1, 2, 3, 4, 5

Now let's choose the permutation which consists of rotating @nums one place to the left:

 @nums: 1, 2, 3, 4, 5
@perms: 2, 3, 4, 5, 1

And there we are: the first four pairs are great and the last deals with the largest nums and smallest perms, so we have achieved a greatness of the maximum possible, 4. We could then of course rearrange the nums/perms pairs in the order nums were originally given to us.

But what if there are duplications in @nums? Let's apply the same logic:

 @nums: 1, 2, 3, 3, 4
@perms: 2, 3, 3, 4, 1

We can see that the greatness has declined to 3 because the middle pair is not great and indeed that is the correct answer in this case - but not always. However, I have determined by experiment on >200 cases that repeating the left shift, several times if necessary, will always find the greatest permutation.

I have coded both the all-permutations and my methods and have timed them both. You can see that for a 9-element @nums with no repetition the permutations method takes about 2.5 seconds, whereas my method takes a mere 85 microseconds, and comes up with the same permutation (although in some cases it comes up with a different, equally great, permutation).

Do you want to avoid CPAN? Yes, it can be fun getting the hand dirty. Thank you for your contributions.

Try it 

#!/usr/bin/perl

use v5.16;    # The Weekly Challenge - 2023-10-02
use utf8;     # Week 237 task 2 - Maximise greatness
use strict;   # Peter Campbell Smith
use warnings; # Blog: http://ccgi.campbellsmiths.force9.co.uk/challenge

use Algorithm::Loops 'NextPermuteNum';
use Time::HiRes ('gettimeofday', 'tv_interval'); 
binmode(STDOUT, ':utf8');

my ($j, $k, @nums);

say qq[Output1 uses the permutations method and Output2
uses the algorithm described in my analysis.];

maximise_greatness(1, 3, 5, 2, 1, 3, 1);
maximise_greatness(1, 2, 3, 4);
maximise_greatness(9, 6, 3, 5, 1, 0, 8, 4, 14);
maximise_greatness(1, 2, 3, 1, 2, 3, 1, 2, 3);

sub maximise_greatness {
    
    my (@nums, @perms, $last, $greatness, $greatness_perm, $count, $j, $greatest, %seen, $distinct, $k,
        @sorted, @order, $n, $m, @best_perm, $t0, $elapsed);
    
    # FULL SEARCH OF PERMUTATIONS
    @nums = @_;
    $t0 = [gettimeofday];
    @perms = sort { $a <=> $b} @nums;
    $last = scalar @nums - 1;
    $greatness = 0;
    say qq[\nInput:   \@nums  = (] . join(', ', @nums) . ')';
    
    # loop over permutations
    do {
        
        # check list for greatness
        $count = 0;
        for $j (0 .. $last) {
            $count ++ if $nums[$j] < $perms[$j];
            last if $count + $last - $j <= $greatness;
        }
        
        # found a better one
        if ($count > $greatness) {
            $greatness = $count;
            $greatness_perm = join(', ', @perms);
        }
        $k ++;
        
    } while (NextPermuteNum(@perms) and $greatness != $last);
    
    $elapsed = int(tv_interval($t0) * 1000000);
    say qq[Output1: \@perms = ($greatness_perm)];
    say qq[      greatness = $greatness ($k permutations, time ${elapsed}μs)];
    
    # PETER'S IMPROVED METHOD
    $t0 = [gettimeofday];
    @sorted = sort { $a <=> $b} @nums;
    @perms = @sorted;
    $greatness = 0;
    
    # loop over left shifts
    K: for $k (0 .. $last - 1) {
        push(@perms, shift @perms);
        $count = 0;
        for $j (0 .. $last) {
            $count ++ if $sorted[$j] < $perms[$j];
            if ($count > $greatness) {
                $greatness = $count;
                @best_perm = @perms;
            }
            last K if $greatness == $last;
        }       
    }
    
    # unsort @best_perm into the same order as @nums
    for $j (0 .. $last) {
        $n = $nums[$j];
        for $k (0 .. $last) {
            if ($sorted[$k] == $n) {
                $m = $k;
                $sorted[$k] = 99999;
                last;
            }
        }
        $order[$j] = $best_perm[$m];
    }
    
    $elapsed = int(tv_interval($t0) * 1000000);
    say qq[Output2: \@perms = (] . join(', ', @order) . qq[)];
    say qq[      greatness = $greatness (time ${elapsed}μs)];
}

46 lines of code

Output from script

Output1 uses the permutations method and Output2
uses the algorithm described in my analysis.

Input:   @nums  = (1, 3, 5, 2, 1, 3, 1)
Output1: @perms = (1, 1, 1, 3, 2, 5, 3)
      greatness = 4 (420 permutations, time 8005μs)
Output2: @perms = (1, 5, 1, 3, 2, 1, 3)
      greatness = 4 (time 152μs)

Input:   @nums  = (1, 2, 3, 4)
Output1: @perms = (2, 3, 4, 1)
      greatness = 3 (10 permutations, time 275μs)
Output2: @perms = (2, 3, 4, 1)
      greatness = 3 (time 61μs)

Input:   @nums  = (9, 6, 3, 5, 1, 0, 8, 4, 14)
Output1: @perms = (14, 8, 4, 6, 3, 1, 9, 5, 0)
      greatness = 8 (355500 permutations, time 2484374μs)
Output2: @perms = (14, 8, 4, 6, 3, 1, 9, 5, 0)
      greatness = 8 (time 77μs)

Input:   @nums  = (1, 2, 3, 1, 2, 3, 1, 2, 3)
Output1: @perms = (2, 3, 1, 2, 3, 1, 2, 3, 1)
      greatness = 6 (1680 permutations, time 13577μs)
Output2: @perms = (2, 3, 1, 2, 3, 1, 2, 3, 1)
      greatness = 6 (time 80μs)