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 перестановок, я хочу начать с 1-го. Если условие выполнено, выход else переместится на 2-й, 3-й и т. Д. И т. Д. Итак, я хочу, чтобы метод перестановки выполнялся только для поиска следующей перестановки и не для всех.

Пожалуйста, помогите.

Answer 1

Вы можете проверить алгоритм для генерации следующей перестановки в 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; 
} 

Я надеюсь, что портирование над алго (псевдо С) на Perl должно быть прямым.

Answer 2

Адаптировано из 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 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? для получения полезного обзора доступных технологий для такого вида обработки.