10 use Moose::Util::TypeConstraints;
14 => where { $_->isa('Human::EyeColor') };
19 return Human::EyeColor->new(
29 => where { $_ =~ m{^[mf]$}s };
31 has 'gender' => ( is => 'ro', isa => 'Gender', required => 1 );
33 has 'eye_color' => ( is => 'ro', isa => 'EyeColor', coerce => 1, required => 1 );
35 has 'mother' => ( is => 'ro', isa => 'Human' );
36 has 'father' => ( is => 'ro', isa => 'Human' );
38 use overload '+' => \&_overload_add, fallback => 1;
43 die('Only male and female humans may have children')
44 if ($one->gender() eq $two->gender());
46 my ( $mother, $father ) = ( $one->gender eq 'f' ? ($one, $two) : ($two, $one) );
49 $gender = 'm' if (rand() >= 0.5);
51 # Would be better to use Crypt::Random.
52 #use Crypt::Random qw( makerandom );
53 #$gender = 'm' if (makerandom( Size => 1, Strength => 1, Uniform => 1 ));
57 eye_color => ( $one->eye_color() + $two->eye_color() ),
65 package Human::EyeColor;
68 use Moose::Util::TypeConstraints;
72 => where { $_->isa('Human::Gene::bey2') };
76 => via { Human::Gene::bey2->new( color => $_ ) };
80 => where { $_->isa('Human::Gene::gey') };
84 => via { Human::Gene::gey->new( color => $_ ) };
86 has 'bey2_1' => ( is => 'ro', isa => 'bey2Gene', coerce => 1 );
87 has 'bey2_2' => ( is => 'ro', isa => 'bey2Gene', coerce => 1 );
89 has 'gey_1' => ( is => 'ro', isa => 'geyGene', coerce => 1 );
90 has 'gey_2' => ( is => 'ro', isa => 'geyGene', coerce => 1 );
92 use overload '+' => \&_overload_add, fallback => 1;
93 use overload '""' => \&color, fallback => 1;
98 return 'brown' if ($self->bey2_1->color() eq 'brown' or $self->bey2_2->color() eq 'brown');
99 return 'green' if ($self->gey_1->color() eq 'green' or $self->gey_2->color() eq 'green');
104 my ($one, $two) = @_;
106 my $one_bey2 = 'bey2_' . _rand2();
107 my $two_bey2 = 'bey2_' . _rand2();
109 my $one_gey = 'gey_' . _rand2();
110 my $two_gey = 'gey_' . _rand2();
112 return Human::EyeColor->new(
113 bey2_1 => $one->$one_bey2->color(),
114 bey2_2 => $two->$two_bey2->color(),
115 gey_1 => $one->$one_gey->color(),
116 gey_2 => $two->$two_gey->color(),
121 # Would be better to use Crypt::Random.
122 #use Crypt::Random qw( makerandom );
123 #return 1 + makerandom( Size => 1, Strength => 1, Uniform => 1 );
124 return 1 + int( rand(2) );
129 package Human::Gene::bey2;
132 use Moose::Util::TypeConstraints;
134 type 'bey2Color' => where { $_ =~ m{^(?:brown|blue)$}s };
136 has 'color' => ( is => 'ro', isa => 'bey2Color' );
140 package Human::Gene::gey;
143 use Moose::Util::TypeConstraints;
145 type 'geyColor' => where { $_ =~ m{^(?:green|blue)$}s };
147 has 'color' => ( is => 'ro', isa => 'geyColor' );
150 use Test::More tests => 10;
152 my $gene_color_sets = [
153 [qw( blue blue blue blue ) => 'blue'],
154 [qw( blue blue green blue ) => 'green'],
155 [qw( blue blue blue green ) => 'green'],
156 [qw( blue blue green green ) => 'green'],
157 [qw( brown blue blue blue ) => 'brown'],
158 [qw( brown brown green green ) => 'brown'],
159 [qw( blue brown green blue ) => 'brown'],
162 foreach my $set (@$gene_color_sets) {
163 my $expected_color = pop( @$set );
164 my $person = Human->new(
169 $person->eye_color(),
171 'gene combination '.join(',',@$set).' produces '.$expected_color.' eye color',
176 [ [qw( blue blue blue blue )], [qw( blue blue blue blue )] => 'blue' ],
177 [ [qw( blue blue blue blue )], [qw( brown brown green blue )] => 'brown' ],
178 [ [qw( blue blue green green )], [qw( blue blue green green )] => 'green' ],
181 foreach my $set (@$parent_sets) {
182 my $expected_color = pop( @$set );
183 my $mother = Human->new(
185 eye_color => shift(@$set),
187 my $father = Human->new(
189 eye_color => shift(@$set),
191 my $child = $mother + $father;
195 'mother '.$mother->eye_color().' + father '.$father->eye_color().' = child '.$expected_color,
199 # Hmm, not sure how to test for random selection of genes since
200 # I could theoretically run an infinite number of iterations and
201 # never find proof that a child has inherited a particular gene.
203 # AUTHOR: Aran Clary Deltac <bluefeet@cpan.org>