#!/usr/bin/perl
use strict;
use warnings;
use Parse::RecDescent;
use Data::Dumper;
#
#
# exercise 4.1 from "Programming Language Pragmatics"
#
#  Basic results from automata theory tell us that the language 
#  L = a**n b**n c**n = ('', 'aabbcc' , 'aaabbbccc' , ...) 
#  is not context free. It can be captured, however, using
#  an attribute grammar. Give an underlying CFG (Context Free Grammar) 
#  and a set of attribute rules that
#  associates a Boolean attribute ok with the root R of each parse tree, 
#  such that R.ok = true if and only if the string corresponding to 
#  the fringe of the tree is in L.
#
#
#  Answer : 
#     start : As Bs Cs       { start.ok      := (As.val == Bs.val == Cs.val) }
#     As:   : a As           { As.val_left   := As.val_right + 1 
#             | ''           { As.val        := 0 }
#     Bs:   : b Bs           { Bs.val_left   := Bs.val_right + 1 
#             | ''           { Bs.val        := 0 }
#     Cs:   : c Cs           { Cs.val_left   := Cs.val_right + 1 
#             | ''           { Cs.val        := 0 }
#
#  I expect that this can be done entirely within Parse::RecDescent
#  (ParseRecDescent does allow code fragments quite like what I have above)
#  And that might be in fact interesting because it'd show if the 
#  the attributes on the right are available before they're needed.
#  Since Parse::RecDescent is recursive descent, and therefore
#  goes depth first left-to-right, I think that'd work in one pass.
#
#  I'm sure this is S-attributed. (Attribute rules for things on 
#  the left depend only on things on the right, i.e. their direct
#  children, so bottom-up works.)  Turns out its also L-attributed
#  (top-down left-to-right has what's needed in order)
#  which is I believe what Parse::RecDescent needs to do it in one pass.
#  See abc_2.pl for a Parse::RecDescent for that version.
#
#  But here I'm doing something conceptually simpler, I think,
#  though it does require more code.
#  First I'm using Parse::RecDesent's <autotree> feature
#  to generate a parse tree, and then once its in hand
#  I'm explicitly applying an attribute grammar at each node
#  using a depth-first tree walking algorithm.
#
#  So this is a "two pass" approach.
#
#  On the first pass, strings like 'aabc' are accepted by the parser.
#  On the second pass, the attribute grammar would assign
#  'aabc' a start.ok=0, while 'aabbcc' would have start.ok=1.
#

my $grammar = q{	
		  <autotree>
		  start:    As Bs Cs
		  As:       'a' As   | ''
		  Bs:       'b' Bs   | ''
		  Cs:	    'c' Cs   | ''
		};

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

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";
  print " " . tree_to_text($tree) if $tree;

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

  if ($tree){
    print " Decorating tree.\n";
    decorate_node($tree);
    print " root->{ok} = '" . $tree->{ok} . "'\n";
  }

  if ($text eq 'aabc'){
    print " --- full tree after decoration --- \n";
    print Dumper($tree);
    print " ------------------------------------------ \n";
  }

  print "\n";
}

# ==== attribute decoration ================================


# Apply the attribute grammar.
# At the bottom terminal nodes, __VALUE__ should be set to '' for this grammar.
# At any other node, __RULE__ should be set to the left hand side of the rule
# that generated this node.
sub decorate_node {
  my $node = shift;
  # If we're at a terminal node, set the attributes for the a,b,c counts.
  if (defined $node->{__VALUE__} and $node->{__VALUE__} eq ''){
    $node->{a_count} = 0;
    $node->{b_count} = 0;
    $node->{c_count} = 0;
  }
  # Otherwise, 
  else {
    # (1) Fill in the attributes of the nodes below us, and
    for my $subnode_name qw(As Bs Cs){
      if (defined $node->{$subnode_name}){
	decorate_node( $node->{$subnode_name} );
      }
    }
    # (2) Apply one of the following attribute grammar rules
    #     to calculate the attributes for this node given the ones below it.
    if ($node->{__RULE__} eq 'As'){
      $node->{a_count} = 1 + $node->{As}{a_count} 
    }
    if ($node->{__RULE__} eq 'Bs'){
      $node->{b_count} = 1 + $node->{Bs}{b_count} 
    }
    if ($node->{__RULE__} eq 'Cs'){
      $node->{c_count} = 1 + $node->{Cs}{c_count} 
    }
    if ($node->{__RULE__} eq 'start'){
      $node->{ok} = ($node->{As}{a_count} == $node->{Bs}{b_count}
		     and
		     $node->{Bs}{b_count} == $node->{Cs}{c_count});
    }
  }
}

# == 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;
}

