t/000-recipes/basics-recipe10.t

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