#!/usr/bin/perl
use strict;
use warnings;
use Parse::RecDescent;
use Data::Dumper;
#
#
# exercise 4.1 from "Programming Language Pragmatics"
#
#  see abc.pl for the description.
#
# This second version tries to do the whole thing in one pass,
# by constructing a tree explicitly with the required attributes,
# instead of using <autotree>
#
# The trick here is the %item hash generated by Parse::RecDescent,
# which has for each production matched, has keys for each
# of the subrules on the right-hand as well as others like __RULE__
# for the name of the rule on the left, __STRINGn__ for the n'th string,
# and various others.  Since each rule match triggers more matches, 
# this generates a recursive tree structure automatically.
#
# Besides the attribute grammar rules,
# I've added an 'order' hash key (what the texbook calls 'attributes')
# that should show the order in which the nodes of the tree were created.
#

my $grammar = q{ 
                    { my $order = 0; my $node;  }

 start: As Bs Cs    { $node=\%item; $node->{order}=$order++;
		      $node->{ok} = ($node->{As}{val}==$node->{Bs}{val} and 
                                     $node->{Bs}{val}==$node->{Cs}{val});
		      $return = $node; }

 As:    'a' As      { $node=\%item; $node->{order}=$order++;
		      $node->{val} = $node->{As}{val}+1;
		      $return = $node; }

      | ''	    { $node={val=>0}, $node->{order}=$order++;
		      $return = $node; }

 Bs:    'b' Bs      { $node=\%item; $node->{order}=$order++;
		      $node->{val} = $node->{Bs}{val}+1;
		      $return = $node; }

      | ''	    { $node={val=>0}, $node->{order}=$order++;
		      $return = $node; }

 Cs:    'c' Cs      { $node=\%item; $node->{order}=$order++;
		      $node->{val} = $node->{Cs}{val}+1;
		      $return = $node; }

      | ''	    { $node={val=>0}, $node->{order}=$order++;
		      $return = $node; }
		};

my @text = ( '',
	     'cab',
	     'abc',
	     'aabc',
	   );

$::RD_HINT = 1; # turn on diagnostic errors.
my $parser = new Parse::RecDescent ($grammar) or die "Bad grammar!\n"; 
for my $text (@text){
  my ($message, $tree) = parse($text);
  print "parsing '$text' gives '$message'. \n";
  if ($tree){
    print " " . tree_to_text($tree);
    print " " . "root->{ok} = '" . $tree->{ok} . "'\n";
  }

  if ($text eq 'aabc'){
    use Data::Dumper;
    print " --- full tree as created by <autotree> --- \n";
    print Dumper($tree);
    print " ------------------------------------------ \n";
  }

  print "\n";
}

# == utiltity routines ================================================

# -- To see the whole thing returned by <autotree> :
# use Data::Dumper;
# print Dumper($tree);

sub parse {	
  my $text = shift;
  my $root = $parser->start(\$text);
  return ("Bad text", 0)    unless defined $root;  # Parse failed.
  return ("Extra text", 0)  if $text;              # Didn't consume all text.
  return ("Success", $root);
}
my $indent_width;
sub tree_to_text {
  my $root = shift;
  $indent_width ||= 3;
  return $root->{__RULE__} . " => " . node_to_text($root, $indent_width);
}
sub node_to_text {
  my ($node, $indent) = @_;
  my $result = '';
  if (ref $node){
    if (exists($node->{__VALUE__})){
      return "{ '' }\n";
    }
    $result .= "{\n";
    for my $key (keys %$node){          # alter sort ordering
      if ($key =~ /^__/){
	(my $akey = $key) =~ s/__/  /;
	$node->{$akey} = $node->{$key};
	delete $node->{$key};
      }
    }
    for my $key (sort keys %$node){
      next if $key =~ /ACTION|RULE/;
      if ($key =~ /STRING|VALUE/){
	$result .= " " x $indent . " '" . $node->{$key} . "'\n";
      }
      else {
	$result .= " " x $indent . " $key => "
	           . node_to_text($node->{$key}, $indent + $indent_width);
      }
    }
    for my $key (keys %$node){         # undo alteration
      if ($key =~ /^  /){
	(my $akey = $key) =~ s/  /__/;
	$node->{$akey} = $node->{$key};
	delete $node->{$key};
      }
    }
    $result .= " " x $indent . " }\n";
  }
  else {
    $result .= "'$node'\n";
  }
  return $result;
}

