Perl all permutations of an array one by one

Question

i have an array, say

@array = qw(11 12 13 14 15);

I want to perform some operation and check a condition. If condition is met, i will exit my program, but if not met, i would like to update my array to next permutation in lexicographically order ie try with @array=qw(11 12 13 15 14);

Currently i am using this code:

sub permute {

    return ([]) unless (@_);
    return map {
                 my @cdr = @_;
                 my $car = splice @cdr, $_, 1;
                 map { [$car, @$_]; } &permute(@cdr);
               } 0 .. $#_;
}

my @array = qw(11 12 13 14 15);

foreach ( &permute(@array) ) {

    if ( condition met ) {
        print "@$_";
        exit;
    }
}

Problem: This code is running sub permute too many times. This is slowing my program by big time if array size is big. I don't want all permutation, i just need next permutation as long as my condition is not met. Suppose 100 permutation are possible, i want to start with 1st. If condition met, exit else move to 2nd,3rd etc etc. So, i want the method permute to run only to find next permutation and not all.

Please help.

Answer 1

This solution uses a simple recursive permutation algorithm and a callback function to process the permutations.

# Name       :  permute
# Parameters :  $array_ref
#               $start_idx
#               $callback_ref
#               @callback_params
# Description : Generate permutations of the elements of the array referenced
#               by $array_ref, permuting only the elements with index
#               $start_idx and above.
#               Call the subroutine referenced by $callback for each
#               permutation.  The first parameter is a reference to an
#               array containing the permutation.  The remaining parameters
#               (if any) come from the @callback_params to this subroutine.
#               If the callback function returns FALSE, stop generating
#               permutations.
sub permute
{
    my ( $array_ref, $start_idx, $callback_ref, @callback_params ) = @_;

    if ( $start_idx == $#{$array_ref} )
    {
        # No elements need to be permuted, so we've got a permutation
        return $callback_ref->( $array_ref, @callback_params );
    }

    for ( my $i = $start_idx; $i <= $#{$array_ref}; $i++ )
    {
        my $continue_permuting
            =   permute( [  @{$array_ref}[  0 .. ($start_idx - 1),
                                            $i,
                                            $start_idx .. ($i - 1),
                                            ($i+1) .. $#{$array_ref}  ] ],
                        $start_idx + 1,
                        $callback_ref,
                        @callback_params                                   );

        if (! $continue_permuting )
            { return 0; }
    }

    return 1;
}


# Name       :  handle_permutation
# Parameters :  $array_ref
#               $last_elem
#               $num_found_perms_ref
# Description : $array_ref is a reference to an array that contains
#               a permutation of elements.
#               If the last element of the array is $last_elem, output the
#               permutation and increment the count of found permutations
#               referenced by $num_found_perms_ref.
#               If 10 of the wanted permutations have been found, return
#               FALSE to stop generating permutations  Otherwise return TRUE.
sub handle_permutation
{
    my ( $array_ref, $last_elem, $num_found_perms_ref ) = @_;

    if ( $array_ref->[-1] eq $last_elem )
    {
        print '[ ';
        print join ', ', @{$array_ref};
        print " ]\n";

        return ( ++${$num_found_perms_ref} < 10 );
    }

    return 1;
}

# Print the first 10 permutations of 'a b c d e f' ending with 'a'
my $num_found_perms = 0;
permute(    [ qw{ a b c d e f } ], 0,
            \&handle_permutation, 'a', \$num_found_perms );

Instead of using a callback function you could also implement the permutation generation using an iterator. See What is the Perl version of a Python iterator? for ways of doing that.

Another option would be to use a thread or coroutine to generate the permutations and pass them on to the main program. See Can a Perl subroutine return data but keep processing? and Perl, how to fetch data from urls in parallel? for a useful overview of available technologies for doing this kind of processing.

Answer 2

Adapted from perl FAQ to resume permutations from certain point/array.

# Fischer-Krause ordered permutation generator
sub permute (&\@\@) {
    my $code = shift;
    my ($starting, $current) = @_;

    my %h;
    @h{@$starting} = 0 .. $#$starting;
    my @idx = @h{@$current};

    while ( $code->(@$starting[@idx]) ) {
        my $p = $#idx;
        --$p while $idx[$p-1] > $idx[$p];
        my $q = $p or return;
        push @idx, reverse splice @idx, $p;
        ++$q while $idx[$p-1] > $idx[$q];
        @idx[$p-1,$q]=@idx[$q,$p-1];
    }
}

# starting array
my @start   = qw(11 12 13 14 15);
# begin with permutations from @current array position
my @current = qw(11 12 13 15 14);
my $i = 3;
permute { print "@_\n"; return --$i } @start, @current;

Answer 3

You can check algorithm to generate next permutation in std::next_permutation and port it to perl. Following is an algorithmic implementation without using any language specific features and this should be fast enough for your requirement as it doesn't uses recursion.

// This function finds the index of the smallest character
// which is greater than 'first' and is present in str[l..h]
int findCeil (string str, char first, int l, int h)
{
    // initialize index of ceiling element
    int ceilIndex = l, i;

    // Now iterate through rest of the elements and find
    // the smallest character greater than 'first'
    for (i = l+1; i <= h; i++)
      if (str[i] > first && str[i] < str[ceilIndex])
            ceilIndex = i;

    return ceilIndex;
}

// Generate all permutation
string find_from_permutation ( string str )
{
    int size = str.length();
    bool isFinished = false;
    while ( ! isFinished )
    {
        int i;
        if( this_is_the_string_I_want(str) ) return str;

        // Find the rightmost character which is smaller than its next
        // character. Let us call it 'first char'
        for ( i = size - 2; i >= 0; --i )
           if (str[i] < str[i+1])
              break;

        // If there is no such character, all are sorted in decreasing order,
        // means we just printed the last permutation and we are done.
        if ( i == -1 )
            isFinished = true;
        else
        {
            // Find the ceil of 'first char' in right of first character.
            // Ceil of a character is the smallest character greater than it
            int ceilIndex = findCeil( str, str[i], i + 1, size - 1 );

            // Swap first and second characters
            swap( &str[i], &str[ceilIndex] );

            // Sort the string on right of 'first char'
            substring_sort(str, i+1); // sort substring starting from index i+1
        }
    }
    return null_string;
}

I hope porting above algo (pseudo C) to Perl should be straight forward.