#!/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) },
});