Как я могу создать все подмножества размером меньше, чем n в Perl?

Question

У меня есть набор наборов.Я хочу создать все наборы, которые принимают не более одного элемента из каждого исходного набора.Например, если мой исходный набор наборов ((x,y),(A),(1,2)), то решения:

(x)
(y)
(A)
(1)
(2)
(x,A)
(x,1)
(x,2)
(y,A)
(y,A)
(y,1)
(y,2)
(A,1)
(A,2)
(x,A,1)
(x,A,2)
(y,A,1)
(y,A,2)

Я использую следующий код, который я написал, чтобы рекурсивно вычислить это:

# gets an array of arrays (aoa)
# returns an array of arrays with all subsets where zero or one element is
# taken from each array, e.g. in = [[a,b],[5],[X,Y,Z]], out =
# [[],[a],[b],[5],[X],[Y],[Z],[a,5],[b,5],[a,X],[a,Y],...,[b,5,Y],[b,5,Z]]
# note the order of elelemnts in each arry is immaterial (an array is
# considered an unordered set)
sub sets_aoa_to_subsets_aoa {
    my $aoa = shift // confess;

    if ( scalar( @{$aoa} ) == 0 ) {
        return [ [] ];
    }

    my $a           = shift @{$aoa};
    my $subsets_aoa = sets_aoa_to_subsets_aoa($aoa);
    my @new_subsets = ();
    foreach my $subset_a ( @{$subsets_aoa} ) {

        # leave subset as-is
        push @new_subsets, $subset_a;

        # add one element from $a
        foreach my $e ( @{$a} ) {
            push @new_subsets, [ $e, @{$subset_a} ];
        }
    }
    return \@new_subsets;

}

однакоЯ хотел бы добавить ограничение на размер подмножества.Например, если я установлю max_size=2, последние четыре решения будут проигнорированы.Я не могу просто сгенерировать все решения, а затем отфильтровать тех, кто слишком велик, так как иногда у меня есть более 100 наборов, каждый из которых содержит 2-3 элемента, и 2 ^ 100 не очень удобно для обработки, особенно когда я хочу только подмножествразмер 5 или меньше.

Answer 1

Также рекурсивное решение, но при этом передается подмножество встроенного софара, так что вы можете остановиться, как только достигнете максимального размера.

#!/opt/perl/bin/perl

use strict;
use warnings;
use 5.010;

sub subsets
{
    my ($sets, $maxSize, $subset) = @_;
    $subset //= [ ];

    # If we already have $maxSize elements, we're done
    return ($subset) if @$subset == $maxSize;

    # If we have no sets left to pick from, we're done
    return ($subset) if !@$sets;

    # Consider the next set
    my @remainingSets = @$sets;
    my $nextSet = shift(@remainingSets);

    # We can choose either 0 or 1 element from this set, continue with the rest
    return (subsets(\@remainingSets, $maxSize, $subset),
            map { subsets(\@remainingSets, $maxSize, [@$subset, $_]) }
                @$nextSet);
}

my $sets = [ [qw(x y)], [qw(A)], [qw(1 2)] ];
my @subsets = subsets($sets, 2);

foreach my $subset (@subsets) {
    say '(', join(', ', @$subset), ')';
}

Answer 2

Как я и подозревал, для этого работает регулярное выражение.

Конкретное решение

Вот конкретное решение вопроса в том виде, в котором оно сформулировано.Есть 80 ответов.

my %seen;

"xy=a=12" =~ m{
        [^=]* (x|y)* [^=]*
    =
        [^=]* (a)*   [^=]*
    =
        [^=]* (1|2)* [^=]*

    (?{ 
         my $size = grep { length } $1, $2, $3;
         print "<$1> <$2> <$3>\n"
            if $size >= 1 && 
               $size <= 2 &&
             ! $seen{$1,$2,$3}++;
    })
    (*FAIL)
}x;

Запустите по этому каналу cat -n, и вы увидите свои 80 ответов.

