Commit | Line | Data |
c2a0627f |
1 | #!/usr/bin/perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
6 | { |
7 | package Human; |
8 | |
9 | use Moose; |
10 | use Moose::Util::TypeConstraints; |
11 | |
c2a0627f |
12 | subtype 'EyeColor' |
13 | => as 'Object' |
14 | => where { $_->isa('Human::EyeColor') }; |
15 | |
16 | coerce 'EyeColor' |
17 | => from 'ArrayRef' |
18 | => via { |
c4314d9d |
19 | return Human::EyeColor->new( |
20 | bey2_1 => $_->[0], |
21 | bey2_2 => $_->[1], |
22 | gey_1 => $_->[2], |
23 | gey_2 => $_->[3], |
24 | ); |
c2a0627f |
25 | }; |
26 | |
27 | subtype 'Gender' |
28 | => as 'Str' |
29 | => where { $_ =~ m{^[mf]$}s }; |
30 | |
31 | has 'gender' => ( is => 'ro', isa => 'Gender', required => 1 ); |
32 | |
33 | has 'eye_color' => ( is => 'ro', isa => 'EyeColor', coerce => 1, required => 1 ); |
34 | |
35 | has 'mother' => ( is => 'ro', isa => 'Human' ); |
36 | has 'father' => ( is => 'ro', isa => 'Human' ); |
37 | |
38 | use overload '+' => \&_overload_add, fallback => 1; |
39 | |
40 | sub _overload_add { |
41 | my ($one, $two) = @_; |
42 | |
43 | die('Only male and female humans may have children') |
44 | if ($one->gender() eq $two->gender()); |
45 | |
46 | my ( $mother, $father ) = ( $one->gender eq 'f' ? ($one, $two) : ($two, $one) ); |
47 | |
48 | my $gender = 'f'; |
49 | $gender = 'm' if (rand() >= 0.5); |
50 | |
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 )); |
54 | |
55 | return Human->new( |
56 | gender => $gender, |
57 | eye_color => ( $one->eye_color() + $two->eye_color() ), |
58 | mother => $mother, |
59 | father => $father, |
60 | ); |
61 | } |
62 | } |
63 | |
64 | { |
65 | package Human::EyeColor; |
66 | |
67 | use Moose; |
68 | use Moose::Util::TypeConstraints; |
69 | |
70 | subtype 'bey2Gene' |
71 | => as 'Object' |
72 | => where { $_->isa('Human::Gene::bey2') }; |
73 | |
74 | coerce 'bey2Gene' |
75 | => from 'Str' |
76 | => via { Human::Gene::bey2->new( color => $_ ) }; |
77 | |
78 | subtype 'geyGene' |
79 | => as 'Object' |
80 | => where { $_->isa('Human::Gene::gey') }; |
81 | |
82 | coerce 'geyGene' |
83 | => from 'Str' |
84 | => via { Human::Gene::gey->new( color => $_ ) }; |
85 | |
86 | has 'bey2_1' => ( is => 'ro', isa => 'bey2Gene', coerce => 1 ); |
87 | has 'bey2_2' => ( is => 'ro', isa => 'bey2Gene', coerce => 1 ); |
88 | |
89 | has 'gey_1' => ( is => 'ro', isa => 'geyGene', coerce => 1 ); |
90 | has 'gey_2' => ( is => 'ro', isa => 'geyGene', coerce => 1 ); |
91 | |
92 | use overload '+' => \&_overload_add, fallback => 1; |
93 | use overload '""' => \&color, fallback => 1; |
94 | |
95 | sub color { |
96 | my ( $self ) = @_; |
97 | |
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'); |
100 | return 'blue'; |
101 | } |
102 | |
103 | sub _overload_add { |
104 | my ($one, $two) = @_; |
105 | |
106 | my $one_bey2 = 'bey2_' . _rand2(); |
107 | my $two_bey2 = 'bey2_' . _rand2(); |
108 | |
109 | my $one_gey = 'gey_' . _rand2(); |
110 | my $two_gey = 'gey_' . _rand2(); |
111 | |
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(), |
117 | ); |
118 | } |
119 | |
120 | sub _rand2 { |
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) ); |
125 | } |
126 | } |
127 | |
128 | { |
129 | package Human::Gene::bey2; |
130 | |
131 | use Moose; |
132 | use Moose::Util::TypeConstraints; |
133 | |
134 | type 'bey2Color' => where { $_ =~ m{^(?:brown|blue)$}s }; |
135 | |
136 | has 'color' => ( is => 'ro', isa => 'bey2Color' ); |
137 | } |
138 | |
139 | { |
140 | package Human::Gene::gey; |
141 | |
142 | use Moose; |
143 | use Moose::Util::TypeConstraints; |
144 | |
145 | type 'geyColor' => where { $_ =~ m{^(?:green|blue)$}s }; |
146 | |
147 | has 'color' => ( is => 'ro', isa => 'geyColor' ); |
148 | } |
149 | |
150 | use Test::More tests => 10; |
151 | |
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'], |
160 | ]; |
161 | |
162 | foreach my $set (@$gene_color_sets) { |
163 | my $expected_color = pop( @$set ); |
164 | my $person = Human->new( |
165 | gender => 'f', |
166 | eye_color => $set, |
167 | ); |
168 | is( |
169 | $person->eye_color(), |
170 | $expected_color, |
171 | 'gene combination '.join(',',@$set).' produces '.$expected_color.' eye color', |
172 | ); |
173 | } |
174 | |
175 | my $parent_sets = [ |
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' ], |
179 | ]; |
180 | |
181 | foreach my $set (@$parent_sets) { |
182 | my $expected_color = pop( @$set ); |
183 | my $mother = Human->new( |
184 | gender => 'f', |
185 | eye_color => shift(@$set), |
186 | ); |
187 | my $father = Human->new( |
188 | gender => 'm', |
189 | eye_color => shift(@$set), |
190 | ); |
191 | my $child = $mother + $father; |
192 | is( |
193 | $child->eye_color(), |
194 | $expected_color, |
195 | 'mother '.$mother->eye_color().' + father '.$father->eye_color().' = child '.$expected_color, |
196 | ); |
197 | } |
198 | |
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. |
202 | |
203 | # AUTHOR: Aran Clary Deltac <bluefeet@cpan.org> |
204 | |