thenetfreaker has asked for the
wisdom of the Perl Monks concerning the following question:
Hello dear monks,
I'm trying to create a function that by getting a number of Ones and Zeroes (if possible also the number of the generation) shall give eventually give all the conbinations without repeats, because Algorithm::Combinatorics can't differ 2 zeroes( for it 010 and 010 is different, but for me it's the same).
I've come with an idea of printing them chronologically like (if $ones=2 and $zeroes=3):
00011
00101
01001
10001
00110
01010
10010
01100
10100
11000
where these 10 are all variations without repeats.
i tried achieving my goal in 2 ways :
1. trying to simply print then like that 
sub combinationN {
my ($O,$Z,$current) = @_;
my $string = '';
my $toMove = 0;
my @states;
my $now = $current  ($current$Z);
$states[0] = $current;
while ($current > $Z) {
$current = $now+1;
$states[$toMove] = $current % ($Z+1);
$toMove++;
}
for (1..$Z$states[0]) {$string .= '0'}
for (1..$O$toMove) {$string .= '1'}
# foreach (@states) {
for (1..$states[0]) {$string .= '0'}
for (1..$toMove) {$string .= '1'}
# }
print "$string\n";
return $string
}
but this gave out
00011
00110
01100
11000
00101
01001
10001
and afterwars there were strange thigs like 000110000, etc;
also it didn't print 00110,01010,...,01100,etc.
2. printing them by distanses from zero to one using a flipFlop flag (after a set of ones there must com a set of zeroes and the opposite) 
sub combinationN {
my ($O,$Z,$current,$tL) = @_;
my $string = '';
my $ff = 1;
my $Dc = 0;
my $Oc = int($current % $O); ##
my $Zc = int($current % $Z); ##
my $place = 1;
while ($tL > $place) {
if ($ff eq 1) {
$Dc = $O$Oc;
for (1..$Dc) {$string .= '1'}
$Oc = $Dc;
} else {
$Dc = $Z$Zc;
for (1..$Dc) {$string .= '0'}
$Zc = $Dc;
}
$place += $Dc;
$ff *= 1;
}
print "$string\n";
return $string
}
but this gave out
11000
1001
11000
1000
1100
10100
11000
1001
and many other strange reasults.
I searched Google and GoogleCodesearch and the only similar things i found were connected to colors and cropping the results that repeated (but still all the results( 24! ) were checked).
Is there a simple logical way to print it out( using map() or/and join()) or fixing one of the codes i tried ?
Re: One Zero variants_without_repetition by BrowserUk (Pope) on Aug 07, 2007 at 10:56 UTC 
print unpack 'B8', chr for 0 .. 255;;
00000000
00000001
00000010
00000011
00000100
00000101
...
11111011
11111100
11111101
11111110
11111111
Examine what is said, not who speaks  Silence betokens consent  Love the truth but pardon error.
"Science is about questioning the status quo. Questioning authority".
In the absence of evidence, opinion is indistinguishable from prejudice.
 [reply] [d/l] 

no, i need to print all the variations with a spesific number of ones and zeroes without repeats, for example all the variants with 6 zeroes and 14 ones.
as i gave the example earlier with 2 ones and 3 zeroes.
 [reply] 

Okay, sorry! Try this iterator then. It will handle upto 32 0s + 1s.
If you uncomment the second example it runs on a bit.
Update: Had to tweak the termination condition. It works now but I'm not happy with it.
Update2: D'oh! No need to count both 1s and 0s.
#! perl slw
use strict;
sub combs {
my( $ones, $zeros ) = @_;
my $n = $ones+$zeros;
my $max = 2**$n;
my $p = 0;
return sub {
my $x = '';
$x = unpack "b$n", pack 'V', $p++
until $x =~ tr[1][] == $ones
or $p > $max and return;
return $x;
}
}
my $iter = combs( 2, 3 );
print while $_ = $iter>();
#my $iter = combs( 14, 6 );
#print while $_ = $iter>();
__END__
C:\test>junk7
11000
10100
01100
10010
01010
00110
10001
01001
00101
00011
Examine what is said, not who speaks  Silence betokens consent  Love the truth but pardon error.
"Science is about questioning the status quo. Questioning authority".
In the absence of evidence, opinion is indistinguishable from prejudice.
 [reply] [d/l] 


Re: One Zero variants_without_repetition by GrandFather (Sage) on Aug 07, 2007 at 11:03 UTC 
Presuming you don't care about the order, the following may be what you are after:
use strict;
use warnings;
for my $left (1 .. 4) {
for my $right (0 .. $left 1) {
printf "%05b\n", (1 << $left)  (1 << $right);
}
}
Prints:
00011
00101
00110
01001
01010
01100
10001
10010
10100
11000
DWIM is Perl's answer to Gödel
 [reply] [d/l] [select] 

i changed a bit you code to :
my $places = 6;
for my $left (1..$places1) {
for my $right (0 .. $left 1) {
printf "%0$places"."b\n", (1 << $left)  (1 << $right);
}
}
and saw it works only with 2 ones...
and what if i have 6 ones and 14 zeroes ? do i have to do 6 for() loops ???  [reply] [d/l] 

use strict;
use warnings;
doShift (2, 5);
print "\n";
doShift (3, 6);
print "\n";
sub doShift {
my ($ones, $bits, $pattern, $limit) = @_;
$ones;
$limit = $bits;
$pattern = 0;
for my $right ($ones .. $limit  1) {
if ($ones) {
doShift ($ones, $bits, $pattern  (1 << $right), $right);
} else {
printf "%0*b\n", $bits, $pattern  (1 << $right);
}
}
}
Prints:
00011
00101
00110
01001
01010
01100
10001
10010
10100
11000
000111
001011
001101
001110
010011
010101
010110
011001
011010
011100
100011
100101
100110
101001
101010
101100
110001
110010
110100
111000
DWIM is Perl's answer to Gödel
 [reply] [d/l] [select] 



 

Re: One Zero variants_without_repetition by grinder (Bishop) on Aug 07, 2007 at 12:21 UTC 
use strict;
use warnings;
my $zero = shift  3;
my $one = shift  2;
my @array = ( (0) x $zero, (1) x $one );
# print "@array\n";
print join ('', @array), "\n";
while (1) {
my $cand = $#array;
while ($cand) {
if ($array[$cand1] == 0 and $array[$cand] == 1) {
($array[$cand1], $array[$cand]) = ($array[$cand], $array[
+$cand1]);
if ($cand < $#array) {
@array[$cand+1..$#array] = sort @array[$cand+1..$#arra
+y];
}
last;
}
$cand;
}
last unless $cand;
# print "@array\n";
print join ('', @array), "\n";
}
Converting this to an iterator is left as an exercise to the reader (update:) remarkably trivial :)
sub iter {
my $zero = shift  3;
my $one = shift  2;
my $init = 0;
my @array = ( (0) x $zero, (1) x $one );
return sub {
$init++ or return join('', @array);
my $cand = $#array;
while ($cand) {
if ($array[$cand1] == 0 and $array[$cand] == 1) {
($array[$cand1], $array[$cand]) = ($array[$cand], $ar
+ray[$cand1]);
if ($cand < $#array) {
@array[$cand+1..$#array] = sort @array[$cand+1..$#
+array];
}
last;
}
$cand;
}
return $cand ? join( '', @array) : undef;
}
}
my $i = iter(@ARGV);
while (my $str = $i>()) {
print "$str\n";
}
update: tye was right (of course!), the sort may be advantageously replaced by a reverse. Furthermore, there is no point in reversing (or sorting) a oneelement array...
$cand < $#array  1 and
@array[$cand+1..$#array] = reverse @array[$cand+1..$#array];
• another intruder with the mooring in the heart of the Perl
 [reply] [d/l] [select] 

Extrordinaly nice, but whay does it do extra checks  crop some results ?
i simply added a counter($inC=0), in the beginning and told it to ++ before $cand;, and at the end it printed 14 instead of 10, and only ehen i put the $inC++ before the print in the while() it printed 10.
i'm sorry to repeat that i work with hundreds of 1's and 0's, and every false checking costs.
All of your code are wonderful, but unfortunatly i like the second code i posted the most, it only needs to get fixed in the part where it gets the $Oc and $Zc; i would have replaces this while() to a foreach() of an array that contains all the distances between ones and zeroes sets(e.g, in the string 0010111 the distance's array should look like qw(2 1 1 3)), but for that i need to know all the distances variaties( without repetition) from @distances= ($ones, $zeroes) upto @distances= ($zeroes, $ones) when the @distances reach the array of $ones+$zeroes1 times 1 ( if $ones=2 and $zeroes=3, when @distances=(1,1,1,1,1)) the rest of the @distances are the reverse of the previose sets in reverse:
11000 [2 3]
10100 [1 1 1 2]
10010 [1 2 1 1]
10001 [1 3 1]
10011 [1 2 2]
01010 [0 1 1 1 1]
01001 [0 1 2 1]
00110 [0 2 2 1]
00101 [0 2 1 1 1]
00011 [0 3 2]
 [reply] [d/l] 

Extrordinaly nice, but whay does it do extra checks  crop some results ?
What extra checks? It just hunts through the array, looking for a 0, 1 pair to swap to 1, 0. If it does so, it sorts the tail of the array that it has already walked past so that 0, 1, 1, 0 becomes 1, 0, 0, 1 (instead of 1, 0, 1, 0). The if check is just to avoid sorting empty length subarrays.
All of your code are wonderful, but unfortunatly i like the second code i posted the most
Yeah, but if it produces garbage, what's the point? There's no point in hanging onto code that doesn't work. Your problem interests me as an intellectual challenge, but I cannot summon the motivation to debug your code :)
I imagine my code would be very efficient up to several hundred elements. At some point it would become more efficient to examine the tail, count the 0s and 1s, and splice in a newlyconstructed tail on the fly, thereby avoiding the sort:
my ($zero, $one) = (0, 0);
for my $element (@array[$cand+1..$#array]) {
$element  ++$zero;
$element && ++$one;
}
@array[$cand+1..$#array] = ((0) x $zero, (1) x $one);
The counting of 0s and 1s is a tad ugly, I admit, but it avoids creating a lexical scope that a classic if/else block would involve.
• another intruder with the mooring in the heart of the Perl
 [reply] [d/l] 

 [reply] 
Re: One Zero variants_without_repetition by Limbic~Region (Chancellor) on Aug 07, 2007 at 12:26 UTC 
 [reply] 

use strict;
use Algorithm::Loops qw( NestedLoops );
my $bits= 8;
my $ones= 5;
my $iter= NestedLoops(
[ [ 0 .. $bits1 ],
( sub {
[ 1+$_[1] .. $bits1 ]
}
) x ($ones1),
],
);
my @ones;
while( @ones= $iter>() ) {
my @bits= (0) x $bits;
@bits[@ones]= (1) x $ones;
print join '', @bits, $/;
}
Which is like
my $bits= 8;
for my $o0 ( 0 .. $bits1 ) {
for my $o1 ( 1+$o0 .. $bits1 ) {
for my $o2 ( 1+$o1 .. $bits1 ) {
for my $o3 ( 1+$o2 .. $bits1 ) {
for my $o4 ( 1+$o3 .. $bits1 ) {
my @bits= (0) x $bits;
@bits[$o0,$o1,$o2,$o3,$o4]= (1)x5;
}
}
}
}
}
Except that the number of ones (and thus the number of nested loops) isn't hardcoded.
Update: You can also avoid some looping at the tail end by setting tight top limits:
use strict;
use Algorithm::Loops qw( NestedLoops );
my $bits= 8;
my $ones= 5;
my $iter= NestedLoops(
[ [ 0 .. $bits  $ones ],
map(
{ # Need lexical for closure
my $top= $bits  $ones + $_;
sub {
[ 1+$_[1] .. $top ]
}
}
1 .. $ones1,
),
],
);
my @ones;
while( @ones= $iter>() ) {
my @bits= (0) x $bits;
@bits[@ones]= (1) x $ones;
print join '', @bits, $/;
}
 [reply] [d/l] [select] 
Re: One Zero variants_without_repetition by bduggan (Pilgrim) on Aug 07, 2007 at 15:10 UTC 
A natural way to do this seems to me to think of it as the number of ways of placing the ones in a string of size $ones + $zeros :
use Algorithm::ChooseSubsets;
use strict;
my $ones = 2;
my $twos = 3;
my $i = Algorithm::ChooseSubsets>new($ones + $twos,$ones);
while (my $x = $i>next) {
my %on = map {($_ => 1)} @$x;
my @str = map { $on{$_} ? '1' : '0' } (0..$ones+$twos1);
print @str,"\n";
}
 [reply] [d/l] 
Re: One Zero variants_without_repetition by johngg (Abbot) on Aug 07, 2007 at 19:38 UTC 
How about using a string and shuffle the ones from right to left using substr.
use strict;
use warnings;
my $raCombinations = combinary(4, 7);
print qq{$_\n} for @$raCombinations;
sub combinary
{
my ($numZeros, $numOnes) = @_;
my $str = q{0} x $numZeros . q{1} x $numOnes;
my @combinations = ($str);
my $leftPtr = 0;
for my $thisOne ( 1 .. $numOnes )
{
for (
my $offset = $numZeros + $thisOne  2;
$offset >= $leftPtr;
$offset 
)
{
substr $str, $offset, 2, q{10};
push @combinations, $str;
}
$leftPtr ++;
}
return \@combinations;
}
produces
00001111111
00010111111
00100111111
01000111111
10000111111
10001011111
10010011111
10100011111
11000011111
11000101111
11001001111
11010001111
11100001111
11100010111
11100100111
11101000111
11110000111
11110001011
11110010011
11110100011
11111000011
11111000101
11111001001
11111010001
11111100001
11111100010
11111100100
11111101000
11111110000
I don't know whether this approach will be slower or faster than other suggestions. It's just the first idea that occurred to me. Cheers, JohnGG  [reply] [d/l] [select] 

I gather that the OP also wants strings like:
00011011111
00011101111
00011110111
00011111011
00011111101
00011111110
00110011111
00111001111
...
which your code didn't get around to. (And apparently, expecting to hold all results in memory before outputting them may be unrealistic.)  [reply] [d/l] 

 [reply] 

You are right about these strings that it doesn't get, as well as:
.
.
.
01001011111
.
.
.
11011001011
.
.
etc
but i don't need to hold them in memory, i simply check each one of them individually and move to the other;
but this algorithm surely seems to work Fast.
If only to fix it a bit to show every variation like the ones you stated, considering it shall slow in twice or three times, with will be wonderful.  [reply] [d/l] 
having fun with RE  was: Re: One Zero variants_without_repetition by oha (Friar) on Aug 08, 2007 at 15:14 UTC 
some fun, at least for me!
$_ = "00111";
do { print "$_\n"; }
while ( s/(1*?)(0*?)01/$2${1}10/ );
00111
01011
10011
01101
10101
11001
01110
10110
11010
11100
Oha
edit: feel free to change $2${1}10 with $2$1\Q10 :)  [reply] [d/l] 

You couldn't have been more understanding :)
that the shortest and the code the strikes right in the dot.
though i feel extremly sad to agree with ohcamacj and admit my failure that i won't live long enough to see it finish with that much ones and zeroes.
originally i was trying to make an de/coder that reads some bytes from a file, for every 26 bytes (at least) counts how many zeroes and one are there and the MD5 of the original binary string( of 26*8 bits) and writes it to a new file in the format of (for every previouse 26 bytes) "$ones,$zeroes,MD5x16\n"
then when it should decode the new file, it reads every string, checks for all the possibilities of strings containing these numbers of 1's and 0's checking their MD5 comparing it to the read one, if it fits it writes the original file by printing the ord('B8', $every_8_ones_or_zeroes_after_split) .
but now i understand i'll wait forever to decode few bytes.
P.S.: the beauty of such a compression, is first that it's a some sort of logic interpretation of almost random strings( of 1/0), and secondly, i can compress the compressed file until i reach it's minimal length (<= 26).
 [reply] 

first, my regex is not perfect, there are ways to make it faster (making it greedy and starting only from start is a good start). but anyway it's slow.
regarding what you are going to do: first you want to use a 16bit MD5 and the count of ones and zeros. the worst case is having all 26 ones or zeroes, so you need 5 bits for that information: that mean for 26 bit of data, you'll get 5+16 bit result. that's about 20% compression.
unfortunately, you can't guarantee that for a given MD5 and number of ones, you'll have only 1 possibile 26bit data. you could analize it and findout how many case you can have at worst and i fear it's more then 32 (if it was 32, you had need another 5bit and the total of data would be 26)
Oha
 [reply] 

Using the same algorithm approach, but reversing the output:
$_ = "11100";
do { print "$_\n"; }
while ( s/(.*)10(0*)(1*)/${1}01$3$2/ );
11100
11010
11001
10110
10101
10011
01110
01101
01011
00111
 Miller  [reply] [d/l] 

i had some time, and just for fun i optimized the above RE: this is faster by avoiding alot of backtracking.
$_ = "00001111";
print "$_\n" while (s/(1*)0(0*)1/$2${1}10/);
Oha  [reply] [d/l] 
Re: One Zero variants_without_repetition by johngg (Abbot) on Aug 14, 2007 at 23:02 UTC 
After my first woeful attempt at a solution I continued to work at this problem. Moving away from the substr idea I started to look at incrementing from the lowest possible value, e.g. with three each of zeros and ones, 000111, up to the highest, 111000 picking out those numbers containing exactly three ones. BrowserUk took a similar approach here.This worked for small values of zeros and ones but slowed markedly with larger values where you increment, say, 000111111111111 to 001000000000000 and then you have a long way to go before you get back to twelve ones again. I wondered if there was a way of short circuiting the incrementation by jumping directly to the next value with the desired number of ones. After some investigation I came up with this.
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;
};
}
It seems to work quite quickly and looks to be accurate when tested against nonshort circuit methods. It was developed on 64bit UltraSPARC so the limits are set for that architecture and may need to be reduced for other systems. Since I had never used Math::BigInt before I decided to have a crack at implementing a version that would cope with larger values of zeros and ones. It appears to run with 400 each of zeros and ones but takes some seconds per iteration (450MHz Ultra60). Here it is.
I've had a lot of fun exploring this problem and discovered a lot of new things, not just Perl but maths as well. Cheers, JohnGG  [reply] [d/l] [select] 

Superb++.
I did a differential analysis, subtracting the numerical value of successive binary strings that met the criteria, and started to see a pattern emerge that seemed to be keyed to 2**N where N was the number of 0s or 1s depending upon whether iterating up or down.
But there was always some odd adjustments required at the start and end of each run which I couldn't tie down the pattern to. Then the OP started talking about infinite compression algorithms and I lost interest :)
Examine what is said, not who speaks  Silence betokens consent  Love the truth but pardon error.
"Science is about questioning the status quo. Questioning authority".
In the absence of evidence, opinion is indistinguishable from prejudice.
 [reply] 

sorry for disappointing you. it ain't that infinite, just a compression which "wraps 0's and 1's into smth logical that can be compressed again up to the smallest value.
 [reply] 


