trAvis - MANAGER

Edit File: basics-recipe10.t

#!/usr/bin/perl

# This test is taken from Moose :)

use strict;
use warnings;

use Test::More tests => 10;

{
    package Human;

use Mouse;
    use Mouse::Util::TypeConstraints;

subtype 'Gender'
        => as 'Str'
        => where { $_ =~ m{^[mf]$}s };

has 'gender' => ( is => 'ro', isa => 'Gender', required => 1 );

has 'mother' => ( is => 'ro', isa => 'Human' );
    has 'father' => ( is => 'ro', isa => 'Human' );

use overload '+' => \&_overload_add, fallback => 1;

sub _overload_add {
        my ( $one, $two ) = @_;

die('Only male and female humans may create children')
            if ( $one->gender() eq $two->gender() );

my ( $mother, $father )
            = ( $one->gender eq 'f' ? ( $one, $two ) : ( $two, $one ) );

my $gender = 'f';
        $gender = 'm' if ( rand() >= 0.5 );

return Human->new(
            gender    => $gender,
            eye_color => ( $one->eye_color() + $two->eye_color() ),
            mother    => $mother,
            father    => $father,
        );
    }

# use List::MoreUtils 'zip'
    # code taken from List::MoreUtils
    sub zip (\@\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@) {
        my $max = -1;
        $max < $#$_ && ( $max = $#$_ ) for @_;

map { my $ix = $_; map $_->[$ix], @_; } 0 .. $max;
    }

coerce 'Human::EyeColor'
        => from 'ArrayRef'
        => via { my @genes = qw( bey2_1 bey2_2 gey_1 gey_2 );
                 return Human::EyeColor->new( zip( @genes, @{$_} ) ); };

has 'eye_color' => (
        is       => 'ro',
        isa      => 'Human::EyeColor',
        coerce   => 1,
        required => 1,
    );

}

{
    package Human::Gene::bey2;

use Mouse;
    use Mouse::Util::TypeConstraints;

type 'bey2_color' => where { $_ =~ m{^(?:brown|blue)$} };

has 'color' => ( is => 'ro', isa => 'bey2_color' );
}

{
    package Human::Gene::gey;

use Mouse;
    use Mouse::Util::TypeConstraints;

type 'gey_color' => where { $_ =~ m{^(?:green|blue)$} };

has 'color' => ( is => 'ro', isa => 'gey_color' );
}

{
    package Human::EyeColor;

use Mouse;
    use Mouse::Util::TypeConstraints;

coerce 'Human::Gene::bey2'
        => from 'Str'
            => via { Human::Gene::bey2->new( color => $_ ) };

coerce 'Human::Gene::gey'
        => from 'Str'
            => via { Human::Gene::gey->new( color => $_ ) };

has [qw( bey2_1 bey2_2 )] =>
        ( is => 'ro', isa => 'Human::Gene::bey2', coerce => 1 );

has [qw( gey_1 gey_2 )] =>
        ( is => 'ro', isa => 'Human::Gene::gey', coerce => 1 );

sub color {
        my ($self) = @_;

return 'brown'
            if ( $self->bey2_1->color() eq 'brown'
            or $self->bey2_2->color() eq 'brown' );

return 'green'
            if ( $self->gey_1->color() eq 'green'
            or $self->gey_2->color() eq 'green' );

return 'blue';
    }

use overload '""' => \&color, fallback => 1;

use overload '+' => \&_overload_add, fallback => 1;

sub _overload_add {
        my ( $one, $two ) = @_;

my $one_bey2 = 'bey2_' . _rand2();
        my $two_bey2 = 'bey2_' . _rand2();

my $one_gey = 'gey_' . _rand2();
        my $two_gey = 'gey_' . _rand2();

return Human::EyeColor->new(
            bey2_1 => $one->$one_bey2->color(),
            bey2_2 => $two->$two_bey2->color(),
            gey_1  => $one->$one_gey->color(),
            gey_2  => $two->$two_gey->color(),
        );
    }

sub _rand2 {
        return 1 + int( rand(2) );
    }
}

my $gene_color_sets = [
    [ qw( blue blue blue blue )     => 'blue' ],
    [ qw( blue blue green blue )    => 'green' ],
    [ qw( blue blue blue green )    => 'green' ],
    [ qw( blue blue green green )   => 'green' ],
    [ qw( brown blue blue blue )    => 'brown' ],
    [ qw( brown brown green green ) => 'brown' ],
    [ qw( blue brown green blue )   => 'brown' ],
];

foreach my $set (@$gene_color_sets) {
    my $expected_color = pop(@$set);

my $person = Human->new(
        gender    => 'f',
        eye_color => $set,
    );

is(
        $person->eye_color(),
        $expected_color,
        'gene combination '
            . join( ',', @$set )
            . ' produces '
            . $expected_color
            . ' eye color',
    );
}

my $parent_sets = [
    [
        [qw( blue blue blue blue )],
        [qw( blue blue blue blue )] => 'blue'
    ],
    [
        [qw( blue blue blue blue )],
        [qw( brown brown green blue )] => 'brown'
    ],
    [
        [qw( blue blue green green )],
        [qw( blue blue green green )] => 'green'
    ],
];

foreach my $set (@$parent_sets) {
    my $expected_color = pop(@$set);

my $mother         = Human->new(
        gender    => 'f',
        eye_color => shift(@$set),
    );

my $father = Human->new(
        gender    => 'm',
        eye_color => shift(@$set),
    );

my $child = $mother + $father;

is(
        $child->eye_color(),
        $expected_color,
        'mother '
            . $mother->eye_color()
            . ' + father '
            . $father->eye_color()
            . ' = child '
            . $expected_color,
    );
}

# Hmm, not sure how to test for random selection of genes since
# I could theoretically run an infinite number of iterations and
# never find proof that a child has inherited a particular gene.

# AUTHOR: Aran Clary Deltac <bluefeet@cpan.org>