The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use Test::More;
BEGIN {
    eval { require XML::Twig };
    if ($@) {
        plan 'skip_all' => 'XML::Twig not installed';
    }
    else {
        Test::More->import('no_plan');
    }
}
use strict;
use Bio::Phylo::IO 'parse';

# TEST PARSING OF TAXON SETS

my $sets1;
{
$sets1 = <<'SETS1';
<nex:nexml 
    version="0.9"
    xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
    generator="handmade"
    xmlns:nex="http://www.nexml.org/2009"
    xmlns="http://www.nexml.org/2009"
    xmlns:xsd="http://www.w3.org/2001/XMLSchema#"
    xsi:schemaLocation="http://www.nexml.org/2009 ../xsd/nexml.xsd">
    <otus id="taxa1">        
        <otu id="t1"/>
        <otu id="t2"/>
        <otu id="t3"/>
        <otu id="t4"/>
        <otu id="t5"/>
        <set otu="t1 t2" id="set1"/>
    </otus>
</nex:nexml>
SETS1
}


{
    my $proj1 = parse(
        '-format' => 'nexml',
        '-string' => $sets1,
        '-as_project' => 1,
    );
    
    for my $taxa ( @{ $proj1->get_taxa } ) {
        my ($set) = @{ $taxa->get_sets };
        ok($set);
        $taxa->visit( sub {
            my $taxon = shift;
            my $name = $taxon->get_xml_id;
            if ( $name eq 't1' or $name eq 't2' ) {
                ok( $taxa->is_in_set($taxon,$set) );
            }
            else {
                ok( ! $taxa->is_in_set($taxon,$set) );
            }
        });
    }
    
    # TEST SERIALIZE TAXON SETS
    
    my %ids1;
    my $xml1 = $proj1->to_xml;
    XML::Twig->new(
        'twig_handlers' => {
            'set' => sub {
                my ( $twig, $elt ) = @_;
                %ids1 = map { $_ => 1 } grep { /\S/ } split /\s+/, $elt->att('otu');
            }
        }
    )->parse($xml1);
    my @ids1 = keys %ids1;
    # ok(exists $ids1{'t1'}); # we no longer try to round-trip ids in projects
    # ok(exists $ids1{'t2'});
    ok(scalar(@ids1)==2);
}

# TEST PARSING OF TREE SETS

my $sets2;
{
$sets2 = <<'SETS2';
<?xml version="1.0" encoding="UTF-8"?>
<nex:nexml 
    version="0.9"
    xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
    generator="handmade"
    xmlns:nex="http://www.nexml.org/2009"
    xmlns="http://www.nexml.org/2009"
    xmlns:xsd="http://www.w3.org/2001/XMLSchema#"
    xsi:schemaLocation="http://www.nexml.org/2009 ../xsd/nexml.xsd">
    <otus 
        id="taxa1">        
        <otu id="t1"/>
        <otu id="t2"/>
        <otu id="t3"/>
        <otu id="t4"/>
        <otu id="t5"/>
    </otus>
    <trees otus="taxa1" id="trees1">       
        <tree xsi:type="nex:IntTree" id="tree1">            
            <node id="n1"/>
            <node id="n2"/>
            <node id="n3"/>
            <rootedge target="n1" id="root"/>
            <edge source="n1" target="n2" id="e1"/>
            <edge source="n1" target="n3" id="e2"/> 
        </tree>
        <set tree="tree1" id="set3"/>        
    </trees>
</nex:nexml>
SETS2
}


