t/000-recipes/basics-recipe10.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 10;
   7
   8
   9 {
  10     package Human;
  11
  12     use Mouse;
  13     use Mouse::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 'zip'
  47     # code taken from List::MoreUtils
  48     sub zip (\@\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@) {
  49         my $max = -1;
  50         $max < $#$_ && ( $max = $#$_ ) for @_;
  51
  52         map { my $ix = $_; map $_->[$ix], @_; } 0 .. $max;
  53     }
  54
  55
  56     coerce 'Human::EyeColor'
  57         => from 'ArrayRef'
  58         => via { my @genes = qw( bey2_1 bey2_2 gey_1 gey_2 );
  59                  return Human::EyeColor->new( zip( @genes, @{$_} ) ); };
  60
  61     has 'eye_color' => (
  62         is       => 'ro',
  63         isa      => 'Human::EyeColor',
  64         coerce   => 1,
  65         required => 1,
  66     );
  67
  68 }
  69
  70 {
  71     package Human::Gene::bey2;
  72
  73     use Mouse;
  74     use Mouse::Util::TypeConstraints;
  75
  76     type 'bey2_color' => where { $_ =~ m{^(?:brown|blue)$} };
  77
  78     has 'color' => ( is => 'ro', isa => 'bey2_color' );
  79 }
  80
  81 {
  82     package Human::Gene::gey;
  83
  84     use Mouse;
  85     use Mouse::Util::TypeConstraints;
  86
  87     type 'gey_color' => where { $_ =~ m{^(?:green|blue)$} };
  88
  89     has 'color' => ( is => 'ro', isa => 'gey_color' );
  90 }
  91
  92 {
  93     package Human::EyeColor;
  94
  95     use Mouse;
  96     use Mouse::Util::TypeConstraints;
  97
  98     coerce 'Human::Gene::bey2'
  99         => from 'Str'
 100             => via { Human::Gene::bey2->new( color => $_ ) };
 101
 102     coerce 'Human::Gene::gey'
 103         => from 'Str'
 104             => via { Human::Gene::gey->new( color => $_ ) };
 105
 106     has [qw( bey2_1 bey2_2 )] =>
 107         ( is => 'ro', isa => 'Human::Gene::bey2', coerce => 1 );
 108
 109     has [qw( gey_1 gey_2 )] =>
 110         ( is => 'ro', isa => 'Human::Gene::gey', coerce => 1 );
 111
 112     sub color {
 113         my ($self) = @_;
 114
 115         return 'brown'
 116             if ( $self->bey2_1->color() eq 'brown'
 117             or $self->bey2_2->color() eq 'brown' );
 118
 119         return 'green'
 120             if ( $self->gey_1->color() eq 'green'
 121             or $self->gey_2->color() eq 'green' );
 122
 123         return 'blue';
 124     }
 125
 126     use overload '""' => \&color, fallback => 1;
 127
 128     use overload '+' => \&_overload_add, fallback => 1;
 129
 130     sub _overload_add {
 131         my ( $one, $two ) = @_;
 132
 133         my $one_bey2 = 'bey2_' . _rand2();
 134         my $two_bey2 = 'bey2_' . _rand2();
 135
 136         my $one_gey = 'gey_' . _rand2();
 137         my $two_gey = 'gey_' . _rand2();
 138
 139         return Human::EyeColor->new(
 140             bey2_1 => $one->$one_bey2->color(),
 141             bey2_2 => $two->$two_bey2->color(),
 142             gey_1  => $one->$one_gey->color(),
 143             gey_2  => $two->$two_gey->color(),
 144         );
 145     }
 146
 147     sub _rand2 {
 148         return 1 + int( rand(2) );
 149     }
 150 }
 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
 165     my $person = Human->new(
 166         gender    => 'f',
 167         eye_color => $set,
 168     );
 169
 170     is(
 171         $person->eye_color(),
 172         $expected_color,
 173         'gene combination '
 174             . join( ',', @$set )
 175             . ' produces '
 176             . $expected_color
 177             . ' eye color',
 178     );
 179 }
 180
 181 my $parent_sets = [
 182     [
 183         [qw( blue blue blue blue )],
 184         [qw( blue blue blue blue )] => 'blue'
 185     ],
 186     [
 187         [qw( blue blue blue blue )],
 188         [qw( brown brown green blue )] => 'brown'
 189     ],
 190     [
 191         [qw( blue blue green green )],
 192         [qw( blue blue green green )] => 'green'
 193     ],
 194 ];
 195
 196 foreach my $set (@$parent_sets) {
 197     my $expected_color = pop(@$set);
 198
 199     my $mother         = Human->new(
 200         gender    => 'f',
 201         eye_color => shift(@$set),
 202     );
 203
 204     my $father = Human->new(
 205         gender    => 'm',
 206         eye_color => shift(@$set),
 207     );
 208
 209     my $child = $mother + $father;
 210
 211     is(
 212         $child->eye_color(),
 213         $expected_color,
 214         'mother '
 215             . $mother->eye_color()
 216             . ' + father '
 217             . $father->eye_color()
 218             . ' = child '
 219             . $expected_color,
 220     );
 221 }
 222
 223 # Hmm, not sure how to test for random selection of genes since
 224 # I could theoretically run an infinite number of iterations and
 225 # never find proof that a child has inherited a particular gene.
 226
 227 # AUTHOR: Aran Clary Deltac <bluefeet@cpan.org>
 228