Re: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's

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;
}
[download]

Prints:

Update: minor code tidy

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

Comment on Re: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's Select or Download Code

Replies are listed 'Best First'.
Re^2: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's by Tux (Canon) on Sep 18, 2020 at 12:22 UTC
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) ]; }` [download] 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 ]; }` [download] Enjoy, Have FUN! H.Merijn	[reply] [d/l] [select]
Re^2: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's by Tux (Canon) on Sep 18, 2020 at 12:43 UTC
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) ]; }` [download] Enjoy, Have FUN! H.Merijn	[reply] [d/l]
Re^2: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's by marioroy (Prior) on Dec 29, 2020 at 05:01 UTC
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);` [download] 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` [download] 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; [download] 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; [download] 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` [download] Regards, Mario	[reply] [d/l] [select]


Perl: the Markov chain saw
	PerlMonks