3 # This test is taken from Moose :)
8 use Test::More tests => 10;
15 use Mouse::Util::TypeConstraints;
19 => where { $_ =~ m{^[mf]$}s };
21 has 'gender' => ( is => 'ro', isa => 'Gender', required => 1 );
23 has 'mother' => ( is => 'ro', isa => 'Human' );
24 has 'father' => ( is => 'ro', isa => 'Human' );
26 use overload '+' => \&_overload_add, fallback => 1;
29 my ( $one, $two ) = @_;
31 die('Only male and female humans may create children')
32 if ( $one->gender() eq $two->gender() );
34 my ( $mother, $father )
35 = ( $one->gender eq 'f' ? ( $one, $two ) : ( $two, $one ) );
38 $gender = 'm' if ( rand() >= 0.5 );
42 eye_color => ( $one->eye_color() + $two->eye_color() ),
48 # use List::MoreUtils 'zip'
49 # code taken from List::MoreUtils
50 sub zip (\@\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@) {
52 $max < $#$_ && ( $max = $#$_ ) for @_;
54 map { my $ix = $_; map $_->[$ix], @_; } 0 .. $max;
58 coerce 'Human::EyeColor'
60 => via { my @genes = qw( bey2_1 bey2_2 gey_1 gey_2 );
61 return Human::EyeColor->new( zip( @genes, @{$_} ) ); };
65 isa => 'Human::EyeColor',
73 package Human::Gene::bey2;
76 use Mouse::Util::TypeConstraints;
78 type 'bey2_color' => where { $_ =~ m{^(?:brown|blue)$} };
80 has 'color' => ( is => 'ro', isa => 'bey2_color' );
84 package Human::Gene::gey;
87 use Mouse::Util::TypeConstraints;
89 type 'gey_color' => where { $_ =~ m{^(?:green|blue)$} };
91 has 'color' => ( is => 'ro', isa => 'gey_color' );
95 package Human::EyeColor;
98 use Mouse::Util::TypeConstraints;
100 coerce 'Human::Gene::bey2'
102 => via { Human::Gene::bey2->new( color => $_ ) };
104 coerce 'Human::Gene::gey'
106 => via { Human::Gene::gey->new( color => $_ ) };
108 has [qw( bey2_1 bey2_2 )] =>
109 ( is => 'ro', isa => 'Human::Gene::bey2', coerce => 1 );
111 has [qw( gey_1 gey_2 )] =>
112 ( is => 'ro', isa => 'Human::Gene::gey', coerce => 1 );
118 if ( $self->bey2_1->color() eq 'brown'
119 or $self->bey2_2->color() eq 'brown' );
122 if ( $self->gey_1->color() eq 'green'
123 or $self->gey_2->color() eq 'green' );
128 use overload '""' => \&color, fallback => 1;
130 use overload '+' => \&_overload_add, fallback => 1;
133 my ( $one, $two ) = @_;
135 my $one_bey2 = 'bey2_' . _rand2();
136 my $two_bey2 = 'bey2_' . _rand2();
138 my $one_gey = 'gey_' . _rand2();
139 my $two_gey = 'gey_' . _rand2();
141 return Human::EyeColor->new(
142 bey2_1 => $one->$one_bey2->color(),
143 bey2_2 => $two->$two_bey2->color(),
144 gey_1 => $one->$one_gey->color(),
145 gey_2 => $two->$two_gey->color(),
150 return 1 + int( rand(2) );
154 my $gene_color_sets = [
155 [ qw( blue blue blue blue ) => 'blue' ],
156 [ qw( blue blue green blue ) => 'green' ],
157 [ qw( blue blue blue green ) => 'green' ],
158 [ qw( blue blue green green ) => 'green' ],
159 [ qw( brown blue blue blue ) => 'brown' ],
160 [ qw( brown brown green green ) => 'brown' ],
161 [ qw( blue brown green blue ) => 'brown' ],
164 foreach my $set (@$gene_color_sets) {
165 my $expected_color = pop(@$set);
167 my $person = Human->new(
173 $person->eye_color(),
185 [qw( blue blue blue blue )],
186 [qw( blue blue blue blue )] => 'blue'
189 [qw( blue blue blue blue )],
190 [qw( brown brown green blue )] => 'brown'
193 [qw( blue blue green green )],
194 [qw( blue blue green green )] => 'green'
198 foreach my $set (@$parent_sets) {
199 my $expected_color = pop(@$set);
201 my $mother = Human->new(
203 eye_color => shift(@$set),
206 my $father = Human->new(
208 eye_color => shift(@$set),
211 my $child = $mother + $father;
217 . $mother->eye_color()
219 . $father->eye_color()
225 # Hmm, not sure how to test for random selection of genes since
226 # I could theoretically run an infinite number of iterations and
227 # never find proof that a child has inherited a particular gene.
229 # AUTHOR: Aran Clary Deltac <bluefeet@cpan.org>