Beefy Boxes and Bandwidth Generously Provided by pair Networks vroom
P is for Practical
 
PerlMonks  

Kris Kringle Script

by Marburg (Novice)
on Apr 28, 2000 at 02:44 UTC ( #9498=sourcecode: print w/ replies, xml ) Need Help??

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!

Comment on Kris Kringle Script
Download Code
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!

      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)

        >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....

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://9498]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others wandering the Monastery: (6)
As of 2014-04-17 02:57 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    April first is:







    Results (437 votes), past polls