#!/usr/bin/perl
use strict;
use warnings;

package SNP;

sub new {
    my ($class, %params) = @_;

    die "id parameter required by $class constructor\n" if !exists $params{id};

    $params{genes} ||= {};

    return bless \%params, $class;
}


sub addGene {
    my ($self, $geneId, %params) = @_;

    $self->{genes}{$geneId} ||= Gene->new(id => $geneId, %params);
    return $self->{genes}{$geneId};
}


sub match {
    my ($self, $other) = @_;
    my @otherGenes = sort keys %{$other->{genes}};
    my @genes      = sort keys %{$self->{genes}};
    my $result     = '';

    return "$self->{id} and $other->{id} differ in number of genes.\n"
        if @otherGenes != @genes;    # different number of transcripts

    # Check all genes match
    for my $gene (@genes) {
        my $matchFail = $self->{genes}{$gene}->match($other->{genes}{$gene});

        next if !$matchFail;
        $result .= "- Gene mismatch for $gene:\n";
        $result .= $matchFail;
    }

    if ($result) {
        $result = "$self->{id} does not match $other->{id}:\n" . $result;
    }

    return $result;
}


package Gene;

sub new {
    my ($class, %params) = @_;

    die "id parameter required by $class constructor\n" if !exists $params{id};

    $params{trans} ||= {};
    return bless \%params, $class;
}


sub addTranscript {
    my ($self, $transId, %params) = @_;

    $self->{trans}{$transId} ||= Transcript->new(id => $transId, %params);
    return $self->{trans}{$transId};
}


sub match {
    my ($self, $other) = @_;
    my @otherTrans = sort keys %{$other->{trans}};
    my @trans      = sort keys %{$self->{trans}};
    my $result     = '';

    return "$self->{id} and $other->{id} differ in number of transactions\n"
        if @otherTrans != @trans;    # different number of transcripts

    # Check all transcripts match
    for my $transName (@trans) {
        my $matchFail =
            $self->{trans}{$transName}->match($other->{trans}{$transName});

        next if !$matchFail;
        $result .= "-- Transcript mismatch for $transName:\n";
        $result .= $matchFail;
    }

    return $result;
}


package Transcript;

sub new {
    my ($class, %params) = @_;

    die "id parameter required by $class constructor\n" if !exists $params{id};

    $params{props} ||= {};
    return bless \%params, $class;
}


sub setProp {
    my ($self, $prop, $value) = @_;

    $self->{props}{$prop} = $value;
}


sub match {
    my ($self, $other) = @_;
    my @otherProps = sort keys %{$other->{props}};
    my @props      = sort keys %{$self->{props}};
    my $result     = '';

    return if @otherProps != @props;    # different number of properties

    # Check all properties match
    for my $propName (@props) {
        if (!defined $other->{props}{$propName}) {
            $result .= "$self->{id} has $propName but $other->{id} doesn't\n";
            next;
        }

        if ($self->{props}{$propName} ne $other->{props}{$propName}) {
            $result .=
                "--- $self->{id} and $other->{id} property $propName differs:\n";
            $result .=
                "    '$self->{props}{$propName}' and '$other->{props}{$propName}'\n";
            next;
        }
    }

    return $result;
}


package main;

my $snp1  = SNP->new(id => 'SNP1');
my $gene  = $snp1->addGene('Gene1');
my $trans = $gene->addTranscript('Trans1');

$trans->setProp(big   => 1);
$trans->setProp(color => 'blue');
$gene  = $snp1->addGene('Gene2');
$trans = $gene->addTranscript('Trans2');
$trans->setProp(big   => 1);
$trans->setProp(color => 'green');

my $snp2 = SNP->new(id => 'SNP2');
$gene  = $snp2->addGene('Gene1');
$trans = $gene->addTranscript('Trans1');

$trans->setProp(big   => 1);
$trans->setProp(color => 'blue');
$gene  = $snp2->addGene('Gene2');
$trans = $gene->addTranscript('Trans2');
$trans->setProp(big   => 1);
$trans->setProp(color => 'blue');

print $snp1->match($snp2);

##</code><code>##

SNP1 does not match SNP2:
- Gene mismatch for Gene2:
-- Transcript mismatch for Trans2:
--- Trans2 and Trans2 property color differs:
    'green' and 'blue'