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