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
|
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
| [reply] [Watch: Dir/Any] [d/l] [select] |
|
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
| [reply] [Watch: Dir/Any] [d/l] [select] |
|
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
| [reply] [Watch: Dir/Any] [d/l] |
|
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 | [reply] [Watch: Dir/Any] [d/l] [select] |
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
|
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]
| [reply] [Watch: Dir/Any] [d/l] [select] |
|
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] [Watch: Dir/Any] [d/l] [select] |
|
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] [Watch: Dir/Any] [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] [Watch: Dir/Any] [d/l] |
|
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] [Watch: Dir/Any] [d/l] [select] |
|
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] [Watch: Dir/Any] [d/l] [select] |
|
| [reply] [Watch: Dir/Any] |
|
| [reply] [Watch: Dir/Any] |
|
Re: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's
by salva (Canon) on Sep 18, 2020 at 05:41 UTC
|
my $length = 10;
my $ones = 4;
my $str = ("1" x $ones) . ("0" x ($length - $ones));
while(1) {
print "$str\n";
$str =~ s/^(0*)(1*)10/${2}${1}01/ or last
}
| [reply] [Watch: Dir/Any] [d/l] |
Re: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's
by choroba (Cardinal) on Sep 18, 2020 at 07:09 UTC
|
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
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]);
}
}
my $ones = 3;
my $length = 10;
my $n = '0' x $length;
while ($length == length $n) {
increment($n);
next unless $ones == $n =~ tr/1//;
say $n;
}
map{substr$_->[0],$_->[1]||0,1}[\*||{},3],[[]],[ref qr-1,-,-1],[{}],[sub{}^*ARGV,3]
| [reply] [Watch: Dir/Any] [d/l] [select] |
|
my $length = 5;
my $str = "0" x $length;
my $start = $str . "1";
do {
print "$str\n";
} while ($str =~ s/^(1*0)/substr $start, -length $1/e)
| [reply] [Watch: Dir/Any] [d/l] |
Re: 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 07:46 UTC
|
One solution which I find pretty intuitive is to start with all zeros, and change N of thems into ones. Then the problems becomes "get all the combinations of three distinct positions", which can be achieved by using combination() function from Algorithm::Combinatorics.
use strict;
use warnings;
use feature 'say';
use Algorithm::Combinatorics qw(combinations);
my $length = 10;
my $ones = 2;
my $iter = combinations([0..$length-1], $ones);
while (my $positions = $iter->next)
{
my @data = (0,) x $length;
$data[$_] = 1 for @$positions;
say join "", @data;
}
Now for the matter of speed, if it's really that important you'll have to benchmark, but if you're going to print each string then print is probably going to make the execution time of generating the string insignificant. | [reply] [Watch: Dir/Any] [d/l] |
|
| [reply] [Watch: Dir/Any] [d/l] [select] |
|
| [reply] [Watch: Dir/Any] |
|
|
It returns far more results than needed, as they are repeated, because for permutations, zero at position 0 is different to zero at position 1.
map{substr$_->[0],$_->[1]||0,1}[\*||{},3],[[]],[ref qr-1,-,-1],[{}],[sub{}^*ARGV,3]
| [reply] [Watch: Dir/Any] [d/l] |
|
| [reply] [Watch: Dir/Any] |
Re: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's
by tybalt89 (Monsignor) on Sep 18, 2020 at 09:11 UTC
|
#!/usr/bin/perl
use strict; # https://perlmonks.org/?node_id=11121888
use warnings;
print "$_\n" for strings( 4, 10 );
sub strings
{
my ($ones, $length) = @_;
my @strings;
my $pattern = '(1?)' x $length;
(1 x $ones) =~ /^$pattern$(?{
push @strings, join '', map $_ || 0, @{^CAPTURE};
})(*FAIL)/x;
return @strings;
}
UPDATE: removed a useless join
| [reply] [Watch: Dir/Any] [d/l] |
Re: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's
by LanX (Saint) on Sep 18, 2020 at 08:43 UTC
|
There is a straight forward solution if the numbers of 1s are fixed.
I've realized too late that that number is supposed to be free too, so you need recursion (or fake it).
For completeness:
use strict;
use warnings;
use 5.12.0;
my $len = 5;
my $max = $len - 1;
for my $p0 ( 0 .. $max ) {
for my $p1 ( $p0+1 .. $max ) {
for my $p2 ( $p1+1 .. $max ) {
my $str = "0" x $len;
substr $str, $p0, 1, '1';
substr $str, $p1, 1, '1';
substr $str, $p2, 1, '1';
say "$str $p0 $p1 $p2";
}
}
}
C:/Perl_524/bin\perl.exe -w d:/tmp/pm/bitstrings.pl
11100 0 1 2
11010 0 1 3
11001 0 1 4
10110 0 2 3
10101 0 2 4
10011 0 3 4
01110 1 2 3
01101 1 2 4
01011 1 3 4
00111 2 3 4
Compilation finished at Fri Sep 18 10:43:25
| [reply] [Watch: Dir/Any] [d/l] [select] |
|
> so you need recursion (or fake it).
so here a recursive version with global variables (because I also wanted to provide a solution with two nested loops "faking" recursion, but gave up)
NB: it's optimized for the dual case, where it's easier to set 0s into a string full of 1s.
use 5.12.0;
use strict;
use warnings;
use Data::Dump qw/pp dd/;
use Test::More;
my $ones = 3;
my $len = 5;
my @res;
my ($zero,$one) = ('0','1');
# optimize dual case
if ($ones > $len/2) {
($zero,$one) = ($one,$zero);
$ones = $len-$ones;
}
my $max = $len - 1;
our $str = $zero x $len;
our $level = 0;
rec(0);
pp \@res;
sub rec {
local $level = $level + 1;
my ($start) =@_;
for my $idx ( $start .. $max ) {
local $str = $str;
substr $str, $idx, 1, $one;
if ($level < $ones) {
rec( $idx + 1 );
} else {
push @res, $str;
}
}
}
[
"00111",
"01011",
"01101",
"01110",
10011,
10101,
10110,
11001,
11010,
11100,
]
| [reply] [Watch: Dir/Any] [d/l] [select] |
Re: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's
by johngg (Canon) on Sep 18, 2020 at 10:07 UTC
|
This problem was visited before here and after a stupid first attempt I posted this solution, which I show again here. Note that my "permutary" routine should more accurately be called "combinatory" or something like! Posted here is code that will work for strings up to 50 or so ones and zeros but there is a version using Math::BigInt for longer strings included here.
use strict;
use warnings;
my ($numZeros, $numOnes) = @ARGV;
die qq{Usage: $0 number_of_zeros number_of_ones\n}
unless $numZeros =~ m{^\d+$} && $numOnes =~ m{^\d+$};
die qq{Maximum values of 53 to avoid precision errors\n}
if $numZeros > 53 || $numOnes > 53;
my $rcNextPerm = permutary($numZeros, $numOnes);
print qq{$_\n} while $_ = $rcNextPerm->();
sub permutary
{
no warnings q{portable};
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;
};
}
I'm not sure how it would stack up in the benchmarks but I seem to recall that a regex solution from that 2007 thread was faster.
Update: Regarding GrandFather's note about the limitation of 32-bit Perl in his benchmark, I developed the code on 64-bit Perl and hit a limit at about 53 digits for either zeros or ones. The Math::BigInt version's only limit was the user's patience!
| [reply] [Watch: Dir/Any] [d/l] |
Re: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's
by tybalt89 (Monsignor) on Sep 18, 2020 at 08:24 UTC
|
#!/usr/bin/perl
use strict; # https://perlmonks.org/?node_id=11121888
use warnings;
print "$_\n" for strings( 4, 10 );
sub strings
{
my ($ones, $length) = @_;
$length <= $ones ? 1 x $length : $ones < 1 ? 0 x $length :
( map("1$_", strings( $ones - 1, $length - 1 ) ),
map "0$_", strings( $ones, $length - 1 ) )
}
| [reply] [Watch: Dir/Any] [d/l] |
Re: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's
by tobyink (Canon) on Sep 18, 2020 at 10:40 UTC
|
For an especially slow solution, just read 10 bytes from /dev/random and test whether it contains seven 0s and three 1s. If it does, keep it. If it doesn't, discard it and repeat.
| [reply] [Watch: Dir/Any] |
|
| [reply] [Watch: Dir/Any] |
|
| [reply] [Watch: Dir/Any] |
Re: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's
by tybalt89 (Monsignor) on Sep 20, 2020 at 22:45 UTC
|
#!/usr/bin/perl
use strict; # https://perlmonks.org/?node_id=11121888
use warnings;
print "$_\n" for strings(10, 4); # length, number_of_ones
sub strings
{
my @strings = '';
my $zeros = $_[0] - $_[1];
my $ones = $_[1];
@strings = map +(
($@ = tr/1//) < $ones ? $_.1 : (),
length($_) - $@ < $zeros ? $_.0 : ()
), @strings for 1 .. $_[0];
return @strings;
}
| [reply] [Watch: Dir/Any] [d/l] |
Re: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's
by karlgoethebier (Abbot) on Sep 18, 2020 at 18:18 UTC
|
#!/usr/bin/env perl
use strict;
use warnings;
use Algorithm::Combinatorics qw(combinations);
use MCE::Loop;
MCE::Loop->init(
max_workers => 12, # what ever you have...
chunk_size => 'auto'
);
my $length = 10;
my $ones = 2;
mce_loop {
my ( $mce,
$chunk_ref,
$chunk_id ) = @_;
for ( @{$chunk_ref} ) {
something($_);
}
} combinations([0..$length-1], $ones);
sub something {
my $chunk_ref = shift;
...;
}
Unfortunately I can’t test because I don’t have access to my Mac because of relocation/renovation. I hope also that I didn’t miss the point. Regards, Karl
See also MCE::Loop
Minor update: Link added etc.
«The Crux of the Biscuit is the Apostrophe»
perl -MCrypt::CBC -E 'say Crypt::CBC->new(-key=>'kgb',-cipher=>"Blowfish")->decrypt_hex($ENV{KARL});'Help
| [reply] [Watch: Dir/Any] [d/l] [select] |
Re: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's
by perlfan (Vicar) on Sep 18, 2020 at 13:59 UTC
|
For computational efficiency, you'll want to use an "iterator" pattern. Search here, there are quite a few interesting posts about this. You can also read about them in section 4.3.1 of Dominus' Higher Order Perl. There are also quite a few CPAN modules that might help. | [reply] [Watch: Dir/Any] |
|
MJD's iterators are awesome, but not fast.
| [reply] [Watch: Dir/Any] |