From: Aran Clary Deltac Date: Mon, 28 Jul 2008 22:47:37 +0000 (+0000) Subject: New cookbook recipe # 12. X-Git-Tag: 0_55~33 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c2a0627f6674f57f46fb0a943587de69dd29889f;p=gitmo%2FMoose.git New cookbook recipe # 12. --- diff --git a/Changes b/Changes index 0d8b305..2996f0a 100644 --- a/Changes +++ b/Changes @@ -1,7 +1,6 @@ Revision history for Perl extension Moose 0.55 - * Moose::Meta::Attribute - breaking down the way 'handles' methods are created so that the process can be more easily @@ -12,6 +11,10 @@ Revision history for Perl extension Moose the type constraints (RT #37569) - added tests for this (Charles Alderman) + * Moose::Cookbook::Recipe12 + - A new recipe that shows off operator overloading + in combination with Moose. (bluefeet) + 0.54 Thurs. July 3, 2008 ... this is not my day today ... diff --git a/lib/Moose/Cookbook.pod b/lib/Moose/Cookbook.pod index 7ea1cb2..2c8c167 100644 --- a/lib/Moose/Cookbook.pod +++ b/lib/Moose/Cookbook.pod @@ -66,6 +66,12 @@ Work off of this http://code2.0beta.co.uk/moose/svn/Moose/trunk/t/200_examples/0 The builder feature provides an inheritable and role-composable way to provide a default attribute value. +=item L - Create Humans and their Spawn + +Shows how operator overloading, coercion, and sub types can be used +to mimmick the human reproductive system (well, the selection of genes +at least). Assumes a basic understanding of Moose. + =back =head2 Moose Roles diff --git a/lib/Moose/Cookbook/Recipe12.pod b/lib/Moose/Cookbook/Recipe12.pod new file mode 100644 index 0000000..7913e77 --- /dev/null +++ b/lib/Moose/Cookbook/Recipe12.pod @@ -0,0 +1,309 @@ + +=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. 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. + +=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. + +=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 + +=head1 LICENSE + +This work is licensed under a Creative Commons Attribution 3.0 Unported License. + +License details are at: L + +=cut + diff --git a/t/000_recipes/012_genes.t b/t/000_recipes/012_genes.t new file mode 100644 index 0000000..e777cce --- /dev/null +++ b/t/000_recipes/012_genes.t @@ -0,0 +1,202 @@ +#!/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 +