Greg Buchholz's Journal Greg Buchholz's use Perl Journal en-us use Perl; is Copyright 1998-2006, Chris Nandor. Stories, comments, journals, and other submissions posted on use Perl; are Copyright their respective owners. 2012-01-25T02:42:37+00:00 pudge Technology hourly 1 1970-01-01T00:00+00:00 Greg Buchholz's Journal Deal or No Deal Here's a small CGI program to calculate the expected value of the remaining cases on the TV show <a href="">Deal or No Deal</a> (Oh, and the all important <a href="">screen shot</a>).<blockquote><div><p> <tt>#!/usr/bin/perl<br>use CGI;<br> <br>$q = new CGI;<br>print $q-&gt;header;<br>print $q-&gt;start_html(-title=&gt;'Deal or No Deal',-BGCOLOR=&gt;'white'),<br>&nbsp; &nbsp; &nbsp; $q-&gt;h1('--Deal or No Deal--'),<br>&nbsp; &nbsp; &nbsp; $q-&gt;startform();<br> <br>@left =&nbsp; &nbsp;qw/ 0.01&nbsp; &nbsp; &nbsp; &nbsp;1&nbsp; &nbsp; &nbsp; &nbsp;5&nbsp; &nbsp; &nbsp; 10&nbsp; &nbsp; &nbsp; 20&nbsp; &nbsp; &nbsp;50<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; 75&nbsp; &nbsp; &nbsp;100&nbsp; &nbsp; &nbsp;200&nbsp; &nbsp; &nbsp;300&nbsp; &nbsp; &nbsp;400&nbsp; &nbsp; &nbsp;500&nbsp; &nbsp; &nbsp;750&nbsp;<nobr> <wbr></nobr>/;<br> <br>@right=&nbsp; &nbsp;qw/1,000&nbsp; &nbsp;5,000&nbsp; 10,000&nbsp; 25,000&nbsp; 50,000&nbsp; 75,000<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;100,000 200,000 300,000 400,000 500,000 750,000 1,000,000/;<br> <br>my $i = 0;<br>print "&lt;table&gt;\n";<br>for (@left)<br>{<br>&nbsp; &nbsp; print $q-&gt;Tr($q-&gt;th([<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;$q-&gt;checkbox(-name=&gt;"cl$i",<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; -checked=&gt;'checked',<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; -value=&gt;'YES',<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; -label=&gt;'').<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; $q-&gt;textfield(-name=&gt;"l$i",<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; -default=&gt;$left[$i],<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; -size=&gt;9,<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; -override=&gt;0),<br> <br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; $q-&gt;textfield(-name=&gt;"r$i",<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; -default=&gt;$right[$i],<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; -size=&gt;9,<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; -override=&gt;0).<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;$q-&gt;checkbox(-name=&gt;"cr$i",<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; -checked=&gt;'checked',<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; -value=&gt;'YES',<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; -label=&gt;'')<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; ])), "\n";<br>&nbsp; &nbsp; $i++;<br>}<br>print "&lt;/table&gt;";<br>print $q-&gt;submit(-name=&gt;'Calculate'),<br>&nbsp; &nbsp; &nbsp; $q-&gt;endform()<br>&nbsp; &nbsp; &nbsp;<nobr> <wbr></nobr>;<br> <br>if (@all = $q-&gt;param())<br>{<br>&nbsp; &nbsp; my $acc = 0;<br>&nbsp; &nbsp; my $count = 0;<br>&nbsp; &nbsp; for (@all)<br>&nbsp; &nbsp; {<br>&nbsp; &nbsp; &nbsp; &nbsp; if(/c((?:l|r)\d+)/)<br>&nbsp; &nbsp; &nbsp; &nbsp; {<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; my $val = $q-&gt;param($1);<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; $val =~ s/[^.0-9]//g;<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; $count++;<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; $sum += $val;<br>&nbsp; &nbsp; &nbsp; &nbsp; }<br>&nbsp; &nbsp; }<br>&nbsp; &nbsp; print "&lt;p&gt;Expected Value: ".'$';<br>&nbsp; &nbsp; printf "%.2f&lt;hr&gt;", $sum/$count;<br>}<br>print $q-&gt;end_html;</tt></p></div> </blockquote> Greg Buchholz 2006-03-10T17:14:08+00:00 journal unfold I came across <a href="">Limbic~Region</a>'s <a href="">article</a> on iterators and thought I write up some quick perl examples using the more generic <a href="">unfold</a> (code reuse in action). Fold is the list deconstructor, while unfold is its dual, the list generator.<blockquote><div><p> <tt>#!/usr/bin/perl -w<br> <br>use strict;<br> <br>#Demonstrations of iterators using 'unfold'<br> <br>#the natural numbers 1,2,3...<br>my $nats = unfold(\&amp;false,&nbsp; &nbsp; &nbsp; #loop forever<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; \&amp;id,&nbsp; &nbsp; &nbsp; &nbsp; &nbsp;#identity function<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; sub{$_[0]+1}, #increment value<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; 1 );&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; #initial seed<br> <br># 0,2,4,6,8<br>my $evens_5 = unfold( sub{$_[0]&gt;8}, \&amp;id, sub{$_[0]+2}, 0);<br> <br>#Factorials<br>my $facs = unfold(\&amp;false,<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; \&amp;fst,<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; sub{[fst($_[0])*snd($_[0]),snd($_[0])+1]},<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; [1,1]);<br> <br>#Fibonacci's famous sequence<br>my $fibs = unfold(\&amp;false, \&amp;fst, sub{[snd($_[0]),fst($_[0])+snd($_[0])]},[0,1]);<br> <br>#Enumeration of DNA sequences from...<br>#&nbsp;<br>#<br>my $dna = unfold(sub{toDNA($_[0]) eq "CTTTT"},<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;sub{my $x = toDNA($_[0]); $x=~s/^.(.*)$/$1/; $x},<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;sub{$_[0]+1},<br>&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;fromDNA("CAAAA"));<br> <br>#print out some samples...<br>my (@n, @e, @a, @f);<br>push @n, $nats-&gt;() for (1..10);<br>push @e, $evens_5-&gt;() for (1..5);<br>push @a, $facs-&gt;() for (1..10);<br>push @f, $fibs-&gt;() for (1..10);<br>print "@n\n@e\n@a\n@f\n";<br> <br>print $dna-&gt;()<nobr> <wbr></nobr>."\n" for (1..10);<br> <br># --Haskell version of unfold...<br>#<br># unfold p f g x =<br>#&nbsp; &nbsp;if p x<br>#&nbsp; &nbsp; &nbsp; then []<br>#&nbsp; &nbsp; &nbsp; else f x : unfold p f g (g x)<br> <br>sub unfold<br>{&nbsp; &nbsp;# function $p is a predicate to indicate when to stop iterator<br>&nbsp; &nbsp; # function $f takes the seed ($x) and formats it before returning it<br>&nbsp; &nbsp; # function $g massages $x for the next iteration<br>&nbsp; &nbsp; # $x is the initial value<br> <br>&nbsp; &nbsp; my ($p, $f, $g, $x) = @_;<br>&nbsp; &nbsp; sub{ ($p-&gt;($x)) ? undef : do{my $val = $f-&gt;($x); $x=$g-&gt;($x); $val}}<br>}<br> <br>#Helper functions<br>sub fst&nbsp; &nbsp;{ $_[0]-&gt;[0] }<br>sub snd&nbsp; &nbsp;{ $_[0]-&gt;[1] }<br>sub false { 0 }<br>sub id&nbsp; &nbsp; { $_[0] }<br> <br># These subs convert back and forth between strings of "ACGT" and<br># integers, using base-4 arithmetic.&nbsp; Something with pack/unpack<br># might be cleaner.<br> <br>sub fromDNA<br>{<br>&nbsp; &nbsp; my $s = shift;<br>&nbsp; &nbsp; $s =~ tr/ACGT/0-3/;<br> <br>&nbsp; &nbsp; my $n=0;<br>&nbsp; &nbsp; $n = $n*4+$_ for (split(//, $s));<br> <br>&nbsp; &nbsp; return $n;<br>}<br> <br>sub toDNA<br>{<br>&nbsp; &nbsp; my $n = shift;<br>&nbsp; &nbsp; my $acc = "";<br> <br>&nbsp; &nbsp; while($n)<br>&nbsp; &nbsp; {<br>&nbsp; &nbsp; &nbsp; &nbsp; my $d = $n % 4;<br>&nbsp; &nbsp; &nbsp; &nbsp; $n = int($n/4);<br>&nbsp; &nbsp; &nbsp; &nbsp; $acc = "$d" . $acc;<br>&nbsp; &nbsp; }<br> <br>&nbsp; &nbsp; ($acc="$acc") =~ tr/0-3/ACGT/;<br> <br>&nbsp; &nbsp; return $acc;<br>}</tt></p></div> </blockquote> Greg Buchholz 2005-09-16T23:26:27+00:00 journal