package Person;

sub create {

    my $class = shift;
    my $me    = shift;  # name of new being

    # should do some validation here

    return bless { me => $me } => $class;

    }

use constant ANON => Person->create('unknown');  # some folks have no antecedents

sub bears {

    my $mom = shift;  # mother instance (matrilineal clone)
    my $me  = shift;  # kid's name
    my $dad = shift;  # father instance

    # should do some validation here

    return bless { me => $me,  mom => $mom,  dad => $dad } => ref $mom;

    }

sub ident {

    my $self = shift;

    return $self->{me};

    }

sub mom {

    my $self = shift;

    return exists $self->{mom} ? $self->{mom} : ANON;

    }

sub dad {

    my $self = shift;

    return exists $self->{dad} ? $self->{dad} : ANON;

    }


my $adam = Person->create('Adam');  # these folks are without antecedents
my $eve  = Person->create('Eve' );

my $able = $eve->bears(Able => $adam);
my $mary = $eve->bears(Mary => $adam);
my $jane = $eve->bears(Jane => $adam);

print "first guy: @{[ $adam->ident ]} \n";
print "first guy's mom: @{[ $adam->mom->ident ]} \n";

print "Jane's mom: @{[ $jane->mom->ident ]} \n";
print "Jane's dad: @{[ $jane->dad->ident ]} \n";

my $fred = $mary->bears(Fred => $able);
my $jill = $jane->bears(Jill => $able);

print "Fred's dad: @{[ $fred->dad->ident ]} \n";
print "Fred's mom: @{[ $fred->mom->ident ]} \n";
print "Fred's dad's dad: @{[ $fred->dad->dad->ident ]} \n";
print "Fred's dad's mom: @{[ $fred->dad->mom->ident ]} \n";
print "Fred's mom's dad: @{[ $fred->mom->dad->ident ]} \n";
print "Fred's dad's dad's dad: @{[ $fred->dad->dad->dad->ident ]} \n";
print "Fred's dad's dad's dad's dad: @{[ $fred->dad->dad->dad->dad->ident ]} \n";
print "Fred's dad's dad's dad's dad's dad: @{[ $fred->dad->dad->dad->dad->dad->ident ]} \n";
print "Fred's dad's dad's mom's dad's dad's dad: @{[ $fred->dad->dad->mom->dad->dad->dad->ident ]} \n";

my $alan = $jill->bears(Alan => $adam);

print "Alan's dad: @{[ $alan->dad->ident ]} \n";
print "Alan's dad's dad: @{[ $alan->dad->dad->ident ]} \n";
print "Alan's mom: @{[ $alan->mom->ident ]} \n";
print "Alan's mom's dad: @{[ $alan->mom->dad->ident ]} \n";
print "Alan's mom's mom: @{[ $alan->mom->mom->ident ]} \n";
print "Alan's mom's mom's mom: @{[ $alan->mom->mom->mom->ident ]} \n";