t/000_recipes/basics/010_genes.t

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