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