Stories
Slash Boxes
Comments
NOTE: use Perl; is on undef hiatus. You can read content, but you can't post it. More info will be forthcoming forthcomingly.

All the Perl that's Practical to Extract and Report

use Perl Log In

Log In

[ Create a new account ]

Friday March 10, 2006
12:14 PM

Deal or No Deal

Here's a small CGI program to calculate the expected value of the remaining cases on the TV show Deal or No Deal (Oh, and the all important screen shot).

#!/usr/bin/perl
use CGI;

$q = new CGI;
print $q->header;
print $q->start_html(-title=>'Deal or No Deal',-BGCOLOR=>'white'),
      $q->h1('--Deal or No Deal--'),
      $q->startform();

@left =   qw/ 0.01       1       5      10      20     50
                75     100     200     300     400     500     750  /;

@right=   qw/1,000   5,000  10,000  25,000  50,000  75,000
           100,000 200,000 300,000 400,000 500,000 750,000 1,000,000/;

my $i = 0;
print "<table>\n";
for (@left)
{
    print $q->Tr($q->th([
                         $q->checkbox(-name=>"cl$i",
                                        -checked=>'checked',
                                      -value=>'YES',
                                      -label=>'').
                        $q->textfield(-name=>"l$i",
                                      -default=>$left[$i],
                                      -size=>9,
                                      -override=>0),

                        $q->textfield(-name=>"r$i",
                                      -default=>$right[$i],
                                      -size=>9,
                                      -override=>0).
                         $q->checkbox(-name=>"cr$i",
                                        -checked=>'checked',
                                      -value=>'YES',
                                      -label=>'')
                                      ])), "\n";
    $i++;
}
print "</table>";
print $q->submit(-name=>'Calculate'),
      $q->endform()
      ;

if (@all = $q->param())
{
    my $acc = 0;
    my $count = 0;
    for (@all)
    {
        if(/c((?:l|r)\d+)/)
        {
            my $val = $q->param($1);
            $val =~ s/[^.0-9]//g;
            $count++;
            $sum += $val;
        }
    }
    print "<p>Expected Value: ".'$';
    printf "%.2f<hr>", $sum/$count;
}
print $q->end_html;

Friday September 16, 2005
06:26 PM

unfold

I came across Limbic~Region's article on iterators and thought I write up some quick perl examples using the more generic unfold (code reuse in action). Fold is the list deconstructor, while unfold is its dual, the list generator.

#!/usr/bin/perl -w

use strict;

#Demonstrations of iterators using 'unfold'

#the natural numbers 1,2,3...
my $nats = unfold(\&false,      #loop forever
                  \&id,         #identity function
                  sub{$_[0]+1}, #increment value
                  1 );          #initial seed

# 0,2,4,6,8
my $evens_5 = unfold( sub{$_[0]>8}, \&id, sub{$_[0]+2}, 0);

#Factorials
my $facs = unfold(\&false,
                  \&fst,
                  sub{[fst($_[0])*snd($_[0]),snd($_[0])+1]},
                  [1,1]);

#Fibonacci's famous sequence
my $fibs = unfold(\&false, \&fst, sub{[snd($_[0]),fst($_[0])+snd($_[0])]},[0,1]);

#Enumeration of DNA sequences from...
#  http://www.perl.com/pub/a/2005/06/16/iterators.html
#
my $dna = unfold(sub{toDNA($_[0]) eq "CTTTT"},
                 sub{my $x = toDNA($_[0]); $x=~s/^.(.*)$/$1/; $x},
                 sub{$_[0]+1},
                 fromDNA("CAAAA"));

#print out some samples...
my (@n, @e, @a, @f);
push @n, $nats->() for (1..10);
push @e, $evens_5->() for (1..5);
push @a, $facs->() for (1..10);
push @f, $fibs->() for (1..10);
print "@n\n@e\n@a\n@f\n";

print $dna->() ."\n" for (1..10);

# --Haskell version of unfold...
#
# unfold p f g x =
#   if p x
#      then []
#      else f x : unfold p f g (g x)

sub unfold
{   # function $p is a predicate to indicate when to stop iterator
    # function $f takes the seed ($x) and formats it before returning it
    # function $g massages $x for the next iteration
    # $x is the initial value

    my ($p, $f, $g, $x) = @_;
    sub{ ($p->($x)) ? undef : do{my $val = $f->($x); $x=$g->($x); $val}}
}

#Helper functions
sub fst   { $_[0]->[0] }
sub snd   { $_[0]->[1] }
sub false { 0 }
sub id    { $_[0] }

# These subs convert back and forth between strings of "ACGT" and
# integers, using base-4 arithmetic.  Something with pack/unpack
# might be cleaner.

sub fromDNA
{
    my $s = shift;
    $s =~ tr/ACGT/0-3/;

    my $n=0;
    $n = $n*4+$_ for (split(//, $s));

    return $n;
}

sub toDNA
{
    my $n = shift;
    my $acc = "";

    while($n)
    {
        my $d = $n % 4;
        $n = int($n/4);
        $acc = "$d" . $acc;
    }

    ($acc="$acc") =~ tr/0-3/ACGT/;

    return $acc;
}