Конечно, вам нужно что-то обобщенное и расширяемое, чтобыВы можете применить его к вашей ситуации из ста комплектов.На создание общего решения всегда требуется больше времени, чем на конкретное, поэтому я поработаю над этим обобщением и свяжусь с вами, как только оно будет выглядеть красиво.

Общее решение

Вотобщее решение;это едва ли не моя самая красивая работа, но она работает :

#!/usr/bin/perl

use 5.010;
use strict;
use warnings;

our($MIN_PICK, $MAX_PICK) = (1, 2);

our @List_of_Sets = (
    [ qw[ x y ] ],
    [ qw[ a   ] ],
    [ qw[ 1 2 ] ],
);

sub dequeue($$) {
    my($leader, $body) = @_;
    $body =~ s/^\s*\Q$leader\E ?//gm;
    return $body;
}

################################

my $gunk     = " (?&gunk) ";
my $alter_rx = join("\n\t(?&post)\n" => map {
                  " $gunk ( "
                . join(" | " => map { quotemeta } @$_)
                . " ) * $gunk "
              } @List_of_Sets);
##print "ALTER_RX <\n$alter_rx\n>\n";

my $string = join(" = ", map { join(" ", @$_) } @List_of_Sets);
##print "STRING: $string\n";

my $numbers_list    = join(", " => map {  '$' . $_        } 1 .. @List_of_Sets);
my $numbers_bracket = join(" "  => map { '<$' . $_  . '>' } 1 .. @List_of_Sets);

my $print_statement = dequeue "|QQ|" => <<"PRINT_STATEMENT";

    |QQ|
    |QQ|    (?{
    |QQ|        no warnings qw(uninitialized);
    |QQ|        my \$size = grep { length } $numbers_list;
    |QQ|        print "$numbers_bracket\\n"
    |QQ|            if \$size >= $MIN_PICK &&
    |QQ|               \$size <= $MAX_PICK &&
    |QQ|             ! \$seen{$numbers_list}++;
    |QQ|    })
    |QQ|

PRINT_STATEMENT   
## print "PRINT $print_statement\n";

my $search_rx = do {
    use re "eval";
    my %seen;
    qr{
        ^
    $alter_rx
        $

    $print_statement

        (*FAIL)

        (?(DEFINE)
            (?<post>   =    )
            (?<gunk> [^=] * )
        )
    }x;
};
## print qq(SEARCH:\n"$string" =~ $search_rx\n);

# run, run, run!!
$string =~ $search_rx;

I am в некоторой степени связана с количеством возможностей, которые вы ожидаете извлечь из этого,Возможно, вам следует поместить этот процесс, который я описал выше, на другом конце канала, чтобы вы могли читать с него сколько угодно, а затем повесить трубку, так сказать, когда вы заполнили.

Я понимаю, что это довольно необычное решение;мой код часто таков.:)

Я просто полагаю, что вы могли бы сделать так, чтобы исчерпывающе-перестановочный характер обратного отслеживания регулярных выражений сделал всю работу за вас.

Возможно, другие возьмут Some::Abstruse::Module, чтобы сделать работу за вас.Вам просто нужно взвесить то, что вы предпочитаете.

РЕДАКТИРОВАТЬ : улучшенная разборчивость, обработанные дубликаты и дополнительные минимальные / максимальные критерии.

Answer 3

    foreach my $e ( @{$a} ) {
        push @new_subsets, [ $e, @{$subset_a} ];
    }

просто передайте параметр $items_wanted и пропустите выделенный бит кода, если @{$subset_a} > $items_wanted.Поскольку строки выше уже генерируют все комбинации, которые не добавляют дополнительные элементы, это будет работать без каких-либо дальнейших изменений.

Answer 4

вы можете создать «переменную состояния», которая будет отслеживать количество обращений к sets_aoa_to_subsets_aoa, а затем проверять это в вашем предельном состоянии:

{
    my $count=0;
    sub sets_aoa_to_subsets_aoa {
        $count++;
        my ($aoa,$number_of_calls) = @_ // confess;
    if ( (scalar( @{$aoa} ) == 0) or ($count == $number_or_calls)) {
            return [ [] ];
        }
    ......
    }
    }