Beefy Boxes and Bandwidth Generously Provided by pair Networks
There's more than one way to do things
 
PerlMonks  

Re: More while issues

by Dandello (Scribe)
on Mar 04, 2011 at 01:19 UTC ( #891342=note: print w/ replies, xml ) Need Help??


in reply to More while issues

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


Comment on Re: More while issues
Download Code
Re^2: More while issues
by GrandFather (Cardinal) on Mar 04, 2011 at 03:18 UTC

    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.

        Hi, Using RegExp I'd use the following (here @stash represents the layers):

        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";
Re^2: More while issues
by poj (Priest) on Mar 04, 2011 at 08:14 UTC

    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

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: note [id://891342]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others exploiting the Monastery: (17)
As of 2014-10-23 15:26 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    For retirement, I am banking on:










    Results (125 votes), past polls