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等等。所以，我希望方法permute只运行以找到下一个排列而不是全部。

请帮忙。

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。 Following是一种算法实现，没有使用任何特定于语言的功能，这应该足够快，因为它不使用递归。

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

我希望将algo（伪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 );

您也可以使用迭代器实现排列生成，而不是使用回调函数。有关这方面的信息，请参见What is the Perl version of a Python iterator?。

另一个选择是使用线程或协同程序生成排列并将它们传递给主程序。有关进行此类处理的可用技术的有用概述，请参阅Can a Perl subroutine return data but keep processing?和Perl, how to fetch data from urls in parallel?。

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

3 个答案: