Beefy Boxes and Bandwidth Generously Provided by pair Networks
Welcome to the Monastery
 
PerlMonks  

comment on

( #3333=superdoc: print w/replies, xml ) 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) }, });

In reply to Re^2: Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's [Updated] by salva
in thread Generate all unique combinations of 1 and 0 using specified length of "0"-string and count of 1's by Lana

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Are you posting in the right place? Check out Where do I post X? to know for sure.
  • Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
    <code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
  • Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
  • Want more info? How to link or How to display code and escape characters are good places to start.
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Chatterbox?
and the web crawler heard nothing...

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

    No recent polls found

    Notices?