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

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]

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 😁

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?