Beefy Boxes and Bandwidth Generously Provided by pair Networks
Your skill will accomplish
what the force of many cannot

Combinations with constraints

by Anonymous Monk
on Jun 28, 2022 at 17:13 UTC ( #11145154=perlquestion: print w/replies, xml ) Need Help??

Anonymous Monk has asked for the wisdom of the Perl Monks concerning the following question:

Hi Monks, I am trying to write a function that takes a string argument $str of the form shown below (letter + weight) and need to generate all combinations with certain restrictions; for example, no repeating numbers. I also need a perlish way to move the letter $firstLetter with the largest weight into first position. The order of the other substrings do not matter. As a secondary restriction, I also want to ensure that the combination contains the substring $substring. So, for this particular $str example, [ c?6, b?2, a%3, a?1] is a valid combination.

Thank you very much for your help

use strict; use Math::Combinatorics; my $firstLetter="c"; my $str="a?1,a?2,a%3,b?2,b?3,b%5,c%4,c%5,c?6,d%2"; my $substring = "a?,b%,c?"; my @combos = Math::Combinatorics::combine(4,split ",",$str); foreach my $combo (@combos) { ## check if numbers are all unique my $hash = {}; my ($count) = grep { ++$hash->{$_} > 1 } map { (split '')[2] } @$c +ombo; next if defined $count; ## place $firstLetter with largest weight in first position ## ensure that substring strings are contained within the combinat +ion }

Replies are listed 'Best First'.
Re: Combinations with constraints
by hv (Parson) on Jun 28, 2022 at 18:52 UTC

    Could you clarify? You say the string is of the form "letter + weight", but I'm not sure how to parse the string in that sense. In "a?1", is "a" the letter and "1" the weight? If so, what role does "?" play?

    Based on the example $str and $substring, I'll treat the first two characters as a notional "token", and say that elements actually consist of a two-character token followed by the numeric weight.

    It appears the elements are unique, but neither tokens nor weights have to be.

    The $substring appears to list tokens, and my guess is that by "contained within" you mean that each of the listed tokens must appear as an element of a qualifying combination. Since "substring" usually implies both ordered and consecutive, I've renamed it to $subset below.

    It is not clear whether a qualifying combination can have repeated tokens. For example is (c?6, b%5, a?2, a?1)a valid combination? I've assumed below that it is valid.

    Since I've assumed order is not relevant to the qualification criteria, it seems that placing the largest weight first is simply a display requirement.

    Based on those assumptions, here's an attempt at some code:

    use strict; use warnings; use Math::Combinatorics; use List::Util qw{ all }; my $firstLetter = 'c'; my $str = 'a?1,a?2,a%3,b?2,b?3,b%5,c%4,c%5,c?6,d%2'; my $subset = 'a?,b%,c?'; print display($_, $firstLetter), "\n" for grep qualify($_, $subset), Math::Combinatorics::combine(4,split ",",$str); sub qualify { my($combo, $subset) = @_; # Check if numbers are all unique, using the "postincrement" trick my %seen; $seen{$_}++ or return 0 for map substr($_, 2), @$combo; # Find all the tokens in the combo. If all the ones we need in the # subset are represented, we're good. my %token = map +(substr($_, 0, 2) => 1), @$combo; return all { $token{$_} } split /,/, $subset; } sub display { my($combo, $first) = @_; # Use a Schwartzian transform over a reverse sort on our # calculated "firstness weight": -1 for elements with the wrong # first letter, else the element's weight. sort() is overkill here, # I'd use a different approach if we were considering larger sets. return join ',', map $_->[0], sort { $b->[1] <=> $a->[1] } map [ $_, substr($_, 0, 1) eq $first ? substr($_, 2) : -1 ], @$combo; }

    This outputs:

    c?6,a?1,a?2,b%5 c?6,a?1,a%3,b%5 c?6,a?1,b?2,b%5 c?6,a?1,b?3,b%5 c?6,c%4,a?1,b%5 c?6,a?1,b%5,d%2 c?6,a?2,a%3,b%5 c?6,a?2,b?3,b%5 c?6,c%4,a?2,b%5

    Does that look like the sort of thing you want?

      WOW. Thank you for your beautiful solution. Your assumptions are all correct. I wrote a version of it as well, but yours is infinitely more elegant. Thank you!
Re: Combinations with constraints
by tybalt89 (Prior) on Jun 28, 2022 at 21:02 UTC


    #!/usr/bin/perl use strict; # use warnings; use ntheory qw( forcomb ); use List::Util qw( all ); my $firstLetter = 'c'; my $str = 'a?1,a?2,a%3,b?2,b?3,b%5,c%4,c%5,c?6,d%2'; my $subset = 'a?,b%,c?'; my @str = sort { $b =~ $firstLetter <=> $a =~ $firstLetter or # sort o +nly once $b =~ tr/0-9//cdr <=> $a =~ tr/0-9//cdr } split /,/, $str; forcomb { my $comb = join ',', @str[@_]; $comb =~ /\b(\d+)\b.*\b\1\b/ or # duplicate number all { $comb =~ /\Q$_/ } split /,/, $subset and # each subset print "$comb\n"; } scalar @str, 4;


    c?6,c%4,b%5,a?2 c?6,c%4,b%5,a?1 c?6,b%5,a%3,a?2 c?6,b%5,a%3,a?1 c?6,b%5,b?3,a?2 c?6,b%5,b?3,a?1 c?6,b%5,a?2,a?1 c?6,b%5,b?2,a?1 c?6,b%5,d%2,a?1
Re: Combinations with constraints
by ikegami (Patriarch) on Jun 29, 2022 at 17:21 UTC

    Generating all the combinations then filtering out the unneeded ones could take a lot lot lot longer than necessary. This is what the earlier solutions do. However, the following program avoids generating extra combinations.

    use strict; use warnings; use feature qw( say ); use Algorithm::Loops qw( NestedLoops ); use Math::Combinatorics qw( combine ); use Sort::Key qw( rukeysort ); # Optional. my @strings = qw( a?1 a?2 a%3 b?2 b?3 b%5 c%4 c%5 c?6 d%2 ); my @mandatory_types = qw( a? b% c? ); my $n = 4; $n -= @mandatory_types; # ( [ "a?1", "a?", 1 ], ... ) my @split_strings = map { [ /^((.+)(\d+))\z/a ] } @strings; my %by_weight; for ( @split_strings ) { push @{ $by_weight{ $_->[2] } }, $_; } my @mandatory_lists = map { my $type = $_; [ grep { $_->[1] eq $type } @split_strings ] } @mandatory_types; my @loops; for my $list ( @mandatory_lists ) { push @loops, sub { my %seen_weights = map { $_->[2] => 1 } @_; return [ grep { !$seen_weights{ $_->[2] } } @$list ]; }; } my $mandatory_iter = NestedLoops( \@loops ); while ( my @mandatory_picks = $mandatory_iter->() ) { my %seen_weights = map { $_->[2] => 1 } @mandatory_picks; my @buckets = map { $by_weight{ $_ } } grep { !$seen_weights{ $_ } } keys( %by_weight ); my $bucket_iter = Math::Combinatorics->new( count => $n, data => \@buckets, ); while ( my @bucket_picks = $bucket_iter->next_combination() ) { my $other_iter = NestedLoops( \@bucket_picks ); while ( my @other_picks = $other_iter->() ) { say join ",", map { $_->[0] } rukeysort { $_->[2] } @mandatory_picks, @other_picks; } } }
    c?6,b%5,a?2,a?1 c?6,b%5,b?2,a?1 c?6,b%5,d%2,a?1 c?6,b%5,a%3,a?1 c?6,b%5,b?3,a?1 c?6,b%5,c%4,a?1 c?6,b%5,a%3,a?2 c?6,b%5,b?3,a?2 c?6,b%5,c%4,a?2 c?6,b%5,a?2,a?1

    More interesting test:

    my @strings = qw( a?1 a?2 a%3 b?2 b?3 b%5 c%4 c%5 c?6 d%2 a?7 c?7 ); my @mandatory_types = qw( a? b% c? ); # ^^^^^^^ my $n = 5; # ^
    a?7,c?6,b%5,a%3,a?1 a?7,c?6,b%5,b?3,a?1 c?7,c?6,b%5,a%3,a?1 c?7,c?6,b%5,b?3,a?1 a?7,c?6,b%5,a?2,a?1 a?7,c?6,b%5,b?2,a?1 a?7,c?6,b%5,d%2,a?1 c?7,c?6,b%5,a?2,a?1 c?7,c?6,b%5,b?2,a?1 c?7,c?6,b%5,d%2,a?1 a?7,c?6,b%5,c%4,a?1 c?7,c?6,b%5,c%4,a?1 c?6,b%5,a%3,a?2,a?1 c?6,b%5,a%3,b?2,a?1 c?6,b%5,a%3,d%2,a?1 c?6,b%5,b?3,a?2,a?1 c?6,b%5,b?3,b?2,a?1 c?6,b%5,b?3,d%2,a?1 c?6,b%5,c%4,a%3,a?1 c?6,b%5,c%4,b?3,a?1 c?6,b%5,c%4,a?2,a?1 c?6,b%5,c%4,b?2,a?1 c?6,b%5,c%4,d%2,a?1 c?7,c?6,b%5,c%4,a?1 c?7,b%5,c%4,a%3,a?1 c?7,b%5,c%4,b?3,a?1 c?7,b%5,c%4,a?2,a?1 c?7,b%5,c%4,b?2,a?1 c?7,b%5,c%4,d%2,a?1 c?7,c?6,b%5,a%3,a?1 c?7,c?6,b%5,b?3,a?1 c?7,c?6,b%5,a?2,a?1 c?7,c?6,b%5,b?2,a?1 c?7,c?6,b%5,d%2,a?1 c?7,b%5,a%3,a?2,a?1 c?7,b%5,a%3,b?2,a?1 c?7,b%5,a%3,d%2,a?1 c?7,b%5,b?3,a?2,a?1 c?7,b%5,b?3,b?2,a?1 c?7,b%5,b?3,d%2,a?1 c?6,b%5,c%4,a?2,a?1 a?7,c?6,b%5,c%4,a?2 c?7,c?6,b%5,c%4,a?2 c?6,b%5,c%4,a%3,a?2 c?6,b%5,c%4,b?3,a?2 a?7,c?6,b%5,a?2,a?1 c?7,c?6,b%5,a?2,a?1 c?6,b%5,a%3,a?2,a?1 c?6,b%5,b?3,a?2,a?1 a?7,c?6,b%5,a%3,a?2 a?7,c?6,b%5,b?3,a?2 c?7,c?6,b%5,a%3,a?2 c?7,c?6,b%5,b?3,a?2 c?7,b%5,a%3,a?2,a?1 c?7,b%5,b?3,a?2,a?1 c?7,b%5,c%4,a?2,a?1 c?7,c?6,b%5,a?2,a?1 c?7,b%5,c%4,a%3,a?2 c?7,b%5,c%4,b?3,a?2 c?7,c?6,b%5,a%3,a?2 c?7,c?6,b%5,b?3,a?2 c?7,c?6,b%5,c%4,a?2 a?7,c?6,b%5,c%4,a?2 a?7,c?6,b%5,c%4,b?2 a?7,c?6,b%5,c%4,d%2 a?7,c?6,b%5,a%3,a?2 a?7,c?6,b%5,b?3,a?2 a?7,c?6,b%5,a%3,b?2 a?7,c?6,b%5,b?3,b?2 a?7,c?6,b%5,a%3,d%2 a?7,c?6,b%5,b?3,d%2 a?7,c?6,b%5,a?2,a?1 a?7,c?6,b%5,b?2,a?1 a?7,c?6,b%5,d%2,a?1 a?7,c?6,b%5,c%4,a%3 a?7,c?6,b%5,c%4,b?3 a?7,c?6,b%5,c%4,a?1 a?7,c?6,b%5,a%3,a?1 a?7,c?6,b%5,b?3,a?1
Re: Combinations with constraints
by Anonymous Monk on Jun 28, 2022 at 17:18 UTC
    Sorry, correction: [ c?6, b%5, a%3, a?1] is a valid combination
      > Sorry, correction: [ c?6, b%5, a%3, a?1] is a valid combination

      That's wrong

      ("c?6", "a?1", "a?2", "b%5")

      is one, a%3 doesn't fit your substring criteria.

      > "a?,b%,c?"

      Cheers Rolf
      (addicted to the Perl Programming Language :)
      Wikisyntax for the Monastery

        Thanks for you comment, Rolf! It just has to contain the substring strings. Any additional strings within the combination are fine (they do not have to conform)

Log In?

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: perlquestion [id://11145154]
Approved by LanX
Front-paged by Corion
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others examining the Monastery: (3)
As of 2022-08-19 20:49 GMT
Find Nodes?
    Voting Booth?

    No recent polls found