Perl Advent Calendar 2010-12-02

Setting the bar high with an array of unique gifts

by Adam Russell

Not every elf studies the theory and craft of toymaking at elf college. Some elves study more abstract but less employable subjects and come to toy making after making the sad realization that very few people care to, say, discuss that shiny new Rubik's Cube that Santa dropped off in terms of Galois Theory.¹ Of course, there are some happy intersections between the abstract and the practical. Set::Array is an example of one such useful application of the abstract—Set Theory—towards cleaner and more maintainable code. Set::Array essentially wraps arrays in a class that defines higher level functions on the internal data. Of course you can still do the basics. The code below shows some of the classic array functions anyone would expect.

Running this:

my $sa0=Set::Array->new(qw/b a yams tartes/);
$sa0->pop(); #methods that that throw pies aren't chainable
$sa0->unshift('cider')->delete('yams')->reverse();

Results in a $sa0 Set::Array object with elements (a, b, cider)

But such functionality is simply the new pair of underwear under the tree when what you really want is a train set! Let us direct our attention to the well hidden and expertly wrapped gifts in the corner under the stairs.

Set::Array comes with a variety of parent-approved² Nerf weaponry to attack our array-like objects with ammunition ranging from the canonical union() on line 36 for our sample script, to the sugary join() on 38 and esoteric bag() on lines 35 and 53.

bag() is a bit of a departure from "real" sets in that it does not exclude duplicates. To ensure uniqueness to elements the module comes with a very necessary unique() function which is included presumably to, you know, actually allow us to convincingly use the word "set". ho ho ho.

Given another array…

my $sa1=Set::Array->new(0,1,'cider','eggnog');

…we can test some of the more set-like operations amongst the thirty-odd methods available:

print $sa0->difference($sa1)->join(', ');
#a, b

print $sa0->intersection($sa1)->join(', ');
#a, b, cider

print $sa0->symmetric_difference($sa1)->join(', ');
#1, a, 0, b, eggnog

In case you've forgotten your math, that last one returns the elements that occur in either set but do not also occur in the intersection.

Finally, it should be mentioned that the proper set operations implemented by Set::Array also come with overloaded operator synonyms i.e; +, &, -, *, and % They were left out of the examples since overloaded operators bring back ghosts of C++ courses past.

mod2.pl

   1 # Keeping with the spirit of fun there is some slight obfuscation
   2 # and possibly questionable coding practices in an attempt to show off as many
   3 # Set-Array functions as possible. Also there is some questionable grammar.
   4 # The singular form of geese-a-laying surely isn't geese-a-laying is it?
   5 # Healthy pours of some wassail will relieve my mind (and yours) of these
   6 # concerns and induce some holiday cheer... Adam Russell ac.russell@live.com
   7 
   8 use Set::Array;  
   9 my @gifts_per_day=();
  10 my @cardinals=qw(first second third fourth
  11                  fifth sixth seventh eighth
  12                  ninth tenth eleventh twelfth);
  13 my @gifts=qw(partridge 
  14              turtle-dove 
  15              french-hens
  16              calling-bird
  17              golden-ring
  18              geese-a-laying
  19              swan-a-swimming
  20              maid-a-milking
  21              lady-dancing
  22              lord-a-leaping
  23              piper-piping
  24              drummer-drumming);
  25 
  26 foreach my $day (1..12){ #the song wins--there is no 0th day of Christmas!
  27     $gifts_per_day[$day]=Set::Array->new(split(/\s/, "$gifts[$day-1] " x $day));
  28 }
  29 
  30 my $total_gifts=Set::Array->new;
  31 my $total_unique_gifts=Set::Array->new;
  32 
  33 foreach my $day (1..12){
  34     my $gifts=gift_calculator($day);
  35     $total_gifts->bag($gifts); #bag keeps duplicates
  36     $total_unique_gifts->union($gifts); #union discards duplicates
  37     print "On the $cardinals[$day-1] of Christmas my true love gave to me the following lovely gifts: ";
  38     $gifts->join(" ")->print(1);
  39 }
  40 
  41 my $total_number_gifts=$total_gifts->length();
  42 my $total_number_geese=$total_gifts->count($gifts[5]);
  43 my $unique_gifts=$total_unique_gifts->length();
  44 
  45 print "I received $total_number_gifts gifts!\n";
  46 print "But I only got $unique_gifts different sorts of things...\n";
  47 print "What am I supposed to do with $total_number_geese $gifts[5]? Are they going to eat much?\n";
  48 
  49 sub gift_calculator{
  50     my $todays_gifts=Set::Array->new;
  51     my $current_day=shift @_;
  52     foreach my $day (1..$current_day){ #use bag() to bag the gifts!
  53         $todays_gifts->bag($gifts_per_day[$day]);
  54     }
  55     return $todays_gifts;
  56 }

1. Hans Zassenhaus, Rubik's cube: A toy, a galois tool, group theory for everybody, Physica A: Statistical Mechanics and its Applications, Volume 114, Issues 1-3, August 1982, Pages 629-637, ISSN 0378-4371, DOI: 10.1016/0378-4371(82)90362-4

2. The modification of the caller $sa0 is because of the void context. If we had called the function in a list context…

my @sack=$sa0->bag($sa1);