Beefy Boxes and Bandwidth Generously Provided by pair Networks
Problems? Is your data what you think it is?
 
PerlMonks  

More while issues

by Dandello (Scribe)
on Mar 03, 2011 at 20:59 UTC ( #891303=perlquestion: print w/ replies, xml ) Need Help??
Dandello has asked for the wisdom of the Perl Monks concerning the following question:

My code

my $cndiea = 0; foreach my $del ( 0 .. $chntot ) { if ( substr( $aod[$yb], $del, 1 ) eq 'y' ) { $cndiea++; } } while ( $cndiea < $incrsdel ) { my $xda = int rand( $chntot + 1 ); if ( substr( $aod[$yb], $xda, 1 ) eq 'a' ) { substr $aod[$yb], $xda, 1, 'y'; $cndiea++; last; } }

As this stands, it works - in a string of 'a's and 'y's, it counts the 'y's and if there aren't enough of them, converts 'a's to 'y's.

Unfortunately, I have to add a second 'layer' as instead of a string with just 'a's and 'y's, I now have a string with 'a's, 'y's, and 'c's. What I need to do is is start converting 'c's to 'y's after all the 'a's have been converted.

But everything I've tried either converts 'c's to 'y's along with the 'a's or it doesn't convert the 'c's at all.

my $cndiea = 0; foreach my $del ( 0 .. $chntot ) { if ( substr( $aod[$yb], $del, 1 ) eq 'y' ) { $cndiea++; } } while ( $cndiea < $incrsdel ) { my $xda = int rand( $chntot + 1 ); if ( substr( $aod[$yb], $xda, 1 ) eq 'a' ) { substr $aod[$yb], $xda, 1, 'y'; $cndiea++; last; } } my $cndi = 0; my $cndj = 0; foreach my $dela ( 0 .. $chntot ) { if ( substr( $aod[$yb], $dela, 1 ) eq 'a' ) { $cndi++; } if ( substr( $aod[$yb], $dela, 1 ) eq 'y' ) { $cndj++; } } if ( $cndi == 0 ) { while ( $cndj < $incrsdel ) { my $xdb = int rand( $chntot + 1 ); if ( substr( $aod[$yb], $xdb, 1 ) eq 'c' ) { substr $aod[$yb], $xdb, 1, 'y'; $cndj++; last; } } }

This version doesn't remove any of the 'c's. If I remove the 'last' from the first 'while' loop it removes the 'c's without going through all the 'a's first but it hangs (goes into an unresolvable loop) if all the 'a's are gone before reaching $cndiea == $incrsdel.

I'm sure fresh eyes see what I'm missing here as I know there has to be a simple solution. And yes, which 'a's and 'c's being converted need to be randomly selected

Thanks in advance.

Comment on More while issues
Select or Download Code
Re: More while issues
by Anonymous Monk on Mar 03, 2011 at 21:09 UTC

    $string =~ tr/H// returns the number of times the character 'H' occurs in a string.

    $string =~ tr/G//d; removes all occurances of the character 'G'.

    See tr/SEARCHLIST/REPLACEMENTLIST/cds in perldoc perlop.

Re: More while issues
by FalseVinylShrub (Chaplain) on Mar 03, 2011 at 21:39 UTC

    Hi

    While there are more Perlish ways to do this, such as using tr to count characters, for example, your real problem is with your algorithm.

    You don't want to use last to break out of the loop like that, that will break out of the a-replacement loop after replacing just one 'a'. What you want to do is stop the a-replacement loop when there are no 'a's left:

    # code not tested because I've not got perl available # and I renamed your variables while ( $str =~ tr{a}{} # count the 'a's in $str && $count_y < $min_y # do we still want more 'y's? ) { # replace a random 'a' with a 'y' }

    The code to replace a random 'a' with a 'y' looks like it would work, but it could go on forever randomly choosing elements before it finds an 'a'.

    Better to get a list of all the positions with an 'a' and choose randomly between them - and keep track of those that have been replaced already.

    I don't see why you need to count the 'y's again after the first while loop. Just increment the counter e.g. $count_y++ when you replace an 'a' with a 'y' in the first while loop.

    I don't think you need to count the 'a's again at all: if there still aren't enough 'y's then you must have replaced all 'a's; if there are enough 'y's, you don't care.

    You can use exactly the same code to replace 'c's with 'y's as was used to replace 'a's with 'y's. A subroutine would be great here.

    Hope this helps.

    FalseVinylShrub

    Disclaimer: Please review and test code, and use at your own risk... If I answer a question, I would like to hear if and how you solved your problem.

      To say that you guys are great is understating it SO much.

      Between the pointers given above and whatever other suggestions come in, I'm sure I'll have this licked in no time.

Re: More while issues
by johngg (Abbot) on Mar 04, 2011 at 00:07 UTC

    How about finding the positions of the 'a' and 'c' characters using a regex look-ahead in a global match along with pos and then randomly replacing 'a's at those positions until there are none left before, if necessary, going on to the 'c's.

    use strict; use warnings; use feature qw{ say }; my $str; my $minY; $str = q{accyyaycayaccyyaaycy}; $minY = 15; say $str; my $yCt = $str =~ tr{y}{}; my @aPosns; push @aPosns, pos $str while $str =~ m{(?=a)}g; my @cPosns; push @cPosns, pos $str while $str =~ m{(?=c)}g; while ( ( $yCt < $minY ) && @aPosns ) { my $offset = splice @aPosns, rand @aPosns, 1; substr $str, $offset, 1, q{y}; $yCt ++; } while ( ( $yCt < $minY ) && @cPosns ) { my $offset = splice @cPosns, rand @cPosns, 1; substr $str, $offset, 1, q{y}; $yCt ++; } say $str;

    This produces

    accyyaycayaccyyaaycy yycyyyycyyyccyyyyycy

    Running this again but with $minY reduced to 10 gives this

    accyyaycayaccyyaaycy accyyaycyyaccyyyaycy

    I hope this is helpful.

    Cheers,

    JohnGG

      While this is probably more efficient - for me it only replaces the last 'a', not a random 'a'. Maybe it has something to do with the 'say' function - which I don't have - but I'm not sure how.

        Using print with a newline instead of say, which was introduced in Perl 5.10, should have no effect on the result. Perhaps you could post what you tried as you might have made a slight error when implementing the method.

        Cheers,

        JohnGG

Re: More while issues
by Dandello (Scribe) on Mar 04, 2011 at 01:19 UTC

    Got it

    sub rankdwn { my ( $yb, $chntot, $incrsdel ) = @_; my $cnd_a = $aod[$yb] =~ tr/a/a/; my $cnd_y = $aod[$yb] =~ tr/y/y/; while ( $cnd_y < $incrsdel && $cnd_a > 0 ) { my $xda = int rand( $chntot + 1 ); if ( substr( $aod[$yb], $xda, 1 ) eq 'a' ) { substr $aod[$yb], $xda, 1, 'y'; $cnd_a--; $cnd_y++; } } while ( $cnd_y < $incrsdel && $cnd_a == 0 ) { my $xda = int rand( $chntot + 1 ); if ( substr( $aod[$yb], $xda, 1 ) eq 'c' ) { substr $aod[$yb], $xda, 1, 'y'; $cnd_y++; } } return; }

    Sometimes just having little things pointed out helps. Thanks

      That doesn't look very deterministic to me! The following code may work a little more efficiently with large strings:

      use strict; use warnings; my $incrsdel = 10; my $str = "acbcybaycayacyccy"; my @chrs = split '', $str; my $yTot = $str =~ tr/y//; for my $letter ('a', 'c') { $yTot += subLetter ($letter, $incrsdel - $yTot, \@chrs); last if $yTot >= $incrsdel; } $str = join '', @chrs; print "$str\n"; sub subLetter { my ($letter, $limit, $chrs) = @_; my @letPos = grep {$chrs[$_] eq $letter} 0 .. $#$chrs; my $count = 0; while ($count < $limit && @letPos) { $chrs->[$letPos[my $idx = rand @letPos]] = 'y'; splice @letPos, $idx, 1; ++$count; } return $count; }

      Oh, and it scales to a larger set of replaceable characters easily too.

      True laziness is hard work

        More possible solutions! I need a happy smiley.

      You could check first whether there are likely to be enough a's and if not use tr/a/y/ to change them all and then go straight to the c's.

      my $letter='a'; if (($cnd_a + $cnd_y) <= $incrsdel){ $aob[$yb] =~ tr/a/y/; $cnd_y += $cnd_a; $letter='c'; } while ($cnd_y < $incrsdel){ my $xda = int rand( $chntot + 1 ); if ( substr( $aod[$yb], $xda, 1 ) eq $letter ) { substr $aod[$yb], $xda, 1, 'y'; $cnd_y++; } }
      poj
Re: More while issues
by Anonymous Monk on Mar 04, 2011 at 11:07 UTC

    Posting again (think the last one didn't catch)

    use strict; use warnings; my $needed_ys = 7; my $str = 'Why do you need 7 ys when cll you hve re as and cs'; my $orig = $str; my @stash = qw(a c); my @existing = $str =~ /y/g; my $missing = $needed_ys - @existing; foreach my $letter (@stash) { while ( $missing > 0 ) { last unless $str =~ s/$letter/y/; $missing -= 1; } } print 'Original: ', $orig, "\n"; print 'Result: ', $str, "\n";

    Ynon

      The algorithm needs randomness in it for the strings that have more than enough 'a's or 'c's.

      For example the first row might look like this: aaaaaaaaaaaaaaaaacacaaaaaaaaaaaaaaaaaaaaaaaaaacaaaaaaaaaaaaacaaaaaaaaaaaaacaaaaaaaaaaaacaaaaaaaaaaaaaaaaaaaaaaaaxxxxxxxxxx

      The second row might look like this: aaaaaaaaaaaaaaaaacacaaaaaaaaaaaaaaaaaaaaaaaaaacaaaaaaaaaaaaacaaaaaaaaaaaaacaaaaaaaaaaaacaaaaaaaaaaaaaaaaaaaaaaaabxxxxxxxxxxx

      The 'a's are 'normal', the 'c' represents 'elite' and the 'b's are newcomers. 'x' is a placeholder. The next script assigns number values to each 'a', 'b', and 'c' based on weighted algorithms. 'b's have their own algorithm and so have no randomness assigned to them. The 'a's and 'c's have their initial positions randomly assigned and then carry down row by row unless total number of 'inheritance lines' needs to decrease - at which time it is replaced by a 'y' (representing a lost line of inheritance AKA a dead person) whose position is also randomly determined.

      The randomness is an essential part of the algorithm.

Re: More while issues
by TomDLux (Vicar) on Mar 04, 2011 at 21:52 UTC

    I apologise if you are using carefully chosen Turkish or Nepalese words for your variable names, but to me they are meaningless gibberish. I think you are trying to compress things too much, I suspect $chntot is a count. You aren't charged by the character, you can be a little more verbose.

    They don't need to be very long names, that's for Java. But complete words and well-known contractions are good. The length of a name should be proportional to the scope of it's use. In a small loop you might use i or idx; a long-lived variable might be @playingcard_suits.

    As Occam said: Entia non sunt multiplicanda praeter necessitatem.

      Considering the vast majority of my variables look like $dr5[$rn] and $datay{$data[$drp]}, $chntot (change total) is clear as day.

      We really need smileys here. - I wonder what chntot means in Nepalese.

      This is the latest working version BTW

      sub rankdwn { my ( $yb, $chntot, $incrsdel ) = @_; my $cnd_a = $aod[$yb] =~ tr/a/a/; my $cnd_y = $aod[$yb] =~ tr/y/y/; my $letter = 'a'; if ( ( $cnd_a + $cnd_y ) <= $incrsdel ) { $aod[$yb] =~ s/a/y/gsxm; $cnd_y += $cnd_a; $letter = 'c'; } while ( $cnd_y < $incrsdel ) { my $xda = int rand( $chntot + 1 ); if ( substr( $aod[$yb], $xda, 1 ) eq $letter ) { substr $aod[$yb], $xda, 1, 'y'; $cnd_y++; } } return; }

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others scrutinizing the Monastery: (11)
As of 2014-08-28 14:23 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The best computer themed movie is:











    Results (263 votes), past polls