lib/Moose/Cookbook/Recipe12.pod

   1
   2 =pod
   3
   4 =head1 NAME
   5
   6 Moose::Cookbook::Recipe12 - Create humans and their spawn using operator
   7 overloading, subtypes, and coercion.
   8
   9 =head1 SYNOPSIS
  10
  11   package Human;
  12
  13   use Moose;
  14   use Moose::Util::TypeConstraints;
  15
  16   subtype 'Gender'
  17       => as 'Str'
  18       => where { $_ =~ m{^[mf]$}s };
  19
  20   has 'gender' => ( is => 'ro', isa => 'Gender', required => 1 );
  21
  22   has 'mother' => ( is => 'ro', isa => 'Human' );
  23   has 'father' => ( is => 'ro', isa => 'Human' );
  24
  25   use overload '+' => \&_overload_add, fallback => 1;
  26
  27   sub _overload_add {
  28       my ($one, $two) = @_;
  29
  30       die('Only male and female humans may create children')
  31           if ($one->gender() eq $two->gender());
  32
  33       my ( $mother, $father ) = ( $one->gender eq 'f' ? ($one, $two) : ($two, $one) );
  34
  35       my $gender = 'f';
  36       $gender = 'm' if (rand() >= 0.5);
  37
  38       return Human->new(
  39           gender => $gender,
  40           mother => $mother,
  41           father => $father,
  42       );
  43   }
  44
  45 =head1 DESCRIPTION
  46
  47 This Moose cookbook recipe shows how operator overloading, coercion,
  48 and sub types can be used to mimic the human reproductive system
  49 (well, the selection of genes at least).  Assumes a basic
  50 understanding of Moose.
  51
  52 =head1 INTRODUCTION
  53
  54 The example in the SYNOPSIS outlines a very basic use of
  55 operator overloading and Moose.  The example creates a class
  56 that allows you to add together two humans and produce a
  57 child from them.
  58
  59 The two parents must be of the opposite gender, as to do
  60 otherwise wouldn't be biologically possible no matter how much
  61 I might want to allow it.
  62
  63 While this example works and gets the job done, it really isn't
  64 all that useful.  To take this a step further let's play around
  65 with genes.  Particularly the genes that dictate eye color.  Why
  66 eye color?  Because it is simple.  There are two genes that have
  67 the most affect on eye color and each person carries two of each
  68 gene.  Now that will be useful!
  69
  70 Oh, and don't forget that you were promised some coercion goodness.
  71
  72 =head1 TECHNIQUES
  73
  74 First, let's quickly define the techniques that will be used.
  75
  76 =head2 Operator Overloading
  77
  78 Overloading operators takes a simple declaration of which operator
  79 you want to overload and what method to call.  See the perldoc for
  80 overload to see some good, basic, examples.
  81
  82 =head2 Subtypes
  83
  84 Moose comes with 21 default type constraints, as documented in
  85 L<Moose::Util::TypeConstraints>.  Int, Str, and CodeRef are
  86 all examples.  Subtypes give you the ability to inherit the
  87 constraints of an existing type, and adding additional
  88 constraints on that type.  An introduction to type constraints
  89 is available in the L<Moose::Cookbook::Recipe4>.
  90
  91 =head2 Coercion
  92
  93 When an attribute is assigned a value its type constraint
  94 is checked to validate the value.  Normally, if the value
  95 does not pass the constraint, an exception will be thrown.
  96 But, it is possible with Moose to define the rules to coerce
  97 values from one type to another.  A good introduction to
  98 this can be found in L<Moose::Cookbook::Recipe5>.
  99
 100 =head1 GENES
 101
 102 As I alluded to in the introduction, there are many different
 103 genes that affect eye color.  But, there are 2 genes that play
 104 the most prominent role: gey and bey2.  To get started let us
 105 make classes for these genes.
 106
 107 =head2 bey2
 108
 109   package Human::Gene::bey2;
 110
 111   use Moose;
 112   use Moose::Util::TypeConstraints;
 113
 114   type 'bey2Color' => where { $_ =~ m{^(?:brown|blue)$}s };
 115
 116   has 'color' => ( is => 'ro', isa => 'bey2Color' );
 117
 118 This class is really simple.  All we need to know about the bey2
 119 gene is whether it is of the blue or brown variety.  As you can
 120 see a type constraint for the color attribute has been created
 121 which validates for the two possible colors.
 122
 123 =head2 gey
 124
 125   package Human::Gene::gey;
 126
 127   use Moose;
 128   use Moose::Util::TypeConstraints;
 129
 130   type 'geyColor' => where { $_ =~ m{^(?:green|blue)$}s };
 131
 132   has 'color' => ( is => 'ro', isa => 'geyColor' );
 133
 134 The gey gene is nearly identical to the bey2, except that it
 135 has a green or blue variety.
 136
 137 =head1 EYE COLOR
 138
 139 Rather than throwing the 4 gene object (2xbey, 2xgey2) straight
 140 on to the Human class, let's create an intermediate class that
 141 abstracts the logic behind eye color.  This way the Human class
 142 won't get all cluttered up with the details behind the different
 143 characteristics that makes up a Human.
 144
 145   package Human::EyeColor;
 146
 147   use Moose;
 148   use Moose::Util::TypeConstraints;
 149
 150   subtype 'bey2Gene'
 151       => as 'Object'
 152       => where { $_->isa('Human::Gene::bey2') };
 153
 154   coerce 'bey2Gene'
 155       => from 'Str'
 156           => via { Human::Gene::bey2->new( color => $_ ) };
 157
 158   subtype 'geyGene'
 159       => as 'Object'
 160       => where { $_->isa('Human::Gene::gey') };
 161
 162   coerce 'geyGene'
 163       => from 'Str'
 164           => via { Human::Gene::gey->new( color => $_ ) };
 165
 166   has 'bey2_1' => ( is => 'ro', isa => 'bey2Gene', coerce => 1 );
 167   has 'bey2_2' => ( is => 'ro', isa => 'bey2Gene', coerce => 1 );
 168
 169   has 'gey_1'  => ( is => 'ro', isa => 'geyGene', coerce => 1 );
 170   has 'gey_2'  => ( is => 'ro', isa => 'geyGene', coerce => 1 );
 171
 172 So, we now have a class that can hold the four genes that dictate
 173 eye color.  This isn't quite enough, as we also need to calculate
 174 what the human's actual eye color is as a result of the genes.
 175
 176 As with most genes there are recessive and dominant genes.  The bey2
 177 brown gene is dominant to both blue and green.  The gey green gene is
 178 recessive to the brown bey gene and dominant to the blues.  Finally,
 179 the bey and gey2 blue genes are recessive to both brown and green.
 180
 181   sub color {
 182       my ( $self ) = @_;
 183
 184       return 'brown' if ($self->bey2_1->color() eq 'brown' or $self->bey2_2->color() eq 'brown');
 185       return 'green' if ($self->gey_1->color() eq 'green' or $self->gey_2->color() eq 'green');
 186       return 'blue';
 187   }
 188
 189 To top it off, if I want to access color(), I want to be really lazy
 190 about it.  Perl overloading supports the ability to overload the
 191 stringification of an object.  So, normally if I did "$eye_color"
 192 I'd get something like "Human::EyeColor=HASH(0xba9348)".  What I
 193 really want is "brown", "green", or "blue".  To do this you overload
 194 the stringification of the object.
 195
 196   use overload '""' => \&color, fallback => 1;
 197
 198 That's all and good, but don't forget the spawn!  Our
 199 humans have to have children, and those children need to inherit
 200 genes from their parents.  Let's use operator overloading so
 201 that we can add (+) together two EyeColor characteristics to
 202 create a new EyeColor that is derived in a similar manner as
 203 the gene selection in human reproduction.
 204
 205   use overload '+' => \&_overload_add, fallback => 1;
 206
 207   sub _overload_add {
 208       my ($one, $two) = @_;
 209
 210       my $one_bey2 = 'bey2_' . _rand2();
 211       my $two_bey2 = 'bey2_' . _rand2();
 212
 213       my $one_gey = 'gey_' . _rand2();
 214       my $two_gey = 'gey_' . _rand2();
 215
 216       return Human::EyeColor->new(
 217           bey2_1 => $one->$one_bey2->color(),
 218           bey2_2 => $two->$two_bey2->color(),
 219           gey_1  => $one->$one_gey->color(),
 220           gey_2  => $two->$two_gey->color(),
 221       );
 222   }
 223
 224   sub _rand2 {
 225       return 1 + int( rand(2) );
 226   }
 227
 228 What is happening here is we are overloading the addition
 229 operator.  When two eye color objects are added together
 230 the _overload_add() method will be called with the two
 231 objects on the left and right side of the + as arguments.
 232 The return value of this method should be the expected
 233 result of the addition.  I'm not going to go in to the
 234 details of how the gene's are selected as it should be
 235 fairly self-explanatory.
 236
 237 =head1 HUMAN EVOLUTION
 238
 239 Our original human class in the SYNOPSIS requires very little
 240 change to support the new EyeColor characteristic.  All we
 241 need to do is define a new subtype called EyeColor, a new
 242 attribute called eye_color, and just for the sake of simple code
 243 we'll coerce an arrayref of colors in to an EyeColor object.
 244
 245   use List::MoreUtils qw( zip );
 246
 247   subtype 'EyeColor'
 248       => as 'Object'
 249       => where { $_->isa('Human::EyeColor') };
 250
 251   coerce 'EyeColor'
 252       => from 'ArrayRef'
 253           => via {
 254               my @genes = qw( bey2_1 bey2_2 gey_1 gey_2 );
 255               return Human::EyeColor->new( zip( @genes, @$_ ) );
 256           };
 257
 258   has 'eye_color' => ( is => 'ro', isa => 'EyeColor', coerce => 1, required => 1 );
 259
 260 And then in the _overload_add() of the Human class we modify
 261 the creation of the child object to include the addition of
 262 the mother and father's eye colors.
 263
 264   return Human->new(
 265       gender => $gender,
 266       eye_color => ( $one->eye_color() + $two->eye_color() ),
 267       mother => $mother,
 268       father => $father,
 269   );
 270
 271 =head1 CONCLUSION
 272
 273 The three techniques used in this article - overloading, subtypes,
 274 and coercion - provide the power to produce simple, flexible, powerful,
 275 explicit, inheritable, and enjoyable interfaces.
 276
 277 If you want to get your hands on this code all combined together, and
 278 working, download the Moose tarball and look at "t/000_recipes/012_genes.t".
 279
 280 =head1 NEXT STEPS
 281
 282 Has this been a real project we'd probably want to:
 283
 284 =over 4
 285
 286 =item Better Randomization with Crypt::Random
 287
 288 =item Characteristic Base Class
 289
 290 =item Mutating Genes
 291
 292 =item More Characteristics
 293
 294 =item Artificial Life
 295
 296 =back
 297
 298 =head1 AUTHOR
 299
 300 Aran Clary Deltac <bluefeet@cpan.org>
 301
 302 =head1 LICENSE
 303
 304 This work is licensed under a Creative Commons Attribution 3.0 Unported License.
 305
 306 License details are at: L<http://creativecommons.org/licenses/by/3.0/>
 307
 308 =cut
 309