Perl 一个接一个数组的所有排列

Question

我有一个数组，比如

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

我想执行一些操作并检查条件。如果满足条件，我将退出我的程序，但如果不满足，我想按字典顺序将我的数组更新为下一个排列，即尝试使用 @array=qw（11 12 13 15 14）;

目前我正在使用以下代码：

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;
    }
}

问题：此代码运行子排列的次数过多。如果数组大小很大，这会大大减慢我的程序速度。我不想要所有的排列，只要我的条件不满足，我只需要下一个排列。假设 100 个排列是可能的，我想从 1st 开始。如果满足条件，则退出否则移动到第 2 个、第 3 个等。所以，我希望方法排列运行只是为了找到下一个排列，而不是全部。

请帮忙。

Answer 1

改编自 perl FAQ 以恢复从某些点/数组的排列。

# 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 2

你可以检查算法以在 std：：next_permutation 中生成下一个排列并将其移植到 perl。下面是一个不使用任何语言特定功能的算法实现，这应该足够快，因为它不使用递归。

// 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;
}

我希望将上面的算法（伪C）移植到Perl应该是直截了当的。

Answer 3

此解决方案使用简单的递归排列算法和回调函数来处理排列。

# 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 );

除了使用回调函数，您还可以使用迭代器实现排列生成。 请参阅什么是 Python 迭代器的 Perl 版本？为方法。

另一种选择是使用线程或协程生成排列并将它们传递给主程序。 请参阅 Perl 子例程可以返回数据但继续处理吗？和 Perl，如何并行从 url 获取数据？有关执行此类处理的可用技术的有用概述。