Commit | Line | Data |
c2a0627f |
1 | |
2 | =pod |
3 | |
4 | =head1 NAME |
5 | |
58d129ba |
6 | Moose::Cookbook::Basics::Recipe10 - Operator overloading, subtypes, and coercion |
c2a0627f |
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 |
021b8139 |
88 | is available in the L<Moose::Cookbook::Basics::Recipe4>. |
c2a0627f |
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 |
021b8139 |
97 | this can be found in L<Moose::Cookbook::Basics::Recipe5>. |
c2a0627f |
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 | |