--- /dev/null
+
+=pod
+
+=head1 NAME
+
+Moose::Cookbook::Recipe12 - Create humans and their spawn using operator
+overloading, subtypes, and coercion.
+
+=head1 SYNOPSIS
+
+ package Human;
+
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ subtype 'Gender'
+ => as 'Str'
+ => where { $_ =~ m{^[mf]$}s };
+
+ has 'gender' => ( is => 'ro', isa => 'Gender', required => 1 );
+
+ has 'mother' => ( is => 'ro', isa => 'Human' );
+ has 'father' => ( is => 'ro', isa => 'Human' );
+
+ use overload '+' => \&_overload_add, fallback => 1;
+
+ sub _overload_add {
+ my ($one, $two) = @_;
+
+ die('Only male and female humans may create children')
+ if ($one->gender() eq $two->gender());
+
+ my ( $mother, $father ) = ( $one->gender eq 'f' ? ($one, $two) : ($two, $one) );
+
+ my $gender = 'f';
+ $gender = 'm' if (rand() >= 0.5);
+
+ return Human->new(
+ gender => $gender,
+ mother => $mother,
+ father => $father,
+ );
+ }
+
+=head1 DESCRIPTION
+
+This Moose cookbook recipe shows how operator overloading, coercion,
+and sub types can be used to mimic the human reproductive system
+(well, the selection of genes at least). Assumes a basic
+understanding of Moose.
+
+=head1 INTRODUCTION
+
+The example in the SYNOPSIS outlines a very basic use of
+operator overloading and Moose. The example creates a class
+that allows you to add together two humans and produce a
+child from them.
+
+The two parents must be of the opposite gender, as to do
+otherwise wouldn't be biologically possible no matter how much
+I might want to allow it.
+
+While this example works and gets the job done, it really isn't
+all that useful. To take this a step further let's play around
+with genes. Particularly the genes that dictate eye color. Why
+eye color? Because it is simple. There are two genes that have
+the most affect on eye color and each person carries two of each
+gene. Now that will be useful!
+
+Oh, and don't forget that you were promised some coercion goodness.
+
+=head1 TECHNIQUES
+
+First, let's quickly define the techniques that will be used.
+
+=head2 Operator Overloading
+
+Overloading operators takes a simple declaration of which operator
+you want to overload and what method to call. See the perldoc for
+overload to see some good, basic, examples.
+
+=head2 Subtypes
+
+Moose comes with 21 default type constraints, as documented in
+L<Moose::Util::TypeConstraints>. Int, Str, and CodeRef are
+all examples. Subtypes give you the ability to inherit the
+constraints of an existing type, and adding additional
+constraints on that type. An introduction to type constraints
+is available in the L<Moose::Cookbook::Recipe4>.
+
+=head2 Coercion
+
+When an attribute is assigned a value its type constraint
+is checked to validate the value. Normally, if the value
+does not pass the constraint, an exception will be thrown.
+But, it is possible with Moose to define the rules to coerce
+values from one type to another. A good introduction to
+this can be found in L<Moose::Cookbook::Recipe5>.
+
+=head1 GENES
+
+As I alluded to in the introduction, there are many different
+genes that affect eye color. But, there are 2 genes that play
+the most prominent role: gey and bey2. To get started let us
+make classes for these genes.
+
+=head2 bey2
+
+ package Human::Gene::bey2;
+
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ type 'bey2Color' => where { $_ =~ m{^(?:brown|blue)$}s };
+
+ has 'color' => ( is => 'ro', isa => 'bey2Color' );
+
+This class is really simple. All we need to know about the bey2
+gene is whether it is of the blue or brown variety. As you can
+see a type constraint for the color attribute has been created
+which validates for the two possible colors.
+
+=head2 gey
+
+ package Human::Gene::gey;
+
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ type 'geyColor' => where { $_ =~ m{^(?:green|blue)$}s };
+
+ has 'color' => ( is => 'ro', isa => 'geyColor' );
+
+The gey gene is nearly identical to the bey2, except that it
+has a green or blue variety.
+
+=head1 EYE COLOR
+
+Rather than throwing the 4 gene object (2xbey, 2xgey2) straight
+on to the Human class, let's create an intermediate class that
+abstracts the logic behind eye color. This way the Human class
+won't get all cluttered up with the details behind the different
+characteristics that makes up a Human.
+
+ package Human::EyeColor;
+
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ subtype 'bey2Gene'
+ => as 'Object'
+ => where { $_->isa('Human::Gene::bey2') };
+
+ coerce 'bey2Gene'
+ => from 'Str'
+ => via { Human::Gene::bey2->new( color => $_ ) };
+
+ subtype 'geyGene'
+ => as 'Object'
+ => where { $_->isa('Human::Gene::gey') };
+
+ coerce 'geyGene'
+ => from 'Str'
+ => via { Human::Gene::gey->new( color => $_ ) };
+
+ has 'bey2_1' => ( is => 'ro', isa => 'bey2Gene', coerce => 1 );
+ has 'bey2_2' => ( is => 'ro', isa => 'bey2Gene', coerce => 1 );
+
+ has 'gey_1' => ( is => 'ro', isa => 'geyGene', coerce => 1 );
+ has 'gey_2' => ( is => 'ro', isa => 'geyGene', coerce => 1 );
+
+So, we now have a class that can hold the four genes that dictate
+eye color. This isn't quite enough, as we also need to calculate
+what the human's actual eye color is as a result of the genes.
+
+As with most genes there are recessive and dominant genes. The bey2
+brown gene is dominant to both blue and green. The gey green gene is
+recessive to the brown bey gene and dominant to the blues. Finally,
+the bey and gey2 blue genes are recessive to both brown and green.
+
+ sub color {
+ my ( $self ) = @_;
+
+ return 'brown' if ($self->bey2_1->color() eq 'brown' or $self->bey2_2->color() eq 'brown');
+ return 'green' if ($self->gey_1->color() eq 'green' or $self->gey_2->color() eq 'green');
+ return 'blue';
+ }
+
+To top it off, if I want to access color(), I want to be really lazy
+about it. Perl overloading supports the ability to overload the
+stringification of an object. So, normally if I did "$eye_color"
+I'd get something like "Human::EyeColor=HASH(0xba9348)". What I
+really want is "brown", "green", or "blue". To do this you overload
+the stringification of the object.
+
+ use overload '""' => \&color, fallback => 1;
+
+That's all and good, but don't forget the spawn! Our
+humans have to have children, and those children need to inherit
+genes from their parents. Let's use operator overloading so
+that we can add (+) together two EyeColor characteristics to
+create a new EyeColor that is derived in a similar manner as
+the gene selection in human reproduction.
+
+ use overload '+' => \&_overload_add, fallback => 1;
+
+ sub _overload_add {
+ my ($one, $two) = @_;
+
+ my $one_bey2 = 'bey2_' . _rand2();
+ my $two_bey2 = 'bey2_' . _rand2();
+
+ my $one_gey = 'gey_' . _rand2();
+ my $two_gey = 'gey_' . _rand2();
+
+ return Human::EyeColor->new(
+ bey2_1 => $one->$one_bey2->color(),
+ bey2_2 => $two->$two_bey2->color(),
+ gey_1 => $one->$one_gey->color(),
+ gey_2 => $two->$two_gey->color(),
+ );
+ }
+
+ sub _rand2 {
+ return 1 + int( rand(2) );
+ }
+
+What is happening here is we are overloading the addition
+operator. When two eye color objects are added together
+the _overload_add() method will be called with the two
+objects on the left and right side of the + as arguments.
+The return value of this method should be the expected
+result of the addition. I'm not going to go in to the
+details of how the gene's are selected as it should be
+fairly self-explanatory.
+
+=head1 HUMAN EVOLUTION
+
+Our original human class in the SYNOPSIS requires very little
+change to support the new EyeColor characteristic. All we
+need to do is define a new subtype called EyeColor, a new
+attribute called eye_color, and just for the sake of simple code
+we'll coerce an arrayref of colors in to an EyeColor object.
+
+ use List::MoreUtils qw( zip );
+
+ subtype 'EyeColor'
+ => as 'Object'
+ => where { $_->isa('Human::EyeColor') };
+
+ coerce 'EyeColor'
+ => from 'ArrayRef'
+ => via {
+ my @genes = qw( bey2_1 bey2_2 gey_1 gey_2 );
+ return Human::EyeColor->new( zip( @genes, @$_ ) );
+ };
+
+ has 'eye_color' => ( is => 'ro', isa => 'EyeColor', coerce => 1, required => 1 );
+
+And then in the _overload_add() of the Human class we modify
+the creation of the child object to include the addition of
+the mother and father's eye colors.
+
+ return Human->new(
+ gender => $gender,
+ eye_color => ( $one->eye_color() + $two->eye_color() ),
+ mother => $mother,
+ father => $father,
+ );
+
+=head1 CONCLUSION
+
+The three techniques used in this article - overloading, subtypes,
+and coercion - provide the power to produce simple, flexible, powerful,
+explicit, inheritable, and enjoyable interfaces.
+
+If you want to get your hands on this code all combined together, and
+working, download the Moose tarball and look at "t/000_recipes/012_genes.t".
+
+=head1 NEXT STEPS
+
+Has this been a real project we'd probably want to:
+
+=over 4
+
+=item Better Randomization with Crypt::Random
+
+=item Characteristic Base Class
+
+=item Mutating Genes
+
+=item More Characteristics
+
+=item Artificial Life
+
+=back
+
+=head1 AUTHOR
+
+Aran Clary Deltac <bluefeet@cpan.org>
+
+=head1 LICENSE
+
+This work is licensed under a Creative Commons Attribution 3.0 Unported License.
+
+License details are at: L<http://creativecommons.org/licenses/by/3.0/>
+
+=cut
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+{
+ package Human;
+
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ use List::MoreUtils qw( zip );
+
+ subtype 'EyeColor'
+ => as 'Object'
+ => where { $_->isa('Human::EyeColor') };
+
+ coerce 'EyeColor'
+ => from 'ArrayRef'
+ => via {
+ my @genes = qw( bey2_1 bey2_2 gey_1 gey_2 );
+ return Human::EyeColor->new( zip( @genes, @$_ ) );
+ };
+
+ subtype 'Gender'
+ => as 'Str'
+ => where { $_ =~ m{^[mf]$}s };
+
+ has 'gender' => ( is => 'ro', isa => 'Gender', required => 1 );
+
+ has 'eye_color' => ( is => 'ro', isa => 'EyeColor', coerce => 1, required => 1 );
+
+ has 'mother' => ( is => 'ro', isa => 'Human' );
+ has 'father' => ( is => 'ro', isa => 'Human' );
+
+ use overload '+' => \&_overload_add, fallback => 1;
+
+ sub _overload_add {
+ my ($one, $two) = @_;
+
+ die('Only male and female humans may have children')
+ if ($one->gender() eq $two->gender());
+
+ my ( $mother, $father ) = ( $one->gender eq 'f' ? ($one, $two) : ($two, $one) );
+
+ my $gender = 'f';
+ $gender = 'm' if (rand() >= 0.5);
+
+ # Would be better to use Crypt::Random.
+ #use Crypt::Random qw( makerandom );
+ #$gender = 'm' if (makerandom( Size => 1, Strength => 1, Uniform => 1 ));
+
+ return Human->new(
+ gender => $gender,
+ eye_color => ( $one->eye_color() + $two->eye_color() ),
+ mother => $mother,
+ father => $father,
+ );
+ }
+}
+
+{
+ package Human::EyeColor;
+
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ subtype 'bey2Gene'
+ => as 'Object'
+ => where { $_->isa('Human::Gene::bey2') };
+
+ coerce 'bey2Gene'
+ => from 'Str'
+ => via { Human::Gene::bey2->new( color => $_ ) };
+
+ subtype 'geyGene'
+ => as 'Object'
+ => where { $_->isa('Human::Gene::gey') };
+
+ coerce 'geyGene'
+ => from 'Str'
+ => via { Human::Gene::gey->new( color => $_ ) };
+
+ has 'bey2_1' => ( is => 'ro', isa => 'bey2Gene', coerce => 1 );
+ has 'bey2_2' => ( is => 'ro', isa => 'bey2Gene', coerce => 1 );
+
+ has 'gey_1' => ( is => 'ro', isa => 'geyGene', coerce => 1 );
+ has 'gey_2' => ( is => 'ro', isa => 'geyGene', coerce => 1 );
+
+ use overload '+' => \&_overload_add, fallback => 1;
+ use overload '""' => \&color, fallback => 1;
+
+ sub color {
+ my ( $self ) = @_;
+
+ return 'brown' if ($self->bey2_1->color() eq 'brown' or $self->bey2_2->color() eq 'brown');
+ return 'green' if ($self->gey_1->color() eq 'green' or $self->gey_2->color() eq 'green');
+ return 'blue';
+ }
+
+ sub _overload_add {
+ my ($one, $two) = @_;
+
+ my $one_bey2 = 'bey2_' . _rand2();
+ my $two_bey2 = 'bey2_' . _rand2();
+
+ my $one_gey = 'gey_' . _rand2();
+ my $two_gey = 'gey_' . _rand2();
+
+ return Human::EyeColor->new(
+ bey2_1 => $one->$one_bey2->color(),
+ bey2_2 => $two->$two_bey2->color(),
+ gey_1 => $one->$one_gey->color(),
+ gey_2 => $two->$two_gey->color(),
+ );
+ }
+
+ sub _rand2 {
+ # Would be better to use Crypt::Random.
+ #use Crypt::Random qw( makerandom );
+ #return 1 + makerandom( Size => 1, Strength => 1, Uniform => 1 );
+ return 1 + int( rand(2) );
+ }
+}
+
+{
+ package Human::Gene::bey2;
+
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ type 'bey2Color' => where { $_ =~ m{^(?:brown|blue)$}s };
+
+ has 'color' => ( is => 'ro', isa => 'bey2Color' );
+}
+
+{
+ package Human::Gene::gey;
+
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ type 'geyColor' => where { $_ =~ m{^(?:green|blue)$}s };
+
+ has 'color' => ( is => 'ro', isa => 'geyColor' );
+}
+
+use Test::More tests => 10;
+
+my $gene_color_sets = [
+ [qw( blue blue blue blue ) => 'blue'],
+ [qw( blue blue green blue ) => 'green'],
+ [qw( blue blue blue green ) => 'green'],
+ [qw( blue blue green green ) => 'green'],
+ [qw( brown blue blue blue ) => 'brown'],
+ [qw( brown brown green green ) => 'brown'],
+ [qw( blue brown green blue ) => 'brown'],
+];
+
+foreach my $set (@$gene_color_sets) {
+ my $expected_color = pop( @$set );
+ my $person = Human->new(
+ gender => 'f',
+ eye_color => $set,
+ );
+ is(
+ $person->eye_color(),
+ $expected_color,
+ 'gene combination '.join(',',@$set).' produces '.$expected_color.' eye color',
+ );
+}
+
+my $parent_sets = [
+ [ [qw( blue blue blue blue )], [qw( blue blue blue blue )] => 'blue' ],
+ [ [qw( blue blue blue blue )], [qw( brown brown green blue )] => 'brown' ],
+ [ [qw( blue blue green green )], [qw( blue blue green green )] => 'green' ],
+];
+
+foreach my $set (@$parent_sets) {
+ my $expected_color = pop( @$set );
+ my $mother = Human->new(
+ gender => 'f',
+ eye_color => shift(@$set),
+ );
+ my $father = Human->new(
+ gender => 'm',
+ eye_color => shift(@$set),
+ );
+ my $child = $mother + $father;
+ is(
+ $child->eye_color(),
+ $expected_color,
+ 'mother '.$mother->eye_color().' + father '.$father->eye_color().' = child '.$expected_color,
+ );
+}
+
+# Hmm, not sure how to test for random selection of genes since
+# I could theoretically run an infinite number of iterations and
+# never find proof that a child has inherited a particular gene.
+
+# AUTHOR: Aran Clary Deltac <bluefeet@cpan.org>
+
projects / gitmo/Moose.git / commitdiff