DigitalKitty has asked for the wisdom of the Perl Monks concerning the following question:

Hi all.

As a biological science major ( among others ), writing punnett squares is an all too common activity. Admittedly, I write them less frequently than I used to but I'm sure you understand. For those who might not know, a 'Punnett Square' is simply a tool to help you understand how alleles are passed to the next generation. It enables you to follow each parental allele as it could get passed to the next generation.

In order to 'perl-ize' ( trademark pending ), I wrote the following simple program that will quickly calculate the resulting genetic model: 


#!/usr/bin/perl -w
use strict;

my $numTop;
my $numSide;
my @top;
my @side;

print "Number of pairs for top of punnett square:";
chomp( $numTop = <STDIN> );

for( my $x = 0; $x < $numTop; $x++ )
{
  print "Enter pairs ( xx ): ";
  chomp( $_ = <STDIN> );
  push @top, $_;
}

print "Number of pairs for side of punnett square:";
chomp( $numSide = <STDIN> );

for( my $y = 0; $y < $numSide; $y++ )
{
  print "Enter pairs ( xx ): ";
  chomp( $_ = <STDIN> );
  push @side, $_;
}

for( my $i = 0; $i < @top; $i++ )
{
  for( my $j = 0; $j < @side; $j++ )
  {
     print "$top[$i]" . "$side[$j]\n";
  }
}

[download]

If you can help improve the design, I would be appreciative.

Thanks,

-Katie.

Replies are listed 'Best First'.
Re: Punnett squares and perl.
by graff (Chancellor) on May 15, 2003 at 02:24 UTC
    Well, the first thing I'd want to do is allow all the input to come from a named file -- or if I choose to type, make it easier/quicker to enter values. Nothing strikes me as more tedious or error-prone than typing a bunch of values, one per line, in response to prompt strings while a program is running. So: 
    #!/usr/bin/perl -w
use strict;

my $Usage = <<ENDUSE;
Usage: $0 [punnett_square_specs.file]

 input data should contain two rows of values:
  first row lists pairs for the top of the punnett square
  second row lists pairs for the side of the punnett square

ENDUSE

die $Usage if(@ARGV and ! -r $ARGV[0]);

my @top = split /\s+/, <>;
my @side = split /\s+/, <>;

for my $t ( @top ) {
   for my $s ( @side ) {
      print "$t$s\n";
   }
}

    [download]
    I'm just taking it for granted that this really is the output format that you want (two values per line, number of lines = scalar @top * scalar @side). Prompting for $numtop and $numSide seems unnecessary -- just count up how many space-separated tokens are provided for each set.

    As I've written it here, you can still type in the values after you start the program (or paste in lines of values from some other window); but you can also save your values in a file, and have it read that file, or you may have some other process that outputs the two lines of values, and pipe it to the script.

    update: If, as suggested by BrowserUK's reply, you really want to print out something that looks like a square (i.e. a table) rather than just a list of lines (the way the OP code was written), then I'd change my loop to look like this (taking the terms "top" and "side" literally here): 

    print join( "    ", "  ", @top, $/);
for my $s ( @side ) {
    print "$s ";
    for my $t ( @top ) {
        print "  $t$s";
    }
    print $/;
}

    [download]
    Given two lines of input like: 
    gg hh kk jj
11 22 33 44

    [download]
    That loop will produce: 
          gg    hh    kk    jj    
11   gg11  hh11  kk11  jj11
22   gg22  hh22  kk22  jj22
33   gg33  hh33  kk33  jj33
44   gg44  hh44  kk44  jj44

    [download]
[reply]
[d/l]
[select]
      Now you just need to handle the relative frequencies of each allele and genotype ;-)

      --
      In Bob We Trust, All Others Bring Data.

[reply]
Re: Punnett squares and perl.
by runrig (Abbot) on May 15, 2003 at 02:09 UTC
    I might do something along these lines for the first and second loops:
    print "Number of pairs for top of punnett square:";
chomp( $numTop = <STDIN> );
my @top = (0) x $numTop;

