#!/usr/statlocal/bin/perl -wT

use CGI;
use CGI::Carp 'fatalsToBrowser';

use strict;
use warnings;
use POSIX;

use constant TOOBIG => 1.0e6;

sub htmldie(@)
{
    my $query = shift;
    print "<p><h1>CGI Error</h1><p>" . join(' ', @_ ) . "<p>\n";
    exit;
}

sub print_head($;$)
{
    my $query = shift;
    my $title = (@_ > 0) ? shift : "";

    $query->print( $query->header, "\n" );
    $query->print( $query->start_html( $title ) );
    $query->print( $query->h1( $title ), "\n" );

    $query->print( $query->p( <<END_OF_INTRO ) );
Welcome to Floosh Island, peaceful
paradise for the little-known floosh birds that inhabit
it. Sadly for the floosh birds, tragedy is about to strike.

END_OF_INTRO
}

sub rnd_pc($)
{
    my $x = shift;

    return( sprintf( "%5.2f%%", 100*$x) );
}

sub print_form($)
{
    my $query = shift;

    $query->print( $query->startform, "\n" );

    $query->print( $query->p( "How many floosh birds of each genotype?\n", $query->br,
                   "AA ", $query->textfield( -name=>'nAA', -default=>"100",
                             -size=>12, -maxlength=>128 ), "\n", $query->br,
                   "Aa&nbsp;", $query->textfield( -name=>'nAa', -default=>"200",
                             -size=>12, -maxlength=>128 ), "\n", $query->br,
                   "aa&nbsp;&nbsp;", $query->textfield( -name=>'naa', -default=>"100",
                             -size=>12, -maxlength=>128 ), "\n", $query->br ) );

    $query->print( $query->p( "What proportion of floosh birds will be wiped out on the sad day? &nbsp;&nbsp; ",
                   $query->textfield( -name=>'p', -default=>"0.10",
                             -size=>12, -maxlength=>128 ), "\n", $query->br ) );


    $query->print( $query->p( "Which floosh birds will wiped out on the sad day?\n", $query->br,
             $query->radio_group( -name=>'which',
                               -Values=>[q/It is purely random/, 'Only the aa genotype', 'Only the Aa genotype', 'Only the AA and Aa genotypes', 'Likelihood based on number of a alleles'],
                               -default=>q/It is purely random/,
                               -linebreak=>'true' ), $query->br, "\n" ) );

    $query->print( $query->hidden( 'mode', 'yes' ), "\n" );

    $query->print( $query->submit( 'The Sad Day Comes' ), $query->defaults( 'Clear Fields' ), $query->p, "\n" );
 
    $query->print( $query->endform, "\n", $query->hr, $query->p, "\n" );
}

sub probabilities_which($$)
{
    my $which = shift;
    my $p = shift;

    my ($pAA, $pAa, $paa) = ($p, $p, $p);

    if( $which eq 'Only the aa genotype' )
    {
        ($pAA, $pAa, $paa) = (0, 0, $p);
    }
    elsif( $which eq 'Only the Aa genotype' )
    {
        ($pAA, $pAa, $paa) = (0, $p, 0);
    }
    elsif( $which eq 'Only the AA and Aa genotypes' )
    {
        ($pAA, $pAa, $paa) = ($p, $p, 0);
    }
    elsif( $which eq 'Likelihood based on number of a alleles' )
    {
        ($pAA, $pAa, $paa) = (0, $p/2, $p);
    }

    return( ($pAA, $pAa, $paa) );
}

sub sample($$)
{
    my $n = shift;
    my $p = shift;

    my $X = 0;

    for( my $i = 0; $i < $n; ++$i )
    {
        my $u = rand;

        $X += ($u <= $p) ? 1 : 0;
    }

    return($X);
}

sub print_results($)
{
    my $query = shift;

    $query->print( $query->p("What happened to the floosh bird population on that tragic day?\n"), $query->br );

    # untaint variables

    my ($nAA, $nAa, $naa, $p, $which);

    my $foo;

    $foo = $query->param('nAA');
    $foo =~ m/(\d+)/;
    $nAA = $1;
    htmldie( $query, "Too many floosh birds!" ) if( $nAA > TOOBIG );

    $foo = $query->param('nAa');
    $foo =~ m/(\d+)/;
    $nAa = $1;
    htmldie( $query, "Too many floosh birds!" ) if( $nAa > TOOBIG );

    $foo = $query->param('naa');
    $foo =~ m/(\d+)/;
    $naa = $1;
    htmldie( $query, "Too many floosh birds!" ) if( $naa > TOOBIG );

    $foo = $query->param('p');
    $foo =~ m/(0?\.\d+)/;
    $p   = $1;

    $foo = $query->param('which');
    $foo =~ m/([\w\s]+)/;
    $which   = $1;

    # Create sample

    my ($pAA, $pAa, $paa) = probabilities_which( $which, $p );
    my ($rAA, $rAa, $raa);

    $rAA = sample( $nAA, $pAA );
    $rAa = sample( $nAa, $pAa );
    $raa = sample( $naa, $paa );

    # Display results

    my $nT = $nAA + $nAa + $naa;
    my $rT = $rAA + $rAa + $raa;
    my $mT = $nT - $rT;

    $query->print( $query->table(
                        $query->Tr( {-align=>"CENTER"}, $query->th(''), $query->th( {-align=>"center", -colspan=>2}, 'Initial' ), $query->th( {-align=>"center", -colspan=>2}, 'Affected' ),
                                    $query->th( {-align=>"center", -colspan=>2}, 'Survivors' ) ), 
                        $query->Tr( {-align=>"CENTER"}, $query->th( ['', 'Number', 'Frequency', 'Number', 'Frequency', 'Number', 'Frequency'] ) ),
                        $query->Tr( {-align=>"CENTER"}, $query->td( ['AA', $nAA, rnd_pc($nAA/$nT), $rAA, rnd_pc($rAA/$rT), $nAA-$rAA, rnd_pc(($nAA-$rAA)/$mT) ] ) ),
                        $query->Tr( {-align=>"CENTER"}, $query->td( ['Aa', $nAa, rnd_pc($nAa/$nT), $rAa, rnd_pc($rAa/$rT), $nAa-$rAa, rnd_pc(($nAa-$rAa)/$mT) ] ) ),
                        $query->Tr( {-align=>"CENTER"}, $query->td( ['aa', $naa, rnd_pc($naa/$nT), $raa, rnd_pc($raa/$rT), $naa-$raa, rnd_pc(($naa-$raa)/$mT) ] ) ) ), "\n" );


    $query->delete( 'mode' );
    $query->print( $query->br, $query->hr, $query->a( {href=>$query->self_url}, "Try Again" ), "\n" );

}

sub print_foot($)
{
    my $query = shift;

    print $query->hr,"\n";
    print $query->a({href=>"http://www.stat.cmu.edu/~genovese/tol/"},"Back To Course Blog"), "\n";
    print $query->end_html,"\n";
}


my $q = new CGI;
my $title = q/Floosh Island/;

print_head( $q, $title );

if( not defined( $q->param( 'mode' ) ) )
{
    print_form( $q );
}
else
{
    print_results( $q );
}

print_foot($q);



# Local Variables:
# mode: perl
# End: