Category: |
Seasonal Oddities |
Author/Contact Info |
Marburg (john.keating@may.ie) |
Description: |
Here is a little script that takes as input (STDIN) a ::
field-delimited file of Names and associated Emails and emails everyone the name of the person they have to buy a present for. It is written in block format, just to make the perl students in my computer science department work a bit harder at figuring out how it works. There are no oddities, just plain Perl, and it should illustrate the way Perl can be used to solve problems.
The basic idea is that the script shouls choose someone from the list for each person in the list but not themselves of course (who wants to buy a pressie for themselves?). Each person should be emailed their chosen present recipient and no details of the selection should
be maintained ... the program includes a copy of itself for educational purposes!
Anyway, could I have comments on improving the algorithm? Could I use a single Hash (appart from using a Hash of Lists)? Would it be better to shuffle a list and then select items one by one? Is there a better way than using grep to return the list of recipients?
I have lots ot time to improve it before next Christmas.
Enjoy it, please! Marburg.
|
chomp,@_=split(/::/),($e{$_[0]},$l{$_[0]})=($_[1],0)while(<>);;
$m=qq#/usr/lib/sendmail#;$s=q#kris.kringle@north.pole#;;foreach
(keys%l){$l{$_}++;@L=grep{($l{$_}==0)}keys%l;;$x=int rand(@L);;
$l{$L[$x]}++;$l{$_}--;open(M,"|".$m." ".$e{$_});print M "From:"
," $s\n";print M "To: ", $e{$_},"\n";$t=qq/Your Kris Kringle /.
q/Recipient/;print M "Subject: $t!\n";print M "\n$t is: $L[$x].
\n\nK.K.";print M "\n\nPlease do NOT reply! 'I' am a program:",
"\n\n";open(T,$0);printf M while(<T>);close(T);close(M);}##JnK!
|
RE: Kris Kringle Script
by turnstep (Parson) on Apr 28, 2000 at 18:59 UTC
|
Yow! That code is almost obfuscated! At the very least, if
you are teaching people perl, please always check the
return value of 'open'! Here is my rewrite, trying to
maintain some of the spirit of the original:
#!perl
use strict;
my(@santa);
my($total,$x,$y,$found,$old);
my(%gift);
my($name, $name2, $email, $email2);
while(<>) {
chomp;
m/::/ && push(@santa, $_);
}
my $mail = "/usr/lib/sendmail -t -oi -odq";
my $mailfrom = "kris.kringle\@north.pole";
my $subject = "Your Kris Kringle Recipient";
## Give everyone a present from a random person:
$total=0; srand;
for $y (@santa) {
$found=0;
$total++;
while (!$found) {
$x = $santa[rand @santa];
$y eq $x && next; ## No presents to self!
## What if the only person left is yourself? This solves that:
if ($total == @santa && !$gift{$y}) {
## Switch with another!
$old = $gift{$x};
$gift{$x}=$y;
$gift{$y}=$old;
last;
}
$gift{$x} && next; ## No more than one present per person
$gift{$x}=$y; $found++;
}
}
## Now we send out the email:
for $y (@santa) {
($name, $email) = split(/::/, $y);
($name2, $email2) = split(/::/, $gift{$y});
open(MAIL, "|$mail $email") || die "Could not open $mail: $!\n";
print MAIL <<"NORTHPOLE";
From: $mailfrom
To: "$name" <$email>
Subject: $subject
$subject is: $name2 ($email2)
K.K.
Please do NOT reply! 'I' am a program:
NORTHPOLE
open(SELF, $0) || die "Could not open $0: $!\n";
while(<SELF>) { print MAIL; }
close(SELF) || die "Could not close $0: $!\n";
close(MAIL) || die "Could not close $0: $!\n";
}
exit;
The little section that begins "if ($total == @santa...)"
is there to prevent the following condition. Say we have
three people, A, B. and C. A randomly gets assigned to
B, then B gets assigned to A. At this point, the only
person C can give a present to who has not gotten
one is herself, which is not allowed! Hence, the
little snippet above, which neatly solves that. Enjoy!
| [reply] [Watch: Dir/Any] [d/l] |
|
Thanks for the comments and the effort placed in producing a new solution for the Kris Kringle script. I should have checked the return of the open statement of course - I almost always do after months of seeing that very comment in comp.lang.per.misc.
Anyway, just a note to say that my solution, or code rather, doesn't have the problem you mention at the end, but it was good to point it out. I've never had the problem after substantial testing.
This script is interesting, I think, as it is typical of scripts that must work first time, and you cannot really test it over and over with real data as you don't want to bug people with junk email. I normally approach this type of problem with writing to files and the writing another Perl program to test.
All programming style asside ...
The main difference between our solutions it that your approach just loops again if you randomly choose yourself and my approach is to remove yourself from the list before you choose. In theory (extrapolating here) you could get caught in a infinite loop if the random assignment returned yourself every time. I was just removing that possibility of ever occurring. My approach also removes the people already selected from the list so that they are not selected again.
I think that I will make a few runs of the programs available with different data sets to show people interested in the workings how it performs over data etc. What do people think?
Regards, Marburg (john.keating@may.ie)
| [reply] [Watch: Dir/Any] |
|
>In theory (extrapolating here) you could get caught in a
>infinite loop if the random assignment returned yourself every time
Well, *in theory* yes, but considering that perl can generate
well over 100,000 random numbers per second on even a slow
machine, the odds of an infinite loop are, well, infinitely
small. The odds of it taking over 1 second are pretty
slim, too. Nothing to worry about here.
>This script is interesting, I think, as it is typical of
>scripts that must work first time, and you cannot really
>test it over and over with real data as you don't want to
>bug people with junk email. I normally approach this type
>of problem with writing to files and the writing another
>Perl program to test.
Actually, I tested mine extensively - that's how I found
the last person "gotcha". A simple rewrite of one line to
open (M, "|more") || die "Could not open more!\n";
takes care of that.
>Anyway, just a note to say that my solution, or code
>rather, doesn't have the problem you mention at the end,
>but it was good to point it out. I've never had the
>problem after substantial testing.
Your code *does* have that problem - if everyone else
is used up, it assigns a null Kris Kringle. Try this out:
chomp,@_=split(/::/),($e{$_[0]},$l{$_[0]})=($_[1],0)while(<>);
for (keys %l) {
$l{$_}++;
@L=grep{($l{$_}==0)}keys%l;
$x=int rand(@L);
$l{$L[$x]}++;
$l{$_}--;
print "$e{$_} has a KK of $L[$x]\n";
}
Now run that with a data set like this:
A::aaron
B::bob
C::cindy
When aaron and bob get each other, cindy gets nothing:
%type test.txt | perl kk2.pl
aaron has a KK of B
bob has a KK of A
cindy has a KK of
The chance of it happening decreases with the total number
of people, but it can still happen....
| [reply] [Watch: Dir/Any] [d/l] [select] |
|
|
|