{
    my $proj2 = parse(
        '-format' => 'nexml',
        '-string' => $sets2,
        '-as_project' => 1,
    );
    
    for my $forest ( @{ $proj2->get_forests } ) {
        my ($set) = @{ $forest->get_sets };
        ok($set);
        $forest->visit( sub {
            my $tree = shift;
            my $name = $tree->get_xml_id;
            if ( $name eq 'tree1' ) {
                ok( $forest->is_in_set($tree,$set) );
            }
        });
    }
    
    # TEST SERIALIZE TREE SETS
    
    my %ids2;
    my $xml2 = $proj2->to_xml;
    XML::Twig->new(
        'twig_handlers' => {
            'set' => sub {
                my ( $twig, $elt ) = @_;
                %ids2 = map { $_ => 1 } grep { /\S/ } split /\s+/, $elt->att('tree');
            }
        }
    )->parse($xml2);
    my @ids2 = keys %ids2;
    # ok(exists $ids2{'tree1'}); # we no longer try to roundtrip ids in projects
    ok(scalar(@ids2)==1);
}

# TEST PARSING OF NODE SETS
my $sets3;
{
$sets3 = <<'SETS3';
<?xml version="1.0" encoding="UTF-8"?>
<nex:nexml 
    version="0.9"
    xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
    generator="handmade"
    xmlns:nex="http://www.nexml.org/2009"
    xmlns="http://www.nexml.org/2009"
    xmlns:xsd="http://www.w3.org/2001/XMLSchema#"
    xsi:schemaLocation="http://www.nexml.org/2009 ../xsd/nexml.xsd">
    <otus 
        id="taxa1">        
        <otu id="t1"/>
        <otu id="t2"/>
        <otu id="t3"/>
        <otu id="t4"/>
        <otu id="t5"/>
    </otus>
    <trees otus="taxa1" id="trees1">       
        <tree xsi:type="nex:IntTree" id="tree1">            
            <node id="n1"/>
            <node id="n2"/>
            <node id="n3"/>
            <rootedge target="n1" id="root"/>
            <edge source="n1" target="n2" id="e1"/>
            <edge source="n1" target="n3" id="e2"/>
            <set node="n1 n2" id="set3"/>        
        </tree>        
    </trees>
</nex:nexml>
SETS3
}


{
    my $proj3 = parse(
        '-format' => 'nexml',
        '-string' => $sets3,
        '-as_project' => 1,
    );
    
    for my $forest ( @{ $proj3->get_forests } ) {
        for my $tree ( @{ $forest->get_entities } ) {
            my ($set) = @{ $tree->get_sets };
            ok($set);
            $tree->visit(sub {
                my $node = shift;
                my $name = $node->get_xml_id;
                if ( $name eq 'n1' or $name eq 'n2' ) {
                    ok($tree->is_in_set($node,$set));
                }
                else {
                    ok(! $tree->is_in_set($node,$set));
                }
            });
        }
    }

    # TEST SERIALIZE NODE SETS

    my %ids3;
    my $xml3 = $proj3->to_xml;
    XML::Twig->new(
        'twig_handlers' => {
            'set' => sub {
                my ( $twig, $elt ) = @_;
                %ids3 = map { $_ => 1 } grep { /\S/ } split /\s+/, $elt->att('node');
            }
        }
    )->parse($xml3);
    my @ids3 = keys %ids3;
    # ok(exists $ids3{'n1'}); # we no longer try to roundtrip ids in projects
    # ok(exists $ids3{'n2'});
    ok(scalar(@ids3)==2);
}

# TEST PARSE CHARACTER SETS

