t/000_recipes/basics-recipe10.t

   1 #!/usr/bin/perl
   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;
   5
   6 use strict;
   7 use warnings;
   8
   9 use Test::More;
  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
  49     use List::MoreUtils qw( zip );
  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
 224 done_testing;