t/002_recipes/basics_recipe10.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More;
   7
   8
   9 {
  10     package Human;
  11
  12     use Moose;
  13     use Moose::Util::TypeConstraints;
  14
  15     subtype 'Gender'
  16         => as 'Str'
  17         => where { $_ =~ m{^[mf]$}s };
  18
  19     has 'gender' => ( is => 'ro', isa => 'Gender', required => 1 );
  20
  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 {
  27         my ( $one, $two ) = @_;
  28
  29         die('Only male and female humans may create children')
  30             if ( $one->gender() eq $two->gender() );
  31
  32         my ( $mother, $father )
  33             = ( $one->gender eq 'f' ? ( $one, $two ) : ( $two, $one ) );
  34
  35         my $gender = 'f';
  36         $gender = 'm' if ( rand() >= 0.5 );
  37
  38         return Human->new(
  39             gender    => $gender,
  40             eye_color => ( $one->eye_color() + $two->eye_color() ),
  41             mother    => $mother,
  42             father    => $father,
  43         );
  44     }
  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
  60 }
  61
  62 {
  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;
  75
  76     use Moose;
  77     use Moose::Util::TypeConstraints;
  78
  79     type 'gey_color' => where { $_ =~ m{^(?:green|blue)$} };
  80
  81     has 'color' => ( is => 'ro', isa => 'gey_color' );
  82 }
  83
  84 {
  85     package Human::EyeColor;
  86
  87     use Moose;
  88     use Moose::Util::TypeConstraints;
  89
  90     coerce 'Human::Gene::bey2'
  91         => from 'Str'
  92             => via { Human::Gene::bey2->new( color => $_ ) };
  93
  94     coerce 'Human::Gene::gey'
  95         => from 'Str'
  96             => via { Human::Gene::gey->new( color => $_ ) };
  97
  98     has [qw( bey2_1 bey2_2 )] =>
  99         ( is => 'ro', isa => 'Human::Gene::bey2', coerce => 1 );
 100
 101     has [qw( gey_1 gey_2 )] =>
 102         ( is => 'ro', isa => 'Human::Gene::gey', coerce => 1 );
 103
 104     sub color {
 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' );
 114
 115         return 'blue';
 116     }
 117
 118     use overload '""' => \&color, fallback => 1;
 119
 120     use overload '+' => \&_overload_add, fallback => 1;
 121
 122     sub _overload_add {
 123         my ( $one, $two ) = @_;
 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 {
 140         return 1 + int( rand(2) );
 141     }
 142 }
 143
 144 my $gene_color_sets = [
 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' ],
 152 ];
 153
 154 foreach my $set (@$gene_color_sets) {
 155     my $expected_color = pop(@$set);
 156
 157     my $person = Human->new(
 158         gender    => 'f',
 159         eye_color => $set,
 160     );
 161
 162     is(
 163         $person->eye_color(),
 164         $expected_color,
 165         'gene combination '
 166             . join( ',', @$set )
 167             . ' produces '
 168             . $expected_color
 169             . ' eye color',
 170     );
 171 }
 172
 173 my $parent_sets = [
 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     ],
 186 ];
 187
 188 foreach my $set (@$parent_sets) {
 189     my $expected_color = pop(@$set);
 190
 191     my $mother         = Human->new(
 192         gender    => 'f',
 193         eye_color => shift(@$set),
 194     );
 195
 196     my $father = Human->new(
 197         gender    => 'm',
 198         eye_color => shift(@$set),
 199     );
 200
 201     my $child = $mother + $father;
 202
 203     is(
 204         $child->eye_color(),
 205         $expected_color,
 206         'mother '
 207             . $mother->eye_color()
 208             . ' + father '
 209             . $father->eye_color()
 210             . ' = child '
 211             . $expected_color,
 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
 221 done_testing;