my $sets4;
{
$sets4 = <<'SETS4';
<nex:nexml 
    version="0.9" 
    xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
    xsi:schemaLocation="http://www.nexml.org/2009 ../xsd/nexml.xsd"
    xmlns:nex="http://www.nexml.org/2009"
    xmlns="http://www.nexml.org/2009">
    <otus id="taxa1" label="Primary taxa block">
        <otu id="t1" label="Homo sapiens"/>
        <otu id="t2" label="Pan paniscus"/>
        <otu id="t3" label="Pan troglodytes"/>
        <otu id="t4" label="Gorilla gorilla"/>
        <otu id="t5" label="Pongo pygmaeus"/>
    </otus>
    <characters otus="taxa1" id="m3" xsi:type="nex:ContinuousCells" label="Continuous characters">        
        <format>
            <char id="ContinuousCharacter1"/>
            <char id="ContinuousCharacter2"/>
            <char id="ContinuousCharacter3"/>
            <char id="ContinuousCharacter4"/>
            <char id="ContinuousCharacter5"/>
            <set id="set1" char="ContinuousCharacter1 ContinuousCharacter2"/>
        </format>
        <matrix>
            <row id="ContinuousCellsRow1" otu="t1">
                <cell char="ContinuousCharacter1" state="-1.545414144070023"/>
                <cell char="ContinuousCharacter2" state="-2.3905621575431044"/>
                <cell char="ContinuousCharacter3" state="-2.9610221833467265"/>
                <cell char="ContinuousCharacter4" state="0.7868662069161243"/>
                <cell char="ContinuousCharacter5" state="0.22968509237534918"/>
            </row>
            <row id="ContinuousCellsRow2" otu="t2">
                <cell char="ContinuousCharacter1" state="-1.6259836379710066"/>
                <cell char="ContinuousCharacter2" state="3.649352410850134"/>
                <cell char="ContinuousCharacter3" state="1.778885099660406"/>
                <cell char="ContinuousCharacter4" state="-1.2580877968480846"/>
                <cell char="ContinuousCharacter5" state="0.22335354995610862"/>
            </row>
            <row id="ContinuousCellsRow3" otu="t3">
                <cell char="ContinuousCharacter1" state="-1.5798979984134964"/>
                <cell char="ContinuousCharacter2" state="2.9548251411133157"/>
                <cell char="ContinuousCharacter3" state="1.522005675256233"/>
                <cell char="ContinuousCharacter4" state="-0.8642016921755289"/>
                <cell char="ContinuousCharacter5" state="-0.938129801832388"/>
            </row>
            <row id="ContinuousCellsRow4" otu="t4">
                <cell char="ContinuousCharacter1" state="2.7436692306788086"/>
                <cell char="ContinuousCharacter2" state="-0.7151148143399818"/>
                <cell char="ContinuousCharacter3" state="4.592207937774776"/>
                <cell char="ContinuousCharacter4" state="-0.6898841440534845"/>
                <cell char="ContinuousCharacter5" state="0.5769509574453064"/>
            </row>
            <row id="ContinuousCellsRow5" otu="t5">
                <cell char="ContinuousCharacter1" state="3.1060827493657683"/>
                <cell char="ContinuousCharacter2" state="-1.0453787389160105"/>
                <cell char="ContinuousCharacter3" state="2.67416332763427"/>
                <cell char="ContinuousCharacter4" state="-1.4045634106692808"/>
                <cell char="ContinuousCharacter5" state="0.019890469925520196"/>
            </row>
        </matrix>
    </characters>
</nex:nexml>
SETS4
}

{
    my $proj4 = parse(
        '-format' => 'nexml',
        '-string' => $sets4,
        '-as_project' => 1,
    );
    
    for my $matrix ( @{ $proj4->get_matrices } ) {
        my $characters = $matrix->get_characters;
        my ($set) = @{ $characters->get_sets };
        for my $char ( @{ $characters->get_entities } ) {
            my $name = $char->get_xml_id;
            if ( $name =~ m/(?:1|2)$/ ) {
                ok($characters->is_in_set($char,$set));
            }
            else {
                ok(! $characters->is_in_set($char,$set));
            }
        }
    }

    # TEST SERIALIZE CHARACTER SETS

    my %ids4;
    my $xml4 = $proj4->to_xml;
    XML::Twig->new(
        'twig_handlers' => {
            'set' => sub {
                my ( $twig, $elt ) = @_;
                %ids4 = map { $_ => 1 } grep { /\S/ } split /\s+/, $elt->att('char');
            }
        }
    )->parse($xml4);
    my @ids4 = keys %ids4;
    ok(exists $ids4{'ContinuousCharacter1'});
    ok(exists $ids4{'ContinuousCharacter2'});
    ok(scalar(@ids4)==2);
}