Commit | Line | Data |
c2a0627f |
1 | #!/usr/bin/perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
a28e50e4 |
6 | use Test::More; |
055dbe8c |
7 | |
8 | |
c2a0627f |
9 | { |
10 | package Human; |
11 | |
12 | use Moose; |
13 | use Moose::Util::TypeConstraints; |
14 | |
c2a0627f |
15 | subtype 'Gender' |
16 | => as 'Str' |
17 | => where { $_ =~ m{^[mf]$}s }; |
18 | |
19 | has 'gender' => ( is => 'ro', isa => 'Gender', required => 1 ); |
20 | |
c2a0627f |
21 | has 'mother' => ( is => 'ro', isa => 'Human' ); |
22 | has 'father' => ( is => 'ro', isa => 'Human' ); |
23 | |
24 | use overload '+' => \&_overload_add, fallback => 1; |
25 | |
26 | sub _overload_add { |
055dbe8c |
27 | my ( $one, $two ) = @_; |
c2a0627f |
28 | |
055dbe8c |
29 | die('Only male and female humans may create children') |
30 | if ( $one->gender() eq $two->gender() ); |
c2a0627f |
31 | |
055dbe8c |
32 | my ( $mother, $father ) |
33 | = ( $one->gender eq 'f' ? ( $one, $two ) : ( $two, $one ) ); |
c2a0627f |
34 | |
35 | my $gender = 'f'; |
055dbe8c |
36 | $gender = 'm' if ( rand() >= 0.5 ); |
c2a0627f |
37 | |
38 | return Human->new( |
055dbe8c |
39 | gender => $gender, |
c2a0627f |
40 | eye_color => ( $one->eye_color() + $two->eye_color() ), |
055dbe8c |
41 | mother => $mother, |
42 | father => $father, |
c2a0627f |
43 | ); |
44 | } |
055dbe8c |
45 | |
46 | use List::MoreUtils qw( zip ); |
47 | |
48 | coerce 'Human::EyeColor' |
49 | => from 'ArrayRef' |
50 | => via { my @genes = qw( bey2_1 bey2_2 gey_1 gey_2 ); |
51 | return Human::EyeColor->new( zip( @genes, @{$_} ) ); }; |
52 | |
53 | has 'eye_color' => ( |
54 | is => 'ro', |
55 | isa => 'Human::EyeColor', |
56 | coerce => 1, |
57 | required => 1, |
58 | ); |
59 | |
c2a0627f |
60 | } |
61 | |
62 | { |
055dbe8c |
63 | package Human::Gene::bey2; |
64 | |
65 | use Moose; |
66 | use Moose::Util::TypeConstraints; |
67 | |
68 | type 'bey2_color' => where { $_ =~ m{^(?:brown|blue)$} }; |
69 | |
70 | has 'color' => ( is => 'ro', isa => 'bey2_color' ); |
71 | } |
72 | |
73 | { |
74 | package Human::Gene::gey; |
c2a0627f |
75 | |
76 | use Moose; |
77 | use Moose::Util::TypeConstraints; |
78 | |
055dbe8c |
79 | type 'gey_color' => where { $_ =~ m{^(?:green|blue)$} }; |
80 | |
81 | has 'color' => ( is => 'ro', isa => 'gey_color' ); |
82 | } |
c2a0627f |
83 | |
055dbe8c |
84 | { |
85 | package Human::EyeColor; |
86 | |
87 | use Moose; |
88 | use Moose::Util::TypeConstraints; |
89 | |
90 | coerce 'Human::Gene::bey2' |
c2a0627f |
91 | => from 'Str' |
92 | => via { Human::Gene::bey2->new( color => $_ ) }; |
93 | |
055dbe8c |
94 | coerce 'Human::Gene::gey' |
c2a0627f |
95 | => from 'Str' |
96 | => via { Human::Gene::gey->new( color => $_ ) }; |
97 | |
055dbe8c |
98 | has [qw( bey2_1 bey2_2 )] => |
99 | ( is => 'ro', isa => 'Human::Gene::bey2', coerce => 1 ); |
c2a0627f |
100 | |
055dbe8c |
101 | has [qw( gey_1 gey_2 )] => |
102 | ( is => 'ro', isa => 'Human::Gene::gey', coerce => 1 ); |
c2a0627f |
103 | |
104 | sub color { |
055dbe8c |
105 | my ($self) = @_; |
106 | |
107 | return 'brown' |
108 | if ( $self->bey2_1->color() eq 'brown' |
109 | or $self->bey2_2->color() eq 'brown' ); |
110 | |
111 | return 'green' |
112 | if ( $self->gey_1->color() eq 'green' |
113 | or $self->gey_2->color() eq 'green' ); |
c2a0627f |
114 | |
c2a0627f |
115 | return 'blue'; |
116 | } |
117 | |
055dbe8c |
118 | use overload '""' => \&color, fallback => 1; |
119 | |
120 | use overload '+' => \&_overload_add, fallback => 1; |
121 | |
c2a0627f |
122 | sub _overload_add { |
055dbe8c |
123 | my ( $one, $two ) = @_; |
c2a0627f |
124 | |
125 | my $one_bey2 = 'bey2_' . _rand2(); |
126 | my $two_bey2 = 'bey2_' . _rand2(); |
127 | |
128 | my $one_gey = 'gey_' . _rand2(); |
129 | my $two_gey = 'gey_' . _rand2(); |
130 | |
131 | return Human::EyeColor->new( |
132 | bey2_1 => $one->$one_bey2->color(), |
133 | bey2_2 => $two->$two_bey2->color(), |
134 | gey_1 => $one->$one_gey->color(), |
135 | gey_2 => $two->$two_gey->color(), |
136 | ); |
137 | } |
138 | |
139 | sub _rand2 { |
c2a0627f |
140 | return 1 + int( rand(2) ); |
141 | } |
142 | } |
143 | |
c2a0627f |
144 | my $gene_color_sets = [ |
055dbe8c |
145 | [ qw( blue blue blue blue ) => 'blue' ], |
146 | [ qw( blue blue green blue ) => 'green' ], |
147 | [ qw( blue blue blue green ) => 'green' ], |
148 | [ qw( blue blue green green ) => 'green' ], |
149 | [ qw( brown blue blue blue ) => 'brown' ], |
150 | [ qw( brown brown green green ) => 'brown' ], |
151 | [ qw( blue brown green blue ) => 'brown' ], |
c2a0627f |
152 | ]; |
153 | |
154 | foreach my $set (@$gene_color_sets) { |
055dbe8c |
155 | my $expected_color = pop(@$set); |
156 | |
c2a0627f |
157 | my $person = Human->new( |
055dbe8c |
158 | gender => 'f', |
c2a0627f |
159 | eye_color => $set, |
160 | ); |
055dbe8c |
161 | |
c2a0627f |
162 | is( |
163 | $person->eye_color(), |
164 | $expected_color, |
055dbe8c |
165 | 'gene combination ' |
166 | . join( ',', @$set ) |
167 | . ' produces ' |
168 | . $expected_color |
169 | . ' eye color', |
c2a0627f |
170 | ); |
171 | } |
172 | |
173 | my $parent_sets = [ |
055dbe8c |
174 | [ |
175 | [qw( blue blue blue blue )], |
176 | [qw( blue blue blue blue )] => 'blue' |
177 | ], |
178 | [ |
179 | [qw( blue blue blue blue )], |
180 | [qw( brown brown green blue )] => 'brown' |
181 | ], |
182 | [ |
183 | [qw( blue blue green green )], |
184 | [qw( blue blue green green )] => 'green' |
185 | ], |
c2a0627f |
186 | ]; |
187 | |
188 | foreach my $set (@$parent_sets) { |
055dbe8c |
189 | my $expected_color = pop(@$set); |
190 | |
191 | my $mother = Human->new( |
192 | gender => 'f', |
c2a0627f |
193 | eye_color => shift(@$set), |
194 | ); |
055dbe8c |
195 | |
c2a0627f |
196 | my $father = Human->new( |
055dbe8c |
197 | gender => 'm', |
c2a0627f |
198 | eye_color => shift(@$set), |
199 | ); |
055dbe8c |
200 | |
c2a0627f |
201 | my $child = $mother + $father; |
055dbe8c |
202 | |
c2a0627f |
203 | is( |
204 | $child->eye_color(), |
205 | $expected_color, |
055dbe8c |
206 | 'mother ' |
207 | . $mother->eye_color() |
208 | . ' + father ' |
209 | . $father->eye_color() |
210 | . ' = child ' |
211 | . $expected_color, |
c2a0627f |
212 | ); |
213 | } |
214 | |
215 | # Hmm, not sure how to test for random selection of genes since |
216 | # I could theoretically run an infinite number of iterations and |
217 | # never find proof that a child has inherited a particular gene. |
218 | |
219 | # AUTHOR: Aran Clary Deltac <bluefeet@cpan.org> |
220 | |
a28e50e4 |
221 | done_testing; |