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

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:

```#!/usr/bin/perl
use warnings;
use strict;

sub salva1 {
my (\$length, \$ones) = @_;
my \$str = "0" x \$length;
my \$start = \$str . "1";

my @r;
while (1) {
push @r, \$str if \$ones == \$str =~ tr/1//;
\$str =~ s/^(1*0)/substr(\$start, -length(\$1))/e or last
}
return \@r
}

sub salva0 {
my (\$length, \$ones) = @_;
my \$str = ("1" x \$ones) . ("0" x (\$length - \$ones));

my @r;
do {
push @r, \$str
} while (\$str =~ s/^(0*)(1*)10/\${2}\${1}01/);
return \@r
}

my %cache;

sub salva2 {
my (\$len, \$ones) = @_;
my \$ref = \$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 ]
}
};
\$ref
}

sub salva2_clear {
%cache = ();
salva2(@_)
}

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);
next unless \$ones == \$n =~ tr/1//;
push @r, \$n;
}
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
}

# use List::Util qw{ uniq };
# sub Discipulus {
#     my (\$length, \$ones) = @_;
#     [ uniq map { join "", @\$_ } permutations( [ (0) x (\$length - \$on
+es), (1) x \$ones] ) ]
# }

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 = join '', ('(1?)') x \$length;
(1 x \$ones) =~ /^\$pattern\$(?{
push @strings, join '', map \$_ || 0,  @{^CAPTU
+RE};
})(*FAIL)/x;
return \@strings
}

use Test::More;
use Test::Deep;

my \$len = 10;
my \$ones = 4;

cmp_deeply
salva0(\$len,\$ones),
bag(@{ GrandFather(\$len, \$ones) });

cmp_deeply
salva1(\$len, \$ones),
bag(@{ GrandFather(\$len, \$ones) });

cmp_deeply
salva2_clear(\$len, \$ones),
bag(@{ GrandFather(\$len, \$ones) });

cmp_deeply
choroba(\$len, \$ones),
bag(@{ GrandFather(\$len, \$ones) });

cmp_deeply
Eily(\$len, \$ones),
bag(@{ GrandFather(\$len, \$ones) });

# cmp_deeply
#     Discipulus(\$len, \$ones),
#     bag(@{ GrandFather(\$len, \$ones) });

cmp_deeply
tybalt89(\$len, \$ones),
bag(@{ GrandFather(\$len, \$ones) });

cmp_deeply
tybalt89_re(\$len, \$ones),
bag(@{ GrandFather(\$len, \$ones) });

done_testing();

use Benchmark qw{ cmpthese };
cmpthese(-3, {
salva0      => sub { salva0(\$len, \$ones) },
salva1      => sub { salva1(\$len, \$ones) },
salva2      => sub { salva2_clear(\$len, \$ones) },
choroba     => sub { choroba(\$len, \$ones) },
GrandFather => sub { GrandFather(\$len, \$ones) },
Eily        => sub { Eily(\$len, \$ones) },
#    Discipulus  => sub { Discipulus(\$len, \$ones) },
tybalt89    => sub { tybalt89(\$len, \$ones) },
tybalt89_re => sub { tybalt89_re(\$len, \$ones) },
});
• Comment on Re^2: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's [Updated]

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

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

No recent polls found

Notices?