Beefy Boxes and Bandwidth Generously Provided by pair Networks
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 ( #11121889=note: print w/replies, xml ) Need Help??


in reply to 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; }

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

    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//; 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

Log In?
Username:
Password:

What's my password?
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?