#!/usr/bin/perl
use warnings;
use strict;
use Marpa::R2;
use Tree::Simple;

package Construct;


sub doMap {
    my @params = @_;
    my $child = 'ARRAY' eq ref $params[3] ? $params[3][1] : $params[3];

    return $params[1]->addChild($child) if $child->getNodeValue() ne 'root';

    my @children = $child->getAllChildren();
    return $params[1]->addChildren(@children);
}


sub doMapSib {
    my @params = @_;
    my ($lhs, $rhs) = map {'ARRAY' eq ref $_ ? $_->[1] : $_} @params[1, 3];
    my $root;

    if ($lhs->getNodeValue() eq 'root') {
        $root = $lhs;
        $lhs  = undef;
    } elsif ($rhs->getNodeValue() eq 'root') {
        $root = $rhs;
        $rhs  = undef;
    } else {
        $root = Tree::Simple->new('root');
    }

    $root->addChild($lhs) if $lhs;
    $root->addChild($rhs) if $rhs;
    return $root;
}


my $tail = '';

sub doTail {
    my @params = @_;

    $tail = $params[1];
    return;
}


sub doCode {
    my @params = @_;
    my $node   = Tree::Simple->new("$params[1]$tail");

    $tail = '';
    return $node;
}


package main;

my $syntax = <<'SYNTAX';
lexeme default = latm => 1

network ::= ident ';' subnet action => doMap
    | subnet action => ::first
 
subnet ::= sibling ',' subnet action => doMapSib
    | sibling action => ::first

sibling ::= '(' network ')' action => [values]
    | ident action => ::first

ident ::= letter tail action => doCode
    | letter action => doCode

tail ::= digits action => doTail

letter ~ [A-Z]+
digits ~ [\d]+
:discard ~ spaces
spaces ~ [\s]+
SYNTAX

my $grammar = Marpa::R2::Scanless::G->new({source => \$syntax});
my $input   = 'R;(S1;(H1,H2,H4,H5)),(S2;H3)';
my $tree    = ${$grammar->parse(\$input, 'Construct')};
my $root    = Tree::Simple->new('root')->addChild($tree);
my $depth   = $root->getHeight();

($root)->traverse(
    sub {
        print "  " x ($depth - $_[0]->getHeight()), $_[0]->getNodeValue(), "\n";
    }
);