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 )
  33           = ( $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::Basics::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::Basics::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'
 185           if ( $self->bey2_1->color() eq 'brown'
 186           or $self->bey2_2->color() eq 'brown' );
 187
 188       return 'green'
 189           if ( $self->gey_1->color() eq 'green'
 190           or $self->gey_2->color() eq 'green' );
 191
 192       return 'blue';
 193   }
 194
 195 To top it off, if I want to access color(), I want to be really lazy
 196 about it.  Perl overloading supports the ability to overload the
 197 stringification of an object.  So, normally if I did "$eye_color"
 198 I'd get something like "Human::EyeColor=HASH(0xba9348)".  What I
 199 really want is "brown", "green", or "blue".  To do this you overload
 200 the stringification of the object.
 201
 202   use overload '""' => \&color, fallback => 1;
 203
 204 That's all and good, but don't forget the spawn!  Our
 205 humans have to have children, and those children need to inherit
 206 genes from their parents.  Let's use operator overloading so
 207 that we can add (+) together two EyeColor characteristics to
 208 create a new EyeColor that is derived in a similar manner as
 209 the gene selection in human reproduction.
 210
 211   use overload '+' => \&_overload_add, fallback => 1;
 212
 213   sub _overload_add {
 214       my ( $one, $two ) = @_;
 215
 216       my $one_bey2 = 'bey2_' . _rand2();
 217       my $two_bey2 = 'bey2_' . _rand2();
 218
 219       my $one_gey = 'gey_' . _rand2();
 220       my $two_gey = 'gey_' . _rand2();
 221
 222       return Human::EyeColor->new(
 223           bey2_1 => $one->$one_bey2->color(),
 224           bey2_2 => $two->$two_bey2->color(),
 225           gey_1  => $one->$one_gey->color(),
 226           gey_2  => $two->$two_gey->color(),
 227       );
 228   }
 229
 230   sub _rand2 {
 231       return 1 + int( rand(2) );
 232   }
 233
 234 What is happening here is we are overloading the addition
 235 operator.  When two eye color objects are added together
 236 the _overload_add() method will be called with the two
 237 objects on the left and right side of the + as arguments.
 238 The return value of this method should be the expected
 239 result of the addition.  I'm not going to go in to the
 240 details of how the gene's are selected as it should be
 241 fairly self-explanatory.
 242
 243 =head1 HUMAN EVOLUTION
 244
 245 Our original human class in the SYNOPSIS requires very little
 246 change to support the new EyeColor characteristic.  All we
 247 need to do is define a new subtype called EyeColor, a new
 248 attribute called eye_color, and just for the sake of simple code
 249 we'll coerce an arrayref of colors in to an EyeColor object.
 250
 251   use List::MoreUtils qw( zip );
 252
 253   subtype 'EyeColor'
 254       => as 'Object'
 255       => where { $_->isa('Human::EyeColor') };
 256
 257   coerce 'EyeColor'
 258       => from 'ArrayRef'
 259       => via { my @genes = qw( bey2_1 bey2_2 gey_1 gey_2 );
 260               return Human::EyeColor->new( zip( @genes, @$_ ) ); };
 261
 262   has 'eye_color' =>
 263       ( is => 'ro', isa => 'EyeColor', coerce => 1, required => 1 );
 264
 265 And then in the _overload_add() of the Human class we modify
 266 the creation of the child object to include the addition of
 267 the mother and father's eye colors.
 268
 269   return Human->new(
 270       gender    => $gender,
 271       eye_color => ( $one->eye_color() + $two->eye_color() ),
 272       mother    => $mother,
 273       father    => $father,
 274   );
 275
 276 =head1 CONCLUSION
 277
 278 The three techniques used in this article - overloading, subtypes,
 279 and coercion - provide the power to produce simple, flexible, powerful,
 280 explicit, inheritable, and enjoyable interfaces.
 281
 282 If you want to get your hands on this code all combined together, and
 283 working, download the Moose tarball and look at "t/000_recipes/012_genes.t".
 284
 285 =head1 NEXT STEPS
 286
 287 Has this been a real project we'd probably want to:
 288
 289 =over 4
 290
 291 =item Better Randomization with Crypt::Random
 292
 293 =item Characteristic Base Class
 294
 295 =item Mutating Genes
 296
 297 =item More Characteristics
 298
 299 =item Artificial Life
 300
 301 =back
 302
 303 =head1 AUTHOR
 304
 305 Aran Clary Deltac <bluefeet@cpan.org>
 306
 307 =head1 LICENSE
 308
 309 This work is licensed under a Creative Commons Attribution 3.0 Unported License.
 310
 311 License details are at: L<http://creativecommons.org/licenses/by/3.0/>
 312
 313 =cut
 314