http://qs1969.pair.com?node_id=11121888

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

Hello Monks!

I am stuck with some trivial task. Maybe somebody could give me some idea on how to solve it.

I need to generate all possible combinations of "0" and "1" - at the specified lenght of "0"'s string and using specified count of "1"'s.

For example, I have a string of ten zeros - "0000000000", and I need to get all unique combinations using three ones. Like:

1110000000 1101000000 1100100000 1100010000 ...till... 0000100011 0000010011 0000001011 0000000111

It seems to be easy to do on a 10-zeros string just by iterating 1024 binary numbers and filtering out those not having three ones and seven zeros. But when it comes to long string of zeros, say 40, I have to iterate an enormous one trillion binary numbers which semms to be a very bad solution with giant overhead.

The count of "1" and length of "0" string may vary so I would prefer to have it as a subroutine, like:

sub GenUniStrings { my ($OnesCount, $ZeroStrLn) = @_; # some Perl magick goes here in loop, printing generated unique stri +ngs } GenUniStrings(3,25);

What is the best way to achieve that with minimal overhead and highest speed?

Thanks :)

Replies are listed 'Best First'.
Re: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's
by GrandFather (Saint) on Sep 18, 2020 at 04:21 UTC

    Recursion is the trick:

    use strict; use warnings; print "$_\n" for GenUniStrings(3, 10); sub GenUniStrings { my ($numOnes, $strLen) = @_; my @strings; die "Number of ones can't be zero or negative" if $numOnes < 1; for my $prefixSize (0 .. $strLen - $numOnes) { my $prefix = '0' x $prefixSize; my $tailLen = $strLen - $prefixSize - 1; if ($numOnes == 1) { push @strings, $prefix . '1' . ('0' x $tailLen); } else { push @strings, map {$prefix . '1' . $_} GenUniStrings($numOnes - 1, $tailLen); } } return @strings; }

    Prints:

    1110000000 1101000000 1100100000 1100010000 ...till... 0000001110 0000001101 0000001011 0000000111

    Update: minor code tidy

    Optimising for fewest key strokes only makes sense transmitting to Pluto or beyond

      This one ends up somewhere in the middle:

      sub tux_for { my ($length, $ones) = @_; [ map { substr unpack ("b*", $_), 0, $length } grep { $ones == unpack "%32b*" => $_ } map { pack "L<", $_ } 0 .. oct "0b".join""=> (1) x $ones, (0) x ($length - $ones) ]; }

      This one is 1200 x faster than Discipulus, but still 1200 x slower than the rest:

      use Algorithm::FastPermute; sub tux_a_fp { my ($length, $ones) = @_; my @l = ((0) x ($length - $ones), (1) x $ones); my %seen; permute { $seen{join "" => @l}++ } @l; [ keys %seen ]; }

      Enjoy, Have FUN! H.Merijn

      This one ends up somewhere in the middle:

      sub tux_for { my ($length, $ones) = @_; [ map { substr unpack ("b*", $_), 0, $length } grep { $ones == unpack "%32b*" => $_ } map { pack "L<", $_ } 0 .. oct "0b".join""=> (1) x $ones, (0) x ($length - $ones) ]; }

      Enjoy, Have FUN! H.Merijn

      Greetings,

      karlgoethebier pinged me to give parallel a try. I tried 2 versions using GrandFather's demonstration.

      Running serially:

      print "$_\n" for GenUniStrings(9, 25);

      Running parallel:

      This is possible. One way is generating a small sample as input data for the workers to process.

      my ($numOnes, $strLen) = (9, 25); my @input_data = uniq map { substr $_, 0, $numOnes - 1 } GenUniStrings($numOnes - 1, $numOnes * 2 - 2); print "$_\n" for @input_data; __END__ 11111111 11111110 11111101 11111100 11111011 11111010 11111001 11111000 ... 00000111 00000110 00000101 00000100 00000011 00000010 00000001 00000000

      MCE::Map:

      use strict; use warnings; use List::MoreUtils 'uniq'; use MCE::Map; sub GenUniStrings { # https://www.perlmonks.org/?node_id=11121889 my ($numOnes, $strLen) = @_; my @strings; die "Number of ones can't be zero or negative" if $numOnes < 1; for my $prefixSize (0 .. $strLen - $numOnes) { my $prefix = '0' x $prefixSize; my $tailLen = $strLen - $prefixSize - 1; if ($numOnes == 1) { push @strings, $prefix . '1' . ('0' x $tailLen); } else { push @strings, map {$prefix . '1' . $_} GenUniStrings($numOnes - 1, $tailLen); } } return @strings; } my ($numOnes, $strLen) = (9, 25); my @input_data = uniq map { substr $_, 0, $numOnes - 1 } GenUniStrings($numOnes - 1, $numOnes * 2 - 2); # print "$_\n" for @input_data; # exit; MCE::Map::init { max_workers => MCE::Util::get_ncpu() >> 1, chunk_size => 1, }; my @strings = mce_map { my $count = $numOnes - tr/1//; my $head = $_; map { $head . $_ } GenUniStrings($count, $strLen - length($head)); } @input_data; print "$_\n" for @strings;

      MCE workers writing directly to STDOUT:

      use strict; use warnings; use List::MoreUtils 'uniq'; use MCE; sub GenUniStrings { # https://www.perlmonks.org/?node_id=11121889 my ($numOnes, $strLen) = @_; my @strings; die "Number of ones can't be zero or negative" if $numOnes < 1; for my $prefixSize (0 .. $strLen - $numOnes) { my $prefix = '0' x $prefixSize; my $tailLen = $strLen - $prefixSize - 1; if ($numOnes == 1) { push @strings, $prefix . '1' . ('0' x $tailLen); } else { push @strings, map {$prefix . '1' . $_} GenUniStrings($numOnes - 1, $tailLen); } } return @strings; } my ($numOnes, $strLen) = (9, 25); my @input_data = uniq map { substr $_, 0, $numOnes - 1 } GenUniStrings($numOnes - 1, $numOnes * 2 - 2); # print "$_\n" for @input_data; # exit; STDOUT->autoflush; MCE->new( max_workers => MCE::Util::get_ncpu() >> 1, chunk_size => 1, input_data => \@input_data, init_relay => '', user_func => sub { my $count = $numOnes - tr/1//; my $head = $_; my @strings = map { $head . $_ } GenUniStrings($count, $strLen - length($head)); MCE::relay { print "$_\n" for @strings; }; } )->run;

      Results:

      Writing to STDOUT involves overhead in itself. Therefore, I reran again after validation and directed the output to /dev/null. The results were captured on a MacBook laptop. The serial demonstration is likely fast enough if also factoring writing to disk.

      $ time perl serial.pl >/dev/null real 0m5.957s user 0m5.851s sys 0m0.099s $ time perl mce_map.pl >/dev/null real 0m2.468s user 0m9.015s sys 0m0.596s $ time perl mce_relay.pl >/dev/null real 0m1.988s user 0m7.067s sys 0m0.507s

      Regards, Mario

Re: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's [Updated]
by choroba (Cardinal) on Sep 18, 2020 at 09:22 UTC
    And here's a benchmark:
    Rate Discipulus tybalt89_re choroba Tux johngg Ei +ly tybalt89 Eily_LanX GrandFather salva tybalt2 Discipulus 9.54e-02/s -- -100% -100% -100% -100% -10 +0% -100% -100% -100% -100% -100% tybalt89_re 1321/s 1383857% -- -2% -47% -51% -5 +1% -58% -71% -76% -79% -80% choroba 1346/s 1410770% 2% -- -46% -50% -5 +0% -57% -70% -76% -78% -80% Tux 2472/s 2590190% 87% 84% -- -9% - +9% -21% -45% -55% -60% -63% johngg 2709/s 2839387% 105% 101% 10% -- - +0% -13% -40% -51% -56% -60% Eily 2715/s 2845137% 106% 102% 10% 0% +-- -13% -40% -51% -56% -60% tybalt89 3130/s 3280107% 137% 132% 27% 16% 1 +5% -- -31% -44% -49% -54% Eily_LanX 4509/s 4725725% 241% 235% 82% 66% 6 +6% 44% -- -19% -27% -33% GrandFather 5547/s 5813004% 320% 312% 124% 105% 10 +4% 77% 23% -- -10% -18% salva 6179/s 6475626% 368% 359% 150% 128% 12 +8% 97% 37% 11% -- -9% tybalt2 6763/s 7088014% 412% 402% 174% 150% 14 +9% 116% 50% 22% 9% --
    map{substr$_->[0],$_->[1]||0,1}[\*||{},3],[[]],[ref qr-1,-,-1],[{}],[sub{}^*ARGV,3]

      Given the way various solutions are likely to scale it's worth running the benchmark for a range of values:

      length: 5, ones: 3 Rate Eily Eily_LanX choroba tybalt89 johngg GrandFather + tybalt89_re salva Eily 5209/s -- -8% -26% -35% -64% -67% + -70% -87% Eily_LanX 5640/s 8% -- -20% -29% -61% -64% + -67% -86% choroba 7013/s 35% 24% -- -12% -52% -56% + -59% -82% tybalt89 7967/s 53% 41% 14% -- -45% -49% + -54% -80% johngg 14517/s 179% 157% 107% 82% -- -8% + -15% -64% GrandFather 15765/s 203% 179% 125% 98% 9% -- + -8% -60% tybalt89_re 17169/s 230% 204% 145% 116% 18% 9% + -- -57% salva 39798/s 664% 606% 468% 400% 174% 152% + 132% -- length: 10, ones: 3 Rate choroba Eily Eily_LanX tybalt89 johngg tybalt89_re +GrandFather salva choroba 138/s -- -67% -74% -78% -83% -86% + -92% -95% Eily 420/s 204% -- -21% -33% -48% -56% + -76% -86% Eily_LanX 533/s 286% 27% -- -15% -34% -44% + -69% -82% tybalt89 626/s 353% 49% 17% -- -23% -34% + -64% -79% johngg 809/s 485% 93% 52% 29% -- -15% + -54% -73% tybalt89_re 955/s 591% 127% 79% 53% 18% -- + -45% -69% GrandFather 1744/s 1161% 315% 227% 178% 115% 83% + -- -43% salva 3041/s 2098% 623% 470% 385% 276% 218% + 74% -- length: 15, ones: 3 Rate choroba Eily tybalt89 Eily_LanX tybalt89_re johngg +GrandFather salva choroba 7.07/s -- -95% -96% -96% -96% -98% + -99% -99% Eily 131/s 1745% -- -17% -23% -26% -62% + -84% -87% tybalt89 157/s 2125% 21% -- -8% -11% -55% + -81% -85% Eily_LanX 171/s 2311% 31% 8% -- -3% -51% + -80% -84% tybalt89_re 177/s 2397% 35% 12% 4% -- -49% + -79% -83% johngg 347/s 4807% 166% 121% 104% 97% -- + -58% -66% GrandFather 834/s 11693% 539% 430% 389% 372% 140% + -- -19% salva 1036/s 14548% 694% 558% 508% 487% 198% + 24% -- length: 20, ones: 3 Rate Eily tybalt89_re tybalt89 Eily_LanX johngg GrandFa +ther salva Eily 39.2/s -- -27% -35% -40% -71% +-89% -91% tybalt89_re 54.0/s 38% -- -11% -17% -59% +-85% -87% tybalt89 60.7/s 55% 12% -- -7% -54% +-83% -86% Eily_LanX 65.3/s 67% 21% 8% -- -51% +-82% -85% johngg 133/s 240% 147% 120% 104% -- +-62% -69% GrandFather 355/s 806% 557% 485% 443% 166% + -- -17% salva 427/s 990% 691% 604% 554% 220% + 20% -- length: 30, ones: 3 Rate tybalt89_re Eily tybalt89 Eily_LanX johngg salva G +randFather tybalt89_re 10.7/s -- -4% -26% -38% -71% -91% + -91% Eily 11.2/s 5% -- -23% -35% -70% -90% + -91% tybalt89 14.5/s 36% 30% -- -16% -61% -87% + -88% Eily_LanX 17.4/s 62% 55% 19% -- -53% -85% + -86% johngg 37.2/s 247% 232% 156% 114% -- -68% + -69% salva 115/s 976% 929% 693% 564% 210% -- + -4% GrandFather 120/s 1020% 971% 726% 591% 223% 4% + -- length: 40, ones: 3 Rate tybalt89_re Eily tybalt89 salva Gra +ndFather tybalt89_re 3.40/s -- -22% -33% -93% + -94% Eily 4.37/s 29% -- -13% -91% + -92% tybalt89 5.04/s 48% 15% -- -90% + -91% salva 48.4/s 1323% 1007% 859% -- + -15% GrandFather 56.8/s 1572% 1201% 1027% 18% + -- length: 60, ones: 3 (warning: too few iterations for a reliable count) Rate tybalt89_re Eily tybalt89 Eily_LanX salva G +randFather tybalt89_re 0.676/s -- -34% -41% -69% -95% + -96% Eily 1.02/s 51% -- -10% -52% -92% + -94% tybalt89 1.14/s 69% 12% -- -47% -91% + -93% Eily_LanX 2.15/s 219% 110% 89% -- -84% + -87% salva 13.4/s 1888% 1212% 1076% 524% -- + -17% GrandFather 16.2/s 2303% 1486% 1322% 654% 21% + --

      choroba was dropped about half way through because it was slowing down dramatically. johngg dropped out after 30 because with a 32 bit Perl it only works out to a length of 32.

      Optimising for fewest key strokes only makes sense transmitting to Pluto or beyond

      With the power of Perlmonks::Combinatorics I combined Lanx's solution and mine:

      sub Eily_LanX { my ($length, $ones) = @_; my $iter = combinations([0..$length-1], $ones); my (@r, $str); while (my $positions = $iter->next) { $str = '0' x $length; substr $str, $_, 1, '1' for @$positions; push @r, $str; } return \@r }
      Rate salva tybalt89_re choroba tybalt89 Eily GrandFather + Eily_LanX salva 795/s -- -10% -57% -59% -62% -84% + -85% tybalt89_re 879/s 11% -- -52% -54% -59% -82% + -83% choroba 1842/s 132% 110% -- -4% -13% -63% + -64% tybalt89 1916/s 141% 118% 4% -- -10% -61% + -63% Eily 2120/s 167% 141% 15% 11% -- -57% + -59% GrandFather 4960/s 524% 464% 169% 159% 134% -- + -4% Eily_LanX 5154/s 548% 486% 180% 169% 143% 4% + --

        I remember, some time ago, looking under the hood of Algorithm::Combinatorics, to find it somewhat inefficient. The ntheory equivalents, if they exist, are faster:

        use ntheory 'forcomb'; sub Eily_LanX_vr { my ( $length, $ones ) = @_; my ( $str, $s, @r ); $str = '0' x $length; forcomb { $s = $str; substr $s, $_, 1, '1' for @_; push @r, $s; } $length, $ones; return \@r } cmpthese(-3, { Eily_LanX_vr => sub { Eily_LanX_vr(25, 5) }, Eily_LanX => sub { Eily_LanX(25, 5) }, }); __END__ Rate Eily_LanX Eily_LanX_vr Eily_LanX 11.9/s -- -59% Eily_LanX_vr 29.0/s 143% --
      Hey, you have not included the first solution I posted (Re: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's - appears as salva0 in the table bellow)!!!
      Rate salva1 tybalt89_re choroba Eily tybalt89 GrandFathe +r salva2 salva0 salva1 1085/s -- -27% -28% -63% -64% -81 +% -82% -82% tybalt89_re 1491/s 37% -- -1% -49% -51% -74 +% -75% -75% choroba 1500/s 38% 1% -- -49% -51% -74 +% -75% -75% Eily 2936/s 171% 97% 96% -- -3% -49 +% -51% -52% tybalt89 3036/s 180% 104% 102% 3% -- -47 +% -50% -50% GrandFather 5771/s 432% 287% 285% 97% 90% - +- -4% -5% salva2 6036/s 456% 305% 302% 106% 99% 5 +% -- -1% salva0 6084/s 461% 308% 305% 107% 100% 5 +% 1% --
      Then I have also added the following method (salva2) which uses caching, though it doesn't beat the regexp solution (salva0) either:
      my %cache; sub salva2 { my ($len, $ones) = @_; $cache{$len, $ones} //= do { if ($len > $ones) { if ($ones) { [ map("1$_", @{salva2($len - 1, $ones - 1)}), map("0$_", @{salva2($len - 1, $ones)})]; } else { [ "0" x $len ] } } else { [ "1" x $len ] } } }

      In any case, it should be taken into account that the position in the table may change greatly depending on the values of $len and $ones.

      My modified benchmarking script:

      I might have accidentally broken my previous post, so I just post the final results here. Not because my solutions are faster (tux_a_fp is sloooooow), but as they show TIMTOWTDI

      use Algorithm::FastPermute; sub tux_a_fp { my ($length, $ones) = @_; my @l = ((0) x ($length - $ones), (1) x $ones); my %seen; permute { $seen{join "" => @l}++ } @l; [ keys %seen ]; } sub tux_for { my ($length, $ones) = @_; my $s1 = "1" x $ones; my $s0 = "0" x ($length - $ones); [ map { substr unpack ("b*", $_), 0, $length } grep { $ones == unpack "%32b*" => $_ } map { pack "L<", $_ } oct "0b$s1" .. oct "0b$s1$s0" ]; } sub tux_tr { my ($length, $ones) = @_; my $s1 = "1" x $ones; my $s0 = "0" x ($length - $ones); [ grep { $ones == tr/1/1/ } map { substr unpack ("b*", pack "L<",$_), 0, $length } oct "0b$s1" .. oct "0b$s1$s0" ]; }

      update: another variation on recursion:

      sub tux_recur { my ($length, $ones) = @_; $length or return []; $ones or return [ "0" x $length ]; $ones == $length and return [ "1" x $length ]; [ ( map { "0$_" } @{tux_recur ($length - 1, $ones )} ), ( map { "1$_" } @{tux_recur ($length - 1, $ones - 1)} ), ]; }

      On my box ends between Eily and tybalt89. GrandFather is still the fastest:

      Discipulus 0.103/s tux_a_fp 1.43/s choroba 1496/s tybalt89_re 1558/s tux_tr 1777/s tux_for 2807/s johngg 2828/s Eily 2851/s tux_recur 2889/s tybalt89 3654/s salva 4187/s Eily_LanX 5110/s GrandFather 6119/s

      Enjoy, Have FUN! H.Merijn

        I mentioned your post because reading your it made me think "oh right, using substr is probably more efficient than changing then joining an array". Although it's not really the generalisation of your code. Also it let me make the Perlmonks::Combinatorics joke 😁

Re: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's
by salva (Canon) on Sep 18, 2020 at 05:41 UTC
    You can use a regular expression!!!
    my $length = 10; my $ones = 4; my $str = ("1" x $ones) . ("0" x ($length - $ones)); while(1) { print "$str\n"; $str =~ s/^(0*)(1*)10/${2}${1}01/ or last }
Re: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's
by choroba (Cardinal) on Sep 18, 2020 at 07:09 UTC
    The function to generate all binary numbers was shown in the solution to the Perl Weakly Challenge 049. Iterate its results and use tr to count the occurrences of ones:
    #!/usr/bin/perl use warnings; use strict; use feature qw{ say }; sub increment { my $pos = rindex $_[0], 0; if ($pos > -1) { substr $_[0], $pos, 1, '1'; substr $_[0], $pos + 1, length($_[0]) - $pos - 1, '0' x (length($_[0]) - $pos - 1); } else { $_[0] = '1' . ('0' x length $_[0]); } } my $ones = 3; my $length = 10; my $n = '0' x $length; while ($length == length $n) { increment($n); next unless $ones == $n =~ tr/1//; say $n; }

    map{substr$_->[0],$_->[1]||0,1}[\*||{},3],[[]],[ref qr-1,-,-1],[{}],[sub{}^*ARGV,3]
      Generating all the combination and then filtering out those that don't have the right number of ones can be pretty inefficient, specially when the number of zeros is big and the number of ones small.

      In any case, you can also use a regular expression for generating all the binary numbers of some given length :-)

      my $length = 5; my $str = "0" x $length; my $start = $str . "1"; do { print "$str\n"; } while ($str =~ s/^(1*0)/substr $start, -length $1/e)
Re: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's
by Eily (Monsignor) on Sep 18, 2020 at 07:46 UTC

    One solution which I find pretty intuitive is to start with all zeros, and change N of thems into ones. Then the problems becomes "get all the combinations of three distinct positions", which can be achieved by using combination() function from Algorithm::Combinatorics.

    use strict; use warnings; use feature 'say'; use Algorithm::Combinatorics qw(combinations); my $length = 10; my $ones = 2; my $iter = combinations([0..$length-1], $ones); while (my $positions = $iter->next) { my @data = (0,) x $length; $data[$_] = 1 for @$positions; say join "", @data; }
    Now for the matter of speed, if it's really that important you'll have to benchmark, but if you're going to print each string then print is probably going to make the execution time of generating the string insignificant.

      UPDATE this code is wrong as noticed by choroba and hippo. See below why

      L*

      There are no rules, there are no thumbs..
      Reinvent the wheel, then learn The Wheel; may be one day you reinvent one of THE WHEELS.

        This is neat code but is doing far too much work because it permutes every zero with every other zero (and also every one with every other one). eg. if you run it with 2 zeros and 2 ones you will get 4 duplicates for each answer. Increasing the numbers just makes the problem exponentially worse. Try with 9 zeros and 1 one and you'll soon see what I mean :-)


        🦛

        It returns far more results than needed, as they are repeated, because for permutations, zero at position 0 is different to zero at position 1.
        map{substr$_->[0],$_->[1]||0,1}[\*||{},3],[[]],[ref qr-1,-,-1],[{}],[sub{}^*ARGV,3]

        Yup. I guess it was just too obvious for me or something ^^".

Re: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's
by tybalt89 (Monsignor) on Sep 18, 2020 at 09:11 UTC

    Fun with regex :)

    #!/usr/bin/perl use strict; # https://perlmonks.org/?node_id=11121888 use warnings; print "$_\n" for strings( 4, 10 ); sub strings { my ($ones, $length) = @_; my @strings; my $pattern = '(1?)' x $length; (1 x $ones) =~ /^$pattern$(?{ push @strings, join '', map $_ || 0, @{^CAPTURE}; })(*FAIL)/x; return @strings; }

    UPDATE: removed a useless join

Re: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's
by LanX (Saint) on Sep 18, 2020 at 08:43 UTC
    There is a straight forward solution if the numbers of 1s are fixed.

    I've realized too late that that number is supposed to be free too, so you need recursion (or fake it).

    For completeness:

    use strict; use warnings; use 5.12.0; my $len = 5; my $max = $len - 1; for my $p0 ( 0 .. $max ) { for my $p1 ( $p0+1 .. $max ) { for my $p2 ( $p1+1 .. $max ) { my $str = "0" x $len; substr $str, $p0, 1, '1'; substr $str, $p1, 1, '1'; substr $str, $p2, 1, '1'; say "$str $p0 $p1 $p2"; } } }

    C:/Perl_524/bin\perl.exe -w d:/tmp/pm/bitstrings.pl 11100 0 1 2 11010 0 1 3 11001 0 1 4 10110 0 2 3 10101 0 2 4 10011 0 3 4 01110 1 2 3 01101 1 2 4 01011 1 3 4 00111 2 3 4 Compilation finished at Fri Sep 18 10:43:25

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

      > so you need recursion (or fake it).

      so here a recursive version with global variables (because I also wanted to provide a solution with two nested loops "faking" recursion, but gave up)

      NB: it's optimized for the dual case, where it's easier to set 0s into a string full of 1s.

      use 5.12.0; use strict; use warnings; use Data::Dump qw/pp dd/; use Test::More; my $ones = 3; my $len = 5; my @res; my ($zero,$one) = ('0','1'); # optimize dual case if ($ones > $len/2) { ($zero,$one) = ($one,$zero); $ones = $len-$ones; } my $max = $len - 1; our $str = $zero x $len; our $level = 0; rec(0); pp \@res; sub rec { local $level = $level + 1; my ($start) =@_; for my $idx ( $start .. $max ) { local $str = $str; substr $str, $idx, 1, $one; if ($level < $ones) { rec( $idx + 1 ); } else { push @res, $str; } } }

      [ "00111", "01011", "01101", "01110", 10011, 10101, 10110, 11001, 11010, 11100, ]

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

Re: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's
by johngg (Canon) on Sep 18, 2020 at 10:07 UTC

    This problem was visited before here and after a stupid first attempt I posted this solution, which I show again here. Note that my "permutary" routine should more accurately be called "combinatory" or something like! Posted here is code that will work for strings up to 50 or so ones and zeros but there is a version using Math::BigInt for longer strings included here.

    use strict; use warnings; my ($numZeros, $numOnes) = @ARGV; die qq{Usage: $0 number_of_zeros number_of_ones\n} unless $numZeros =~ m{^\d+$} && $numOnes =~ m{^\d+$}; die qq{Maximum values of 53 to avoid precision errors\n} if $numZeros > 53 || $numOnes > 53; my $rcNextPerm = permutary($numZeros, $numOnes); print qq{$_\n} while $_ = $rcNextPerm->(); sub permutary { no warnings q{portable}; my ($numZeros, $numOnes) = @_; my $format = q{%0} . ($numZeros + $numOnes) . q{b}; my $start = oct(q{0b} . q{1} x $numOnes); my $limit = oct(q{0b} . q{1} x $numOnes . q{0} x $numZeros); return sub { return undef if $start > $limit; my $binStr = sprintf $format, $start; die qq{Error: $binStr not $numOnes ones\n} unless $numOnes == $binStr =~ tr{1}{}; my $jump = 0; if ( $binStr =~ m{(1+)$} ) { $jump = 2 ** (length($1) - 1); } elsif ( $binStr =~ m{(1+)(0+)$} ) { $jump = 2 ** (length($1) - 1) + 1; $jump += 2 ** $_ for 1 .. length($2) - 1; } else { die qq{Error: $binStr seems malformed\n}; } $start += $jump; return $binStr; }; }

    I'm not sure how it would stack up in the benchmarks but I seem to recall that a regex solution from that 2007 thread was faster.

    Update: Regarding GrandFather's note about the limitation of 32-bit Perl in his benchmark, I developed the code on 64-bit Perl and hit a limit at about 53 digits for either zeros or ones. The Math::BigInt version's only limit was the user's patience!

    Cheers,

    JohnGG

Re: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's
by tybalt89 (Monsignor) on Sep 18, 2020 at 08:24 UTC
    #!/usr/bin/perl use strict; # https://perlmonks.org/?node_id=11121888 use warnings; print "$_\n" for strings( 4, 10 ); sub strings { my ($ones, $length) = @_; $length <= $ones ? 1 x $length : $ones < 1 ? 0 x $length : ( map("1$_", strings( $ones - 1, $length - 1 ) ), map "0$_", strings( $ones, $length - 1 ) ) }
Re: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's
by tobyink (Canon) on Sep 18, 2020 at 10:40 UTC

    For an especially slow solution, just read 10 bytes from /dev/random and test whether it contains seven 0s and three 1s. If it does, keep it. If it doesn't, discard it and repeat.

      Because of the "unique" requirement, you can add a cache as well, so that it can take a lot of memory as well as time.

        Only takes a lot of memory if you cache the unsuccessful hits.

Re: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's
by tybalt89 (Monsignor) on Sep 20, 2020 at 22:45 UTC

    And now for something completely different...

    #!/usr/bin/perl use strict; # https://perlmonks.org/?node_id=11121888 use warnings; print "$_\n" for strings(10, 4); # length, number_of_ones sub strings { my @strings = ''; my $zeros = $_[0] - $_[1]; my $ones = $_[1]; @strings = map +( ($@ = tr/1//) < $ones ? $_.1 : (), length($_) - $@ < $zeros ? $_.0 : () ), @strings for 1 .. $_[0]; return @strings; }
Re: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's
by karlgoethebier (Abbot) on Sep 18, 2020 at 18:18 UTC

    I wonder if something like this might be helpful/useful:

    #!/usr/bin/env perl use strict; use warnings; use Algorithm::Combinatorics qw(combinations); use MCE::Loop; MCE::Loop->init( max_workers => 12, # what ever you have... chunk_size => 'auto' ); my $length = 10; my $ones = 2; mce_loop { my ( $mce, $chunk_ref, $chunk_id ) = @_; for ( @{$chunk_ref} ) { something($_); } } combinations([0..$length-1], $ones); sub something { my $chunk_ref = shift; ...; }

    Unfortunately I can’t test because I don’t have access to my Mac because of relocation/renovation. I hope also that I didn’t miss the point. Regards, Karl

    See also MCE::Loop

    Minor update: Link added etc.

    «The Crux of the Biscuit is the Apostrophe»

    perl -MCrypt::CBC -E 'say Crypt::CBC->new(-key=>'kgb',-cipher=>"Blowfish")->decrypt_hex($ENV{KARL});'Help

Re: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's
by perlfan (Vicar) on Sep 18, 2020 at 13:59 UTC
    For computational efficiency, you'll want to use an "iterator" pattern. Search here, there are quite a few interesting posts about this. You can also read about them in section 4.3.1 of Dominus' Higher Order Perl. There are also quite a few CPAN modules that might help.
      MJD's iterators are awesome, but not fast.