use Perl

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;

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;
}