in reply to Kris Kringle Script

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;

[download]
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!

Replies are listed 'Best First'.
RE: RE: Kris Kringle Script
by Marburg (Novice) on Apr 28, 2000 at 20:26 UTC

    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]

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

      [download]
      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";
}

      [download]

      Now run that with a data set like this: 

      A::aaron
B::bob
C::cindy

      [download]

      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

      [download]

      The chance of it happening decreases with the total number of people, but it can still happen....

[reply]
[d/l]
[select]

        You are perfectly correcct of course ... I guess that my main problems were twofold ... i didn't test with small sets of data and I just tested by experiment rather than proper analysis of the algorithm. Thanks.

        I just checked this with the code that you suggest on my Win32 PC and the "random" numbers appeared the same every time!! So I didn't get the problem. I then checked it using a unix perl and got the example you cited after the fifth trial ... thanks very much - I really appreciate it. It was fun too.

        Regards, Marburg (john.keating@may.ie)

[reply]

In Section Code Catacombs