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