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