6 Moose::Cookbook::Recipe12 - Create humans and their spawn using operator
7 overloading, subtypes, and coercion.
14 use Moose::Util::TypeConstraints;
18 => where { $_ =~ m{^[mf]$}s };
20 has 'gender' => ( is => 'ro', isa => 'Gender', required => 1 );
22 has 'mother' => ( is => 'ro', isa => 'Human' );
23 has 'father' => ( is => 'ro', isa => 'Human' );
25 use overload '+' => \&_overload_add, fallback => 1;
30 die('Only male and female humans may create children')
31 if ($one->gender() eq $two->gender());
33 my ( $mother, $father ) = ( $one->gender eq 'f' ? ($one, $two) : ($two, $one) );
36 $gender = 'm' if (rand() >= 0.5);
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.
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
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.
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!
70 Oh, and don't forget that you were promised some coercion goodness.
74 First, let's quickly define the techniques that will be used.
76 =head2 Operator Overloading
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.
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>.
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>.
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.
109 package Human::Gene::bey2;
112 use Moose::Util::TypeConstraints;
114 type 'bey2Color' => where { $_ =~ m{^(?:brown|blue)$}s };
116 has 'color' => ( is => 'ro', isa => 'bey2Color' );
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.
125 package Human::Gene::gey;
128 use Moose::Util::TypeConstraints;
130 type 'geyColor' => where { $_ =~ m{^(?:green|blue)$}s };
132 has 'color' => ( is => 'ro', isa => 'geyColor' );
134 The gey gene is nearly identical to the bey2, except that it
135 has a green or blue variety.
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.
145 package Human::EyeColor;
148 use Moose::Util::TypeConstraints;
152 => where { $_->isa('Human::Gene::bey2') };
156 => via { Human::Gene::bey2->new( color => $_ ) };
160 => where { $_->isa('Human::Gene::gey') };
164 => via { Human::Gene::gey->new( color => $_ ) };
166 has 'bey2_1' => ( is => 'ro', isa => 'bey2Gene', coerce => 1 );
167 has 'bey2_2' => ( is => 'ro', isa => 'bey2Gene', coerce => 1 );
169 has 'gey_1' => ( is => 'ro', isa => 'geyGene', coerce => 1 );
170 has 'gey_2' => ( is => 'ro', isa => 'geyGene', coerce => 1 );
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.
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.
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');
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.
196 use overload '""' => \&color, fallback => 1;
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.
205 use overload '+' => \&_overload_add, fallback => 1;
208 my ($one, $two) = @_;
210 my $one_bey2 = 'bey2_' . _rand2();
211 my $two_bey2 = 'bey2_' . _rand2();
213 my $one_gey = 'gey_' . _rand2();
214 my $two_gey = 'gey_' . _rand2();
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(),
225 return 1 + int( rand(2) );
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.
237 =head1 HUMAN EVOLUTION
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.
245 use List::MoreUtils qw( zip );
249 => where { $_->isa('Human::EyeColor') };
254 my @genes = qw( bey2_1 bey2_2 gey_1 gey_2 );
255 return Human::EyeColor->new( zip( @genes, @$_ ) );
258 has 'eye_color' => ( is => 'ro', isa => 'EyeColor', coerce => 1, required => 1 );
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.
266 eye_color => ( $one->eye_color() + $two->eye_color() ),
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.
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".
282 Has this been a real project we'd probably want to:
286 =item Better Randomization with Crypt::Random
288 =item Characteristic Base Class
292 =item More Characteristics
294 =item Artificial Life
300 Aran Clary Deltac <bluefeet@cpan.org>
304 This work is licensed under a Creative Commons Attribution 3.0 Unported License.
306 License details are at: L<http://creativecommons.org/licenses/by/3.0/>