Beefy Boxes and Bandwidth Generously Provided by pair Networks
Think about Loose Coupling
 
PerlMonks  

Gift Exchange Code

by agianni (Hermit)
on Oct 29, 2008 at 20:31 UTC ( #720328=perlquestion: print w/ replies, xml ) Need Help??
agianni has asked for the wisdom of the Perl Monks concerning the following question:

Before I write this code myself, I thought I'd check to see if anyone has any suggestions of existing CPAN modules or code snippets that would help me along my way. I want to write a simple script to shuffle a bunch of people for a gift exchange. The complicating factor is that I want to make sure that significant others aren't matched with each other. So given a group of people a, b, c and d where a and b are SOs, a can be matched with anyone but b and vice versa while c and d can be matched with anyone. Any suggestions?
perl -e 'split//,q{john hurl, pest caretaker}and(map{print @_[$_]}(joi +n(q{},map{sprintf(qq{%010u},$_)}(2**2*307*4993,5*101*641*5261,7*59*79 +*36997,13*17*71*45131,3**2*67*89*167*181))=~/\d{2}/g));'

Comment on Gift Exchange Code
Download Code
Re: Gift Exchange Code
by JadeNB (Chaplain) on Oct 29, 2008 at 21:29 UTC
Re: Gift Exchange Code
by MidLifeXis (Prior) on Oct 29, 2008 at 21:31 UTC

    General bin packing problem. Instead of checking if the pair of people "fit", however, you test against your own constraints - they are not SO. If not, pair them, move the pair into the bin, and move on with the remaining people.

    Some pseudocode

    global results = (); function match (people) { if (people.empty) { return SUCCESS } $x = people.pop; foreach $y (people) { if (validpair($x, $y) { if (match(people.remove($y)) == SUCCESS) { results.push( {$x, $y} ); return SUCCESS; } } } return FAILURE; }

    --MidLifeXis

      Maybe I misunderstand the term ‘bin packing’, but I always thought that it applied to the problem of assigning weighted objects to bins with a maximum weight allowance, in such a way that there is as little “wasted space” as possible. Aside from the general terminology of putting things in a bin, this idea doesn't seem to share anything with that problem setting. (The pseudo-code looks good for the OP's problem, though, assuming that remove is non-destructive.)

        You are correct. I tend to over-generalize problems. Perhaps a more proper comparison (at least from the standpoint of the algorithm) would be a knights tour problem, tic-tac-toe, or some other game-type problem.

        The difference between bin-packing and this problem, is that I can assume that every item in the data set must be used. In bin packing that may not be true (bin.size < data.sum(size)).

        The solutions, however, can be very similar. One area of difference that I can see is that the selection of the first item ($x = people.pop) is not correct. Perhaps removing it completely and modifying the termination check (the if clause at the top) to some fitness test (less than N% wasted space, for example) would get close enough to be a solution. Note that I did not say the best solution.

        Basically I am doing a depth first search of all option paths, pruning the tree (FAILURE) if an invalid combination occurs, and building the answer as I unwind the call stack (results.push) if I exhaust the list of people (people.empty).

        Now, this solution (and I don't think the original problem asked to do this) does not handle the case where there are an odd number of people in the list, and it pairs up people rather than allowing A to give to B, B to give to C, and C to give to A. Perhaps CountZero's solution would be better in this case.

        --MidLifeXis

      ... and if your final pair is SO so 'FAILURE'?

        Then the entire algorithm returns failure, since there is no possible way to match everyone into pairs successfully. This search is an exhaustive search (well, until a single successful set of matches is found).

        --MidLifeXis

Re: Gift Exchange Code
by CountZero (Bishop) on Oct 29, 2008 at 22:05 UTC
    It is easy if you allow a bit of "cheating" (although nobody will notice).

    Make two arrays as follows: @array1 = qw/man1 man2 woman3 single1 single2/; and @array2 = qw/woman1 woman2 man3 single3 single4/;

    man1 and woman1 are SO to each other, same for man2 and woman2, etc.

    Now do a few times push @array2, shift @array2; (less than the number of elements in this array of course). You have now rolled-over this array and you can pair-off the elements of both arrays against each other and guarantee that no SOs will "meet".

    The "cheating" is that you cannot find all possible legal combinations in this way, but who would need that?

    CountZero

    A program should be light and agile, its subroutines connected like a string of pearls. The spirit and intent of the program should be retained throughout. There should be neither too little or too much, neither needless loops nor useless variables, neither lack of structure nor overwhelming rigidity." - The Tao of Programming, 4.1 - Geoffrey James

Re: Gift Exchange Code
by JadeNB (Chaplain) on Oct 29, 2008 at 22:12 UTC
    As MidLifeXis mentions above, this seems to be a very easy problem if you only need one working match. Is there some further requirement? Do you maybe want to see lots of possibilities, and pick only the best one? If you really just need one match, then let's suppose that you have an array @people of people, and a hash %so_s with the properties that keys %so_s consists only of people with SOs and that, whenever $a and $b are SOs, exactly one of $a or $b is a key of %so_s, with the other as the corresponding value. (In your example, %so_s could be ( a => 'b' ) or ( b => 'a' ).) Then
    die "No match possible" if @people % 2 or @people == 2 and %so_s; %reverse_so_s = reverse %so_s; @keys = keys %so_s; @values = values %so_s; @singles = grep { ! ( exists $so_s{$_} or exists $reverse_so_s{$_} ) } + @people; %matches = ( @keys, @singles, @values );
    should do it.

    UPDATE: Oops, CountZero posted a very similar solution already. Much of my set-up is designed just to construct his or her @array1 and @array2.

    UPDATE 2: Oops again. This dies far too often. (For example, it thinks that no match is possible if a, b, and c are affianced to d, e, and f, respectively, whereas that is not the case.) A few minutes' thought didn't show how to fix this without serious re-jiggering.

    UPDATE 3: Third time's a charm, I hope. (Hey, maybe this is why people use modules instead of worrying about edge cases in their own code, huh?)

Re: Gift Exchange Code
by mikelieman (Pilgrim) on Oct 30, 2008 at 15:57 UTC
    Perhaps rolling through the Significant Others making matches first, so at the end of the process all you have is candidates without significant others?
Re: Gift Exchange Code
by BrowserUk (Pope) on Oct 30, 2008 at 20:34 UTC

    This is not determanistic but fair, reliable and reasonably fast.

    Basically, it shuffles the indices and reshuffles if the outcome violates the specifications, as many times as it takes to get the required outcome.

    For small arrays, it can take several attempts--with 10 couples I've seen it take 6 attempts--but with arrays that size it still doesn't take long. For larger arrays--100 or more--it rarely takes more than 2 attempts, and the larger the array, the less likely that it will need a second attempt.

    #! perl -slw use strict; use List::Util qw[ shuffle ]; our $N ||= 10; my @people = map{ $_ . 'a', $_ . 'b' } 1 .. $N; my $iters = 1; ## Just for testing my @indices = shuffle 0 .. $#people; ++$iters, @indices = shuffle 0 .. $#people while grep{ $indices[ $_ + 1] & 1 ## If the upper item + is odd ? $indices[ $_ ] +1 == $indices[ $_ + 1 ] ## the lower shouldn +'t be -1 : $indices[ $_ ] == $indices[ $_ + 1 ] +1 ## vice versa } 0 .. $#people/2; @people = @people[ @indices ]; ## shuffle the real data print "Took $iters iterations"; ## How many tries? print "@people[ $_, $_+1 ]" for 0 .. $#people/2 if <STDIN>; ## Allows +^C

    Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
    "Science is about questioning the status quo. Questioning authority".
    In the absence of evidence, opinion is indistinguishable from prejudice.

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others drinking their drinks and smoking their pipes about the Monastery: (5)
As of 2014-07-26 04:43 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    My favorite superfluous repetitious redundant duplicative phrase is:









    Results (175 votes), past polls