Problems? Is your data what you think it is? PerlMonks

### 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 Need Help??

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
• Comment on Re: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's

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)
];
}

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
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)
];
}

Enjoy, Have FUN! H.Merijn
Re^2: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's
by marioroy (Parson) 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);

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//;
} @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 @strings = map { \$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

Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: note [id://11121889]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others romping around the Monastery: (5)
As of 2022-12-03 18:22 GMT
Sections?
Information?
Find Nodes?
Leftovers?
Voting Booth?

No recent polls found

Notices?