lib/Moose/Cookbook/Basics/Recipe10.pod

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