Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl Monk, Perl Meditation
 
PerlMonks  

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 ( #11121907=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

And here's a benchmark:
#!/usr/bin/perl use warnings; use strict; sub salva { my ($length, $ones) = @_; my $str = ("1" x $ones) . ("0" x ($length - $ones)); my @r; while(1) { push @r, $str; $str =~ s/^(0*)(1*)10/${2}${1}01/ or last; } return \@r } 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]); } } sub choroba { my ($length, $ones) = @_; my @r; my $n = '0' x $length; while ($length == length $n) { increment($n); push @r, $n if $ones == $n =~ tr/1//; } return \@r } sub GrandFather { my ($strLen, $numOnes) = @_; my @strings; 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' . $_} @{ GrandFather($tailLen, $numOnes - 1) }; } } return \@strings } use Algorithm::Combinatorics qw{ combinations permutations }; sub Eily { my ($length, $ones) = @_; my $iter = combinations([0..$length-1], $ones); my @r; while (my $positions = $iter->next) { my @data = (0,) x $length; $data[$_] = 1 for @$positions; push @r, join "", @data; } return \@r } sub Discipulus { my ($length, $ones) = @_; my %seen; @seen{ map { join "", @$_ } permutations( [ (0) x ($length - $ones), (1) x $ones] ) } = (); [ keys %seen ] } sub _tybalt89 { my ($length, $ones) = @_; $length <= $ones ? 1 x $length : $ones < 1 ? 0 x $length : ( map("1$_", _tybalt89( $length - 1, $ones - 1 ) ), map "0$_", _tybalt89( $length - 1, $ones ) ) } sub tybalt89 { [ _tybalt89(@_) ] } sub tybalt89_re { my ($length, $ones) = @_; my @strings; my $pattern = '(1?)' x $length; (1 x $ones) =~ /^$pattern$(?{ push @strings, join '', map $_ || 0, @{^CAPTU +RE}; })(*FAIL)/x; return \@strings } sub tybalt2 { my @strings = ''; my $zeros = $_[0] - $_[1]; my $ones = $_[1]; @strings = map +( ($@ = tr/1//) < $ones ? $_.1 : (), length($_) - $@ < $zeros ? $_.0 : () ), @strings for 1 .. $_[0]; return \@strings } 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 } sub johngg { my ($length, $ones) = @_; my $zeros = $length - $ones; my $rcNextPerm = _johngg($zeros, $ones); my @r; push @r, $_ while $_ = $rcNextPerm->(); \@r } sub _johngg { 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 } } sub Tux { 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) ] } use Test::More; use Test::Deep; cmp_deeply salva(10, 3), bag(@{ choroba(10, 3) }); cmp_deeply GrandFather(10, 3), bag(@{ choroba(10, 3) }); cmp_deeply Eily(10, 3), bag(@{ choroba(10, 3) }); cmp_deeply Discipulus(10, 3), bag(@{ choroba(10, 3) }); cmp_deeply tybalt89(10, 3), bag(@{ choroba(10, 3) }); cmp_deeply tybalt89_re(10, 3), bag(@{ choroba(10, 3) }); cmp_deeply tybalt2(10, 3), bag(@{ choroba(10, 3) }); cmp_deeply Eily_LanX(10, 3), bag(@{ choroba(10, 3) }); cmp_deeply johngg(10, 3), bag(@{ choroba(10, 3) }); cmp_deeply Tux(10, 3), bag(@{ choroba(10, 3) }); done_testing(); use Benchmark qw{ cmpthese }; cmpthese(-3, { salva => sub { salva(10, 3) }, choroba => sub { choroba(10, 3) }, GrandFather => sub { GrandFather(10, 3) }, Eily => sub { Eily(10, 3) }, Discipulus => sub { Discipulus(10, 3) }, tybalt89 => sub { tybalt89(10, 3) }, tybalt89_re => sub { tybalt89_re(10, 3) }, tybalt2 => sub { tybalt2(10, 3) }, Eily_LanX => sub { Eily_LanX(10, 3) }, johngg => sub { johngg(10, 3) }, Tux => sub { Tux(10, 3) }, });
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]
  • Comment on Re: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's [Updated]
  • 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 [Updated]
by GrandFather (Saint) on Sep 18, 2020 at 11:46 UTC

    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
Re^2: 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 09:43 UTC

    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% --
Re^2: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's [Updated]
by salva (Canon) on Sep 18, 2020 at 10:41 UTC
    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:

Re^2: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's [Updated]
by Tux (Canon) on Sep 18, 2020 at 12:46 UTC

    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
Re^2: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's [Updated]
by LanX (Sage) on Sep 18, 2020 at 13:50 UTC

      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 😁

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: note [id://11121907]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others exploiting the Monastery: (3)
As of 2022-12-03 20:27 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found

    Notices?