Beefy Boxes and Bandwidth Generously Provided by pair Networks
Think about Loose Coupling
 
PerlMonks  

One Zero variants_without_repetition

by thenetfreaker (Friar)
on Aug 07, 2007 at 10:36 UTC ( #631006=perlquestion: print w/ replies, xml ) Need Help??
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 Google-Code-search 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 ?

Comment on One Zero variants_without_repetition
Select or Download Code
Re: One Zero variants_without_repetition
by BrowserUk (Pope) on Aug 07, 2007 at 10:56 UTC
      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.

        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.
Re: One Zero variants_without_repetition
by GrandFather (Cardinal) 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
      i changed a bit you code to :
      my $places = 6; for my $left (1..$places-1) { 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 ???

        Recursion:

        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
Re: One Zero variants_without_repetition
by grinder (Bishop) on Aug 07, 2007 at 12:21 UTC

    oooh, fun!

    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[$cand-1] == 0 and $array[$cand] == 1) { ($array[$cand-1], $array[$cand]) = ($array[$cand], $array[ +$cand-1]); 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[$cand-1] == 0 and $array[$cand] == 1) { ($array[$cand-1], $array[$cand]) = ($array[$cand], $ar +ray[$cand-1]); 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 one-element 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

      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+$zeroes-1 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]
        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 sub-arrays.

        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 newly-constructed 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

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

      ... which is available as Algorithm::Loops::NextPermute().

      And Algorithm::Loops offers another way to do this as well.

      use strict; use Algorithm::Loops qw( NestedLoops ); my $bits= 8; my $ones= 5; my $iter= NestedLoops( [ [ 0 .. $bits-1 ], ( sub { [ 1+$_[-1] .. $bits-1 ] } ) x ($ones-1), ], ); 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 .. $bits-1 ) { for my $o1 ( 1+$o0 .. $bits-1 ) { for my $o2 ( 1+$o1 .. $bits-1 ) { for my $o3 ( 1+$o2 .. $bits-1 ) { for my $o4 ( 1+$o3 .. $bits-1 ) { 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 hard-coded.

      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 .. $ones-1, ), ], ); my @ones; while( @ones= $iter->() ) { my @bits= (0) x $bits; @bits[@ones]= (1) x $ones; print join '', @bits, $/; }

      - tye        

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+$twos-1); print @str,"\n"; }
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

      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.)
      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.
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 :-)

      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).
        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

      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
      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
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 non-short circuit methods. It was developed on 64-bit 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 Ultra-60). 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

      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.
        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.

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: perlquestion [id://631006]
Approved by Corion
Front-paged by Corion
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others examining the Monastery: (18)
As of 2014-07-22 16:51 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    My favorite superfluous repetitious redundant duplicative phrase is:









    Results (120 votes), past polls