for ( @top )
{
  print "Enter pairs ( xx ): ";
  chomp( $_ = <STDIN> );
}

    [download]
    And definitely don't use the C style for loop for that last loop. Use for my $t (@top) {, etc. Then you don't have to worry about off by one errors, or having to index your array to get to the elements.
[reply]
[d/l]
[select]
Re: Punnett squares and perl.
by BrowserUk (Patriarch) on May 15, 2003 at 02:37 UTC 

    #! perl -slw
use strict;
use vars qw[$T $S];

sub promptfor{
    my ($rv, $prompt, $match) = ('',@_);
    do{
        printf $prompt;
    } until ($rv = <STDIN>) =~ m[^$match$];
    chomp($rv);
    return $rv;
}

my (@tops, @sides);
if( $S ) {
    @sides = split ' ', $S;
}
else {
    my $count = promptfor 'How many side pairs? ', '\d';
    push @sides, promptfor 'Enter side pair ( xx ): ', '\w{2}' while $
+count--;
}

if( $T ) {
    @tops = split ' ', $T;
}
else {
    my $count = promptfor 'How many top pairs? ', '\d';
    push @tops, promptfor 'Enter top pair ( xx ): ', '\w{2}' while $co
+unt--;
}

printf '    ' . '  %2s  ' x @tops . $/, @tops;

for my $side ( @sides ) {
    printf ' %2s ' . ' %2s%2s ' x @tops . $/, $side, map{ $side, $_ } 
+@tops;
}

__END__
D:\Perl\test>258302
How many side pairs? 4
Enter side pair ( xx ): AC
Enter side pair ( xx ): Ac
Enter side pair ( xx ): aC
Enter side pair ( xx ): ac
How many top pairs? 4
Enter top pair ( xx ): CA
Enter top pair ( xx ): Ca
Enter top pair ( xx ): cA
Enter top pair ( xx ): ca
      CA    Ca    cA    ca
 AC  ACCA  ACCa  ACcA  ACca
 Ac  AcCA  AcCa  AccA  Acca
 aC  aCCA  aCCa  aCcA  aCca
 ac  acCA  acCa  accA  acca

D:\Perl\test>258302 -T="AC Ac aC ac" -S="AC Ac aC ac"
      AC    Ac    aC    ac
 AC  ACAC  ACAc  ACaC  ACac
 Ac  AcAC  AcAc  AcaC  Acac
 aC  aCAC  aCAc  aCaC  aCac
 ac  acAC  acAc  acaC  acac

    [download]
    Examine what is said, not who speaks.
    "Efficiency is intelligent laziness." -David Dunham
    "When I'm working on a problem, I never think about beauty. I think only how to solve the problem. But when I have finished, if the solution is not beautiful, I know it is wrong." -Richard Buckminster Fuller
[reply]
[d/l]
Re: Punnett squares and perl.
by wufnik (Friar) on May 15, 2003 at 08:10 UTC
    hola world.

    a wave of nostalgia overcame me when i read the posting re: punnet squares, & i offer the following wee map-fest in penance for the sundry wrongs & misdemeanors in the classroom of biology teacher mr robinson...

    it does the trick in a fairly simple way, made more complicated by the presence of pesky column and row titles.

    if i wanted to do something with the combinations generated, like count frequencies, i'd get rid of the unshift's, which are only there to deal with the row and column titles.

    the venerable getopt::long module is used for arg capture. 

    # i am not strict

use Getopt::Long;
GetOptions("f=s@" => \@dadAlls, 
       "m=s@" => \@mumAlls, 
       "help" => sub { 
print "psquare: --f (male allele) --m (female allele)\n"; exit; });

unshift @mumAlls, ""; # for titles. 
@psquare = map { my $current = $_; [ map { sprintf("%-10s",$current . 
+$_) } @mumAlls ] } @dadAlls; 
unshift @psquare, [map { sprintf("%-10s", $_) } @mumAlls];
map { print join "", @$_; print "\n"; } @psquare;

    [download]


    hope that helps.
[reply]
[d/l]

Back to Seekers of Perl Wisdom