File Coverage

blib/lib/Parse/Stallion.pm

Criterion	Covered	Total	%
statement	1058	1137	93.0
branch	447	520	85.9
condition	272	348	78.1
subroutine	66	77	85.7
pod	12	59	20.3
total	1855	2141	86.6

#Copyright 2007-10 Arthur S Goldstein

package Parse::Stallion::Talon;
use Carp;
use strict;
use warnings;
use 5.006;

sub stringify {
  my $self = shift;
  my $parameters = shift;
  my $values = $parameters->{values} || ['steps','name','parse_match'];
  my $spaces = $parameters->{spaces} || '';
  my $value_separator = '|';
  if (defined $parameters->{value_separator}) {
    $value_separator = $parameters->{value_separator};
  }
  my $line = $spaces;

  foreach my $value (@$values) {
    if (defined $self->{$value}) {
      $line .= $self->{$value}.$value_separator;
    }
    else {
      $line .= $value_separator;
    }
  }

  $line .= "\n";
  foreach my $child (@{$self->{children}}) {
    $parameters->{spaces} = $spaces.' ';
    $line .= stringify($child,$parameters);
  }

  return $line;
}

package Parse::Stallion::Parser;
use Carp;
use strict;
use warnings;

sub new {
  my $type = shift;
  my $class = ref($type) || $type;
  my $parameters = shift;
  my $parsing_info = {parse_stallion => $parameters};
  return bless $parsing_info, $class;
}


sub parse_leaf {
  my $parsing_info = shift;
  my $parameters = shift;
  my $start_rule_name = shift;
  my $parse_stallion = $parsing_info->{parse_stallion};
  my $parse_hash = $parameters->{parse_hash};
  my $parse_this_ref = $parse_hash->{parse_this_ref} =
   $parameters->{parse_this_ref};
  my $parse_this_length = $parse_hash->{__parse_this_length};
  my $must_parse_length = $parse_hash->{__match_length};
  my $do_evaluation_in_parsing = $parse_stallion->{do_evaluation_in_parsing};
  my $start_node = $parse_stallion->{rule}->{$start_rule_name};
  my $initial_position = $parse_hash->{__initial_position};

  my $tree;
  my @bottom_up_left_to_right;
  my $current_position;
  my $continue_forward;
  my $match;
  my $delta_position;

  if (my $pf = $start_node->{parse_forward}) {
    $current_position = $parse_hash->{current_position} = $initial_position;
    $parse_hash->{rule_name} = $start_rule_name;
    ($continue_forward, $match, $delta_position) = &{$pf}($parse_hash);
    if (defined $delta_position) {
      if ($delta_position < 0) {
        croak ("Parse forward on $start_rule_name resulted in
         backward progress ($initial_position, $delta_position)");
      }
      else {
        $current_position += $delta_position;
      }
    }
  }
  elsif (my $x = $start_node->{regex_match}) {
    pos $$parse_this_ref = $initial_position;
    if ($$parse_this_ref =~ m/$x/cg) {
      if (defined $2) {$match = $2;}
      else {$match = $1;}
      $continue_forward = 1;
      $current_position = pos $$parse_this_ref;
    }
    else {
      $continue_forward = 0;
    }
  }
  else {
    croak ("Cannot handle leaf $start_rule_name");
  }
  if ($continue_forward) {
    $tree = {
      name => $start_rule_name,
      alias => $start_node->{alias},
      steps => 1,
      parent => undef,
      position_when_entered => $initial_position,
      __nodes_when_entered => 0,
      position_when_completed => $current_position,
      parse_match => $match,
      child_count => 0
    };
    if ($do_evaluation_in_parsing) {
      $parameters->{nodes} = [$tree];
      $parse_hash->{current_position} = $current_position;
      if ($parse_stallion->new_evaluate_tree_node($parameters)) {
        $continue_forward = 0; #rejection
      }
    }
    if (($parse_this_length != $current_position) && $must_parse_length) {
      $continue_forward = 0;
    }
  }
  my $tree_size;
  if ($continue_forward) {
    push @bottom_up_left_to_right, $tree;
    $tree_size = 1;
  }
  else {
    $tree = undef;
    $tree_size = 0;
  }

  my $results = $parameters->{parse_info};
  $results->{start_rule} = $start_rule_name;
  $results->{number_of_steps} = 1;
  $results->{final_position} = $current_position;
  $results->{final_position_rule} = $start_rule_name;
  $results->{parse_backtrack_value} = undef;
  $results->{maximum_position} = $current_position;
  $results->{maximum_position_rule} = $start_rule_name;
  $results->{parse_succeeded} = $continue_forward;
  $results->{tree} = $tree;
  $results->{tree_size} = $tree_size;
  $results->{bottom_up_left_to_right} = \@bottom_up_left_to_right;
  if ($do_evaluation_in_parsing) {
    $results->{parsing_evaluation} = $tree->{computed_value};
  }
  return $results;
}

sub parse {
  my $parsing_info = shift;
  my $parse_stallion = $parsing_info->{parse_stallion};
  my $parameters = shift;
  my $rule = $parse_stallion->{rule};
  my $start_rule;
  if (defined $parameters->{start_rule}) {
    if (!defined $rule->{$parameters->{start_rule}}) {
      croak ("Unknown start rule ".$parameters->{start_rule});
    }
    $start_rule = $parameters->{start_rule};
  }
  else {
    $start_rule = $parse_stallion->{start_rule};
  }
  if ($rule->{$start_rule}->{leaf_rule}) {
    return $parsing_info->parse_leaf($parameters, $start_rule);
  }
  my $parse_trace_routine = $parameters->{parse_trace_routine}
   || $parse_stallion->{parse_trace_routine};
  my $parse_hash = $parameters->{parse_hash};
  my $parse_this_ref = $parse_hash->{parse_this_ref} =
   $parameters->{parse_this_ref};
  my $parse_this_length = $parse_hash->{__parse_this_length};
  my $max_steps = $parameters->{max_steps} || $parse_stallion->{max_steps};
  my $no_max_steps = 0;
  if ($max_steps < 0) {
    $no_max_steps = 1;
    $max_steps = 1000000;
  }
  my $bottom_up_left_to_right;
  my $move_back_mode = 0;
  my $not_move_back_mode = 1;

  my $first_alias =
   'b'.$parse_stallion->{separator}.$parse_stallion->{separator};

  my $current_position = $parse_hash->{__initial_position};
  my $results = $parameters->{parse_info};
  my $maximum_position = $current_position;
  my $maximum_position_rule = $start_rule;

  my $must_parse_length = $parse_hash->{__match_length};
  my $any_minimize_children = $parse_stallion->{any_minimize_children};
  my $not_any_minimize_children = !$any_minimize_children;
  my $any_maximum_child = $parse_stallion->{any_maximum_child};
  my $not_any_maximum_child = !$any_maximum_child;
  my $any_minimum_child = $parse_stallion->{any_minimum_child};
  my $not_any_minimum_child = !$any_minimum_child;
  my $any_match_once = $parse_stallion->{any_match_once};
  my $any_parse_forward = $parse_stallion->{any_parse_forward};
  my $any_parse_backtrack = $parse_stallion->{any_parse_backtrack};
  my $fast_move_back = $parse_stallion->{fast_move_back};
  my $delta_tree_size = $parse_stallion->{max_nodes_before_size_must_change};
  my $do_evaluation_in_parsing = $parse_stallion->{do_evaluation_in_parsing};
  my $bottom_up;
  if ($do_evaluation_in_parsing || $parse_stallion->{no_evaluation}) {
    $bottom_up = 0;
  }
  else {
    $bottom_up = 1;
  }


  my ($tree,
      $current_node,
      $moving_forward,
      $moving_down,
      $steps,
      $message,
      $new_rule_name,
      $new_alias,
      $position_tree_size,
      $node_completed,
      $create_child,
      $move_back_to_child,
      $remove_node,
      $new_rule,
      $new_sub_rule,
      $continue_forward,
      $match,
      $previous_position,
      $current_node_name,
      $current_rule,
      $end_parse_now,
      $tree_size);

  if (defined $parse_hash->{__steps_ref}) {
    $steps = ${$parse_hash->{__steps_ref}};
  }
  else {
    $steps = 0;
  }

  my $continue_parse = $parameters->{continue_parse};
  if ($continue_parse) {
    $tree = $parse_hash->{__tree};
    $current_node = $parse_hash->{__current_node};
    $moving_forward = ${$parse_hash->{__moving_forward_ref}};
    $moving_down = ${$parse_hash->{__moving_down_ref}};
    $current_position = ${$parse_hash->{__current_position_ref}};
    $message = ${$parse_hash->{__message_ref}};
    $position_tree_size = $parse_hash->{__position_tree_size};
    $continue_forward = ${$parse_hash->{__continue_forward_ref}};
    $tree_size = ${$parse_hash->{__tree_size_ref}};
    $bottom_up_left_to_right = $parse_hash->{__bottom_up_left_to_right};
  }
  else {
    $tree = {
      name => $start_rule,
      steps => $steps,
      alias => $first_alias,
      position_when_entered => $current_position,
      __nodes_when_entered => 0,
      parent => undef,
      children => [],
      child_count => 0
    };
    bless($tree, 'Parse::Stallion::Talon');
    $parse_hash->{__tree} = $tree;

    $bottom_up_left_to_right = [];
    $current_node = $tree;
    $moving_forward = 1;
    $moving_down = 1;
    $message = 'Start of Parse';
    $continue_forward = 1;
    $tree_size = 1;
    $position_tree_size = {};
    $parse_hash->{__position_tree_size} = $position_tree_size;
  }
  $node_completed = 0;
  $create_child = 0;
  $move_back_to_child = 0;
  $remove_node = 0;
  $current_node_name = $current_node->{name};
  $current_rule = $rule->{$current_node_name};

  $parse_hash->{__current_node_ref} = \$current_node;
  $parse_hash->{__current_node} = $current_node;
  $parse_hash->{__current_node_name_ref} = \$current_node_name;
  $parse_hash->{__moving_forward_ref} = \$moving_forward;
  $parse_hash->{__moving_down_ref} = \$moving_down;
  $parse_hash->{__current_position_ref} = \$current_position;
  $parse_hash->{__message_ref} = \$message;
  $parse_hash->{__steps_ref} = \$steps;
  $parse_hash->{__continue_forward_ref} = \$continue_forward;
  $parse_hash->{__tree_size_ref} = \$tree_size;
  $parse_hash->{__current_rule_ref} = \$current_rule;
  $parse_hash->{__bottom_up} = $bottom_up;
  $parse_hash->{__bottom_up_left_to_right} = $bottom_up_left_to_right;
  $parse_hash->{__parse_trace_routine} = $parse_trace_routine;

  while (($steps < $max_steps) && $current_node) {
    while ($current_node && (++$steps <= $max_steps)) {
      if ($parse_trace_routine) {
        &{$parse_trace_routine}($parse_hash);
      }
      if ($moving_forward) {
        if ($current_rule->{or_rule}) {
          if ($moving_down) {
            $new_sub_rule = $current_rule->{subrule_list}->[0];
            $new_rule_name = $new_sub_rule->{name};
            $new_alias = $new_sub_rule->{alias};
            $current_node->{or_child_number} = 0;
            $create_child = 1;
          }
          else {
            $node_completed = 1;
          }
        }
        elsif ($current_rule->{and_rule}) {
          if ($current_node->{child_count} ==
           $current_rule->{subrule_list_count}) {
            $node_completed = 1;
          }
          else {
            $new_sub_rule = $current_rule->{subrule_list}->[
             $current_node->{child_count}];
            $new_rule_name = $new_sub_rule->{name};
            $new_alias = $new_sub_rule->{alias};
            $create_child = 1;
          }
        }
        elsif ($any_minimize_children && $current_rule->{minimize_children} &&
         ($not_any_minimum_child ||
          $current_rule->{minimum_child} <= $current_node->{child_count})) {
          $node_completed = 1;
        }
        elsif ($any_maximum_child && $current_rule->{maximum_child} &&
         $current_rule->{maximum_child} == $current_node->{child_count}) {
          $node_completed = 1;
        }
        else {
          $new_rule_name = $current_rule->{sub_rule_name};
          $new_alias = $current_rule->{sub_alias};
          $create_child = 1;
        }
      }
      else { # !$moving_forward
        if ($current_rule->{leaf_rule}) {
          $remove_node = 1;
        }
        elsif ($current_rule->{or_rule}) {
          if ($moving_down) {
            $move_back_to_child = 1;
          }
          else {
            if ($not_move_back_mode && (++$current_node->{or_child_number} <
             $current_rule->{subrule_list_count})) {
              $new_sub_rule = $current_rule->{subrule_list}->[
               $current_node->{or_child_number}];
              $new_rule_name = $new_sub_rule->{name};
              $new_alias = $new_sub_rule->{alias};
              $create_child = 1;
            }
            else {
              $remove_node = 1;
            }
          }
        }
        elsif ($current_rule->{and_rule}) {
          if ($current_node->{child_count}) {
            $move_back_to_child = 1;
          }
          else {
            $remove_node = 1;
          }
        }
        elsif
         (
          (
           (
            !$moving_down &&
            ($not_any_minimize_children || !$current_rule->{minimize_children})
           ) &&
           ($not_any_minimum_child || !$current_rule->{minimum_child} ||
           ($current_rule->{minimum_child} <= $current_node->{child_count}))
          )
           && $not_move_back_mode
          ) {
          $node_completed = 1;
        }
        elsif ($any_minimize_children && $not_move_back_mode &&
         $current_rule->{minimize_children} && $moving_down &&
         ($not_any_maximum_child || !$current_rule->{maximum_child} ||
         ($current_rule->{maximum_child} > $current_node->{child_count}))) {
          $new_rule_name = $current_rule->{sub_rule_name};
          $new_alias = $current_rule->{sub_alias};
          $create_child = 1;
        }
        elsif ($current_node->{child_count}) {
          $move_back_to_child = 1;
        }
        else {
          $remove_node = 1;
        }
        if ($move_back_to_child) {
          $move_back_to_child = 0;
          $message .= " Backtracking to child" if $parse_trace_routine;
          $moving_down = 1;
          $moving_forward = 0;
          pop @$bottom_up_left_to_right if $bottom_up;
          $current_node =
           $current_node->{children}->[$current_node->{child_count}-1];
          $current_node_name = $current_node->{name};
          $current_rule = $rule->{$current_node_name};
          if ($do_evaluation_in_parsing) {
            $parameters->{node} = $current_node;
            $parse_stallion->new_unevaluate_tree_node($parameters);
          }
          if ($any_match_once && $not_move_back_mode
           && $rule->{$current_node_name}->{match_once}) {

            if ($fast_move_back) {
              $remove_node = 1;
              $message .= ". Fast Move Back " if $parse_trace_routine;
            }
            else {
              $move_back_mode = 1;
              $not_move_back_mode = 0;
              $current_node->{__move_back_to} = 1;
              $message .= ". Move Back Mode Enabled " if $parse_trace_routine;
            }
          }
        }
      }

      if ($create_child) {
        $create_child = 0;
        $new_rule = $rule->{$new_rule_name};
        $previous_position = $current_position;
        if ($any_parse_forward && (my $pf = $new_rule->{parse_forward})) {
          my $delta_position;
          $parse_hash->{current_position} = $current_position;
          $parse_hash->{rule_name} = $new_rule_name;
          ($continue_forward, $match, $delta_position) =
           &{$pf}($parse_hash);
          if (defined $delta_position) {
            if ($delta_position < 0) {
              croak ("Parse forward on $new_rule_name resulted in
               backward progress ($previous_position, $delta_position)");
            }
            else {
              $current_position += $delta_position;
            }
          }
        }
        elsif (my $x = $new_rule->{regex_match}) {
          pos $$parse_this_ref = $current_position;
          if ($$parse_this_ref =~ m/$x/g) {
            if (defined $2) {$match = $2;}
            else {$match = $1;}
            $continue_forward = 1;
            $current_position = pos $$parse_this_ref;
            $message .= 'Leaf matched' if $parse_trace_routine;
          }
          else {
            $continue_forward = 0;
            $message .= 'Leaf not matched' if $parse_trace_routine;
          }
        }
        else {
          $match = undef;
        }

        if ($continue_forward) {
          if ($current_position > $maximum_position) {
            $maximum_position = $current_position;
            $maximum_position_rule = $new_rule_name;
          }
          if ($current_position == $previous_position) {
            if (defined $position_tree_size->{$current_position}) {
              if ($position_tree_size->{$current_position} <
               $tree_size - $delta_tree_size) {
                croak
                 ("$new_rule_name duplicated position $current_position");
              }
            }
            else {
             $position_tree_size->{$current_position} = $tree_size;
            }
          }
          my $new_node = {
            name => $new_rule_name,
            alias => $new_alias,
            steps => $steps,
            parent => $current_node,
            position_when_entered => $previous_position,
            __nodes_when_entered => $tree_size,
            parse_match => $match,
            child_count => 0
          };
          if ($new_rule->{leaf_rule}) {
            $node_completed = 1;
          }
          else {
            $moving_forward = 1;
            $moving_down = 1;
          }
          push @{$current_node->{children}}, $new_node;
          $current_node->{child_count}++;
          $current_node = $new_node;
          $tree_size++;
          $current_node_name = $new_rule_name;
          $current_rule = $rule->{$current_node_name};
          $message = "Creating child $new_rule_name on step $steps for ".
           "node created on step "
           .$current_node->{steps} if $parse_trace_routine;
        }
        else {
          $continue_forward = 1;
          $moving_forward = 0;
          $moving_down = 0;
        }
      }
      elsif ($remove_node) {
        $remove_node = 0;
        $moving_forward = 0;
        $moving_down = 0;
        $current_position = $current_node->{position_when_entered};
        if ($bottom_up) {
          my $change_in_tree =
           $tree_size - $current_node->{__nodes_when_entered};
          if ($change_in_tree > 1) {
            splice (@$bottom_up_left_to_right, 1 - $change_in_tree);
          }
        }
        $tree_size = $current_node->{__nodes_when_entered};
        if (defined $position_tree_size->{$current_position}
         && ($position_tree_size->{$current_position} == $tree_size)) {
          delete $position_tree_size->{$current_position};
        }
        $message .= " Removed node created on step ".$current_node->{steps}
         if $parse_trace_routine;
        $parse_hash->{parse_match} = $current_node->{parse_match};
        if ($move_back_mode && $current_node->{__move_back_to}) {
          $move_back_mode = 0;
          $not_move_back_mode = 1;
          $message .= ". Move Back Mode Completed"
           if $parse_trace_routine;
        }
        $current_node = $current_node->{parent};
        if (defined $current_node) {
          pop @{$current_node->{children}};
          $current_node->{child_count}--;
          if ($any_parse_backtrack && $current_rule->{parse_backtrack}) {
            $parse_hash->{current_position} = $current_position;
            $parse_hash->{rule_name} = $current_node_name;
            $end_parse_now = &{$current_rule->{parse_backtrack}}
              ($parse_hash);
            if ($end_parse_now) {
              $current_node = undef;
              $moving_forward = 0;
              last;
            }
          }
          $current_node_name = $current_node->{name};
          $current_rule = $rule->{$current_node_name};
        }
        delete $parse_hash->{parse_match};
      }

      if ($node_completed) {
        $node_completed = 0;
        my $parent = $current_node->{parent};
        if ($current_position == $current_node->{position_when_entered}
         && $parent &&
         (defined $rule->{$parent->{name}}->{minimum_child})
         && ($not_any_minimum_child || ($parent->{child_count} >
         $rule->{$parent->{name}}->{minimum_child}))
         ) {
          $message .= " Last child empty, Child of multiple cannot be empty "
           if $parse_trace_routine;
          $moving_forward = 0;
          $moving_down = 1;
        }
        else {
          my $reject;
          if ($do_evaluation_in_parsing) {
            $parameters->{nodes} = [$current_node];
            $parse_hash->{current_position} = $current_position;
            if ($parse_stallion->new_evaluate_tree_node($parameters)) {
              $moving_forward = 0;
              $moving_down = 1;
              $message .= " Node rejected" if $parse_trace_routine;
              next;
            }
          }
            push @$bottom_up_left_to_right, $current_node if $bottom_up;
            $message .= " Completed node created on step ".
             $current_node->{steps} if $parse_trace_routine;
            $moving_down = 0;
            $moving_forward = 1;
            $current_node->{position_when_completed} = $current_position;
            if ($current_node = $parent) {
              $current_node_name = $current_node->{name};
              $current_rule = $rule->{$current_node_name};
            }
        }
      }
    }
    if (!$current_node && $moving_forward && $must_parse_length &&
     ($parse_this_length != $current_position)) {
      $moving_forward = 0;
      $moving_down = 1;
      $current_node = $tree;
      $current_node_name = $current_node->{name};
      $message .= ' . At top of tree but did not parse entire object'
       if $parse_trace_routine;
      pop @$bottom_up_left_to_right if $bottom_up;
      if ($any_match_once
       && $rule->{$current_node_name}->{match_once}) {
        if ($fast_move_back) {
          $current_node = undef;
          $message .= ". Fast Move Back " if $parse_trace_routine;
        }
        else {
          $move_back_mode = 1;
          $not_move_back_mode = 0;
          $current_node->{__move_back_to} = 1;
          $message .= ". Move Back Mode Enabled " if $parse_trace_routine;
        }
      }
    }
    if ($no_max_steps && ($steps == $max_steps)) {
      $max_steps += 1000000;
    }
  }
  $results->{start_rule} = $start_rule;
  $results->{number_of_steps} = $steps;
  $results->{final_position} = $current_position;
  $results->{final_position_rule} = $current_node_name;
  $results->{parse_backtrack_value} = $end_parse_now;
  $results->{maximum_position} = $maximum_position;
  $results->{maximum_position_rule} = $maximum_position_rule;
  if (!$moving_forward && !$current_node) {
    $results->{tree} = {};
  }
  else {
    $results->{tree} = $tree;
  }
  $results->{tree_size} = $tree_size;
  $results->{bottom_up_left_to_right} = $bottom_up_left_to_right;
  if ($steps >= $max_steps) {
    croak ("Not enough steps to do parse, max set at $max_steps");
  }
  if ($moving_forward) {
    $results->{parse_succeeded} = 1;
    if ($do_evaluation_in_parsing) {
      $results->{parsing_evaluation} = $tree->{computed_value};
    }
  }
  else {
    $results->{parse_succeeded} = 0;
  }
  return $results;
}

package Parse::Stallion;
require Exporter;
our $VERSION = '2.01';
our @ISA = qw(Exporter);
our @EXPORT =
 qw(A AND O OR LEAF L MATCHED_STRING
    MATCH_MIN_FIRST MATCH_ONCE M MULTIPLE OPTIONAL
    ZERO_OR_ONE Z
    E EVALUATION U UNEVALUATION PF PARSE_FORWARD PB PARSE_BACKTRACK
    RULE_INFO R TERMINAL TOKEN
    LEAF_DISPLAY USE_STRING_MATCH LOCATION SE STRING_EVALUATION
    I IN INC INCORPORATE
   );
use strict;
use warnings;
use Carp;

sub new {
  my $type = shift;
  my $class = ref($type) || $type;
  my $rules_to_set_up_hash = shift;
  my $parameters = shift;
  my $self = {};

  bless $self, $class;
  $self->{separator} = '__XZ__';
  $self->{max_steps} = $parameters->{max_steps} || 1000000;
  $self->{parse_trace_routine} = $parameters->{parse_trace_routine} || undef;
  $self->{multiple_rule_mins} = 0;
  $self->{any_match_once} = 0;
  $self->{any_minimize_children} = 0;
  $self->{any_unevaluation} = 0;
  $self->{any_parse_forward} = 0;
  $self->{any_parse_backtrack} = 0;
  $self->{any_maximum_child} = 0;
  $self->{any_minimum_child} = 0;
  $self->{self} = $self;
  if ($self->{no_evaluation} = $parameters->{no_evaluation} || 0) {
    $self->{do_evaluation_in_parsing} = 0;
  }
  else {
    $self->{do_evaluation_in_parsing} = $parameters->{do_evaluation_in_parsing}
     || 0;
  }
  $self->{unreachable_rules_allowed} = $parameters->{unreachable_rules_allowed}
   || 0;
  $self->{do_not_compress_eval} = $parameters->{do_not_compress_eval} || 0;
  $self->{separator} = $parameters->{separator} || $self->{separator};
  if (defined $parameters->{parse_forward}) {
    $self->{leaf_parse_forward} = $parameters->{parse_forward};
    $self->{any_parse_forward} = 1;
  }
  if (defined $parameters->{parse_backtrack}) {
    $self->{leaf_parse_backtrack} = $parameters->{parse_backtrack};
    $self->{any_parse_backtrack} = 1;
  }
  if (defined $parameters->{length_routine}) {
    $self->{length_routine} = $parameters->{length_routine};
  }
  else {
    $self->{length_routine} = sub {return length(${$_[0]});}
  }
  $self->incorporate_others($parameters->{incorporate})
   if defined $parameters->{incorporate};
  $self->set_up_full_rule_set($rules_to_set_up_hash, $parameters);
  my $number_of_rules = scalar(keys %{$self->{rule}});
  my $min_multiplier = $number_of_rules;
  $self->{max_nodes_before_size_must_change} = $number_of_rules +
    $min_multiplier * $self->{multiple_rule_mins};
  $self->{fast_move_back} = $parameters->{fast_move_back} ||
   !($self->{any_parse_backtrack} || $self->{any_unevaluation});
  return $self;
}

sub copy_tree_node_list {
  my $list = shift;
  my @new_list;
  my %parent_hash;
  my $node_count = scalar @$list - 1;
  my $node_to_copy = $list->[$node_count];
  $new_list[$node_count] = {
      name => $node_to_copy->{name},
      alias => $node_to_copy->{alias},
      parse_match => $node_to_copy->{parse_match},
      position_when_entered => $node_to_copy->{position_when_entered},
      position_when_completed => $node_to_copy->{position_when_completed}
  };
  $parent_hash{$node_to_copy} = $node_count;
  for (my $i = $node_count-1; $i > -1; $i--) {
    $node_to_copy = $list->[$i];
    $parent_hash{$node_to_copy} = $i;
    $new_list[$i] = {
      name => $node_to_copy->{name},
      alias => $node_to_copy->{alias},
      parse_match => $node_to_copy->{parse_match},
      position_when_entered => $node_to_copy->{position_when_entered},
      position_when_completed => $node_to_copy->{position_when_completed},
      parent => $new_list[$parent_hash{$node_to_copy->{parent}}],
     };
  }
  return \@new_list;
}

sub parse_and_evaluate {
  my $self = shift;
  my $parameters = $_[1] || {};
  my $in_is_string = 0;
  $parameters->{parse_info} = $parameters->{parse_info} || {};
  $parameters->{parse_hash} = $parameters->{parse_hash} || {};
  my $initial_position = 0;
  if (defined $_[0]) {
    $parameters->{parse_this_ref} = \$_[0];
    if (ref $_[0] eq '') {
      $in_is_string = 1;
      $initial_position = pos $_[0] || 0;
    }
  }
  my $find_all;
  if (defined $parameters->{find_all}) {
    $find_all = $parameters->{find_all};
  }
  elsif ($parameters->{global}) {
    if (wantarray) {
      $find_all = 1;
    }
    else {
      $find_all = 0;
    }
  }
  if (defined $parameters->{start_position}) {
    $initial_position = $parameters->{start_position};
  }
  my $not_match_start;
  if (!defined $parameters->{match_start}) {
    $not_match_start = 0;
  }
  else {
    $not_match_start = !$parameters->{match_start};
  }
  if (!defined $parameters->{match_length}) {
    $parameters->{parse_hash}->{__match_length} = 1;
  }
  else {
    $parameters->{parse_hash}->{__match_length} = $parameters->{match_length};
  }
  $parameters->{parse_hash}->{__initial_position} = $initial_position;
  my $parse_this_ref = $parameters->{parse_this_ref};
  my $parse_this_length = $parameters->{parse_hash}->{__parse_this_length} =
   $self->{length_routine}($parse_this_ref);
  my $parser = new Parse::Stallion::Parser($self);
  my $substitution_subroutine;
  my $substitute;
  if (defined $parameters->{substitution}) {
    $substitute = 1;
    if (ref $parameters->{substitution} eq 'CODE') {
      $substitution_subroutine = $parameters->{substitution};
    }
    else {
      $substitution_subroutine = sub {return $parameters->{substitution}};
    }
  }
  elsif ($substitute = $parameters->{substitute} || 0) {
    $substitution_subroutine = sub {return $_[0];}
  }
  $parameters->{parse_hash}->{rule_info} =
   $self->{rule_info};
  my $parser_results;
  if ($parameters->{parse_trace}) {
    $parameters->{parse_trace_routine} = sub {
      my $parse_hash = shift;
      my $parent_step = 0;
      my $current_node = ${$parse_hash->{__current_node_ref}};
      if ($current_node->{parent}) {
        $parent_step = $current_node->{parent}->{steps};
      }
      push @{$parameters->{parse_trace}}, {
       rule_name => ${$parse_hash->{__current_node_name_ref}},
       moving_forward => ${$parse_hash->{__moving_forward_ref}},
       moving_down => ${$parse_hash->{__moving_down_ref}},
       position => ${$parse_hash->{__current_position_ref}},
       node_creation_step => $current_node->{steps},
       parent_node_creation_step => $parent_step,
       message => ${$parse_hash->{__message_ref}},
       tree => $parse_hash->{__tree}->stringify,
      };
    };
  }
  my $match_position;
  my $match_maximum = $parameters->{match_maximum};
  my $match_minimum = $parameters->{match_minimum};
  if ($match_maximum && $match_minimum) {
    croak "Cannot match both maximum and minimum";
  }
  if ($match_maximum || $match_minimum) {
    $parameters->{parse_hash}->{__match_length} = 0;
  }
  my $tree_to_evaluate = undef;
  my $to_return;
  my @results_array;
  my $continue_to_parse = 1;
  my $parse_succeeded;
  while ($continue_to_parse) {
    $continue_to_parse = 0;
    if ($match_maximum) {
      $match_position = -1;
    }
    elsif ($match_minimum) {
      $match_position = $parse_this_length;
    }
    $parse_succeeded = 0;
    my $root_node;
    my $repeat_parse_by_start = 1;
    while ($repeat_parse_by_start) {
      $repeat_parse_by_start = 0;
      my $repeat_parse = 1;
      while ($repeat_parse) {
        $repeat_parse = 0;
        $parser_results = eval {$parser->parse($parameters)};
        if ($@) {croak ($@)};
        if ($parser_results->{parse_succeeded}) {
          $parse_succeeded = 1;
          if ($match_maximum &&
           ($parser_results->{final_position} < $parse_this_length)) {
            if ($parser_results->{final_position} > $match_position) {
              $match_position = $parser_results->{final_position};
              if ($self->{do_evaluation_in_parsing}) {
                $to_return = $parser_results->{parsing_evaluation};
              }
              else {
                $tree_to_evaluate = copy_tree_node_list(
                 $parser_results->{bottom_up_left_to_right});
                $root_node =
                 $tree_to_evaluate->[$parser_results->{tree_size}-1];
              }
            }
            $repeat_parse = 1;
            $parameters->{continue_parse} = 1;
            ${$parameters->{parse_hash}->{__moving_forward_ref}} = 0;
            ${$parameters->{parse_hash}->{__moving_down_ref}} = 1;
            $parameters->{parse_hash}->{current_node} =
             $parameters->{parse_hash}->{tree};
            ${$parameters->{parse_hash}->{__message_ref}} .=
             ' . Looking for longer match '
             if $parameters->{parse_hash}->{__parse_trace_routine};
            pop @{$parser_results->{bottom_up_left_to_right}}
             if $parameters->{parse_hash}->{__bottom_up};
          }
          elsif ($match_minimum &&
           ($parser_results->{final_position} > $initial_position)) {
            if ($parser_results->{final_position} < $match_position) {
              $match_position = $parser_results->{final_position};
              if ($self->{do_evaluation_in_parsing}) {
                $to_return = $parser_results->{parsing_evaluation};
              }
              else {
                $tree_to_evaluate = copy_tree_node_list(
                 $parser_results->{bottom_up_left_to_right});
                $root_node =
                 $tree_to_evaluate->[$parser_results->{tree_size}-1];
              }
            }
            $repeat_parse = 1;
            $parameters->{continue_parse} = 1;
            ${$parameters->{parse_hash}->{__moving_forward_ref}} = 0;
            ${$parameters->{parse_hash}->{__moving_down_ref}} = 1;
            $parameters->{parse_hash}->{current_node} =
             $parameters->{parse_hash}->{tree};
            ${$parameters->{parse_hash}->{__message_ref}} .=
             ' . Looking for shorter match '
             if $parameters->{parse_hash}->{__parse_trace_routine};
            pop @{$parser_results->{bottom_up_left_to_right}}
             if $parameters->{parse_hash}->{__bottom_up};
          }
          elsif ($self->{do_evaluation_in_parsing}) {
            $match_position = $parser_results->{final_position};
            $to_return = $parser_results->{parsing_evaluation};
          }
          else {
            $match_position = $parser_results->{final_position};
            $tree_to_evaluate = $parser_results->{bottom_up_left_to_right};
            $root_node = $parser_results->{tree};
          }
        }
      }
      if (!($parse_succeeded) && $not_match_start &&
          ($parse_this_length > $initial_position)) {
        $parameters->{parse_hash}->{__initial_position}++;
        $initial_position++;
        $parameters->{continue_parse} = 0;
        $repeat_parse_by_start = 1;
      }
    }

    $parser_results->{parse_succeeded} =
     $parser_results->{parse_succeeded} || $parse_succeeded;
    if (!($parse_succeeded) || $self->{no_evaluation}) {
      $to_return = undef;
    }
    elsif ($self->{do_evaluation_in_parsing}) {
      if (!defined $to_return) {$to_return = ''};
    }
    else {
      $parameters->{nodes} = $tree_to_evaluate;
      $self->new_evaluate_tree_node($parameters);
      #$to_return = $parser_results->{tree}->{computed_value};
      $to_return = $root_node->{computed_value};
      if (!defined $to_return) {$to_return = ''};
    }
    if ((defined $to_return) && ($substitute) ) {
      my $replaced_length = $match_position - $initial_position;
      my $to_sub = &{$substitution_subroutine}($to_return);
      substr(${$parameters->{parse_this_ref}}, $initial_position,
       $replaced_length) = $to_sub;
      $match_position += $self->{length_routine}(\$to_sub) - $replaced_length;
      $parameters->{parse_hash}->{__parse_this_length} = $parse_this_length =
       $self->{length_routine}($parse_this_ref);
    }
    if ($find_all && $parse_succeeded) {
      push @results_array, $to_return;
      if ($match_position == $initial_position) {
        $match_position++;
      }
      $initial_position = $parameters->{parse_hash}->{__initial_position}
       = $match_position;
      if ($match_position <= $parse_this_length) {
        $continue_to_parse = 1;
        $parameters->{continue_parse} = 0;
      }
    }
  }
  if ($in_is_string) {
    if ($parameters->{global} && $parse_succeeded) {
      pos $_[0] = $match_position;
    }
    else {
      pos $_[0] = undef;
    }
  }

  if ($find_all) {
    return @results_array;
  }
  return $to_return;
}

sub search {
  my $self = shift;
  my $parameters = $_[1] || {};
  if (!defined $parameters->{match_start}) {
    $parameters->{match_start} = 0;
  }
  if (!defined $parameters->{match_length}) {
    $parameters->{match_length} = 0;
  }
  $parameters->{parse_info} = $parameters->{parse_info} || {};
  if ($parameters->{global} && wantarray) {
    return $self->parse_and_evaluate($_[0], $parameters);
  }
  else {
    $self->parse_and_evaluate($_[0], $parameters);
    if ($parameters->{parse_info}->{parse_succeeded}) {
      return 1;
    }
    else {
      return '';
    }
  }
}

sub search_and_substitute {
  my $self = shift;
  my $parameters = $_[1] || {};
  $parameters->{substitute} = 1;
  if ($parameters->{global}) {
    my @substitutions = $self->search($_[0], $parameters);
    return scalar(@substitutions);
  }
  else {
    return $self->search($_[0], $parameters);
  }
}

#package rules
sub ri_sub {
  return ['RULE_INFO', @_];
}

sub R {ri_sub(@_)}
sub RULE_INFO {ri_sub(@_)}

sub eval_sub {
  return ['EVAL', @_];
}

sub E {eval_sub(@_)}
sub EVALUATION {eval_sub(@_)}

sub string_eval_sub {
  return ['SEVAL', @_];
}

sub SE {string_eval_sub(@_)}
sub STRING_EVALUATION {string_eval_sub(@_)}

sub uneval_sub {
  return ['UNEVAL', @_];
}

sub U {uneval_sub(@_)}
sub UNEVALUATION {uneval_sub(@_)}

sub parse_forward_sub {
  return ['PARSE_FORWARD', @_];
}

sub PF {parse_forward_sub(@_)}
sub PARSE_FORWARD {parse_forward_sub(@_)}

sub parse_backtrack_sub {
  return ['PARSE_BACKTRACK', @_];
}

sub PB {parse_backtrack_sub(@_)}
sub PARSE_BACKTRACK {parse_backtrack_sub(@_)}

sub USE_STRING_MATCH {return ['USE_STRING_MATCH']}

sub MATCH_ONCE {return ['MATCH_ONCE', @_]}

sub MATCH_MIN_FIRST {return ['MATCH_MIN_FIRST']}

sub and_sub {
  return ['AND', @_];
}

sub AND {and_sub(@_)}
sub A {and_sub(@_)}

sub or_sub {
  return ['OR', @_];
}

sub OR {or_sub(@_)}
sub O {or_sub(@_)}

sub LEAF_DISPLAY {
  return ['LEAF_DISPLAY', $_[0]];
}

sub leaf {
  my @p;
  my @q;
  foreach my $parm (@_) {
    if (ref $parm eq 'ARRAY') {
      push @q, $parm;
    }
    else {
      push @p, $parm;
    }
  }
  if (ref $p[0] eq 'Regexp') {
    return ['LEAF', qr/\G($p[0])/, LEAF_DISPLAY($p[0]), @q];
  }
  else {
    return ['LEAF', @p, @q];
  }
}

sub LEAF {leaf(@_)}
sub TOKEN {leaf(@_)}
sub TERMINAL {leaf(@_)}
sub L {leaf(@_)}

sub multiple {
  my @p;
  my @q;
  foreach my $parm (@_) {
    if ((ref $parm eq 'ARRAY') &&
     ($parm->[0] eq 'EVAL' || $parm->[0] eq 'UNEVAL' || $parm->[0] eq 'SEVAL'
      || $parm->[0] eq 'RULE_INFO' || $parm->[0] eq 'MATCH_ONCE'
      || $parm->[0] eq 'MATCH_MIN_FIRST'
      || $parm->[0] eq 'USE_STRING_MATCH')) {
      push @q, $parm;
    }
    else {
      push @p, $parm;
    }
  }
  if ($#p == 0) {
    return ['MULTIPLE', 0, 0, $p[0], @q];
  }
  elsif ($#p == 2) {
    return ['MULTIPLE', $p[1], $p[2], $p[0], @q];
  }
  croak "Malformed MULTIPLE; arguments: ".join(", ", @_);
}

sub MULTIPLE {multiple(@_)}
sub M {multiple(@_)}

sub optional {
  return ['MULTIPLE', 0, 1, @_];
}
sub OPTIONAL {optional(@_)}
sub ZERO_OR_ONE {optional(@_)}
sub Z {optional(@_)}

sub update_count {
  my $rule_type = shift;
  my $rule_hash = shift;
  my $subrule_alias = shift;
  my $subrule_count = shift || 0;
  if ($subrule_count > 1) {
    $rule_hash->{rule_count}->{$subrule_alias} = 2;
  }
  elsif ($rule_type eq 'AND') {
    $rule_hash->{rule_count}->{$subrule_alias} += $subrule_count;
  }
  elsif ($rule_type eq 'MULTIPLE' && ($rule_hash->{maximum_child} != 1 ||
   $subrule_count > 1)) {
    $rule_hash->{rule_count}->{$subrule_alias} = 2;
  }
  elsif ($rule_type eq 'MULTIPLE') {
    $rule_hash->{rule_count}->{$subrule_alias} =
     $rule_hash->{rule_count}->{$subrule_alias} || 1;
  }
  elsif ($rule_type eq 'OR' &&
   (!defined $rule_hash->{rule_count}->{$subrule_alias} ||
    ($subrule_count > $rule_hash->{rule_count}->{$subrule_alias}))) {
    $rule_hash->{rule_count}->{$subrule_alias} = $subrule_count;
  }
}

sub incorporate_others {
  my $self = shift;
  my $incorporate_list = shift;
  if (ref $incorporate_list ne 'ARRAY') {
    croak "Must pass array to incorporate";
  }
  foreach my $to_incorporate (@$incorporate_list) {
    $self->copy_rules_from_grammar($to_incorporate);
  }
}

sub copy_rules_from_grammar {
  my $self = shift;
  my $parameters = shift;
  my $parser_to_incorporate = $parameters->{grammar_source};
  if (!defined $parser_to_incorporate) {
    croak "Need to define grammar_source to incorporate";
  }
  my $rules_to_copy = $parser_to_incorporate->{rule};
  my $prefix;
  if (defined $parameters->{prefix}) {
    $prefix = $parameters->{prefix};
  }
  else {
    $prefix = '';
  }
  foreach my $rule_name (keys %{$rules_to_copy}) {
    if (defined $self->{rule}->{$prefix.$rule_name}) {
      croak ("Rule $prefix$rule_name in extraction already exists");
    }
    my $rule_to_copy = $rules_to_copy->{$rule_name};
    my %copied_rule = %{$rule_to_copy};
    $copied_rule{sub_rule_name} = $prefix.$rule_to_copy->{sub_rule_name}
     if defined $rule_to_copy->{sub_rule_name};
    if (defined $rule_to_copy->{rule_count}) {
      $copied_rule{rule_count} = {%{$rule_to_copy->{rule_count}}};
      $copied_rule{subrule_list} = [];
      for my $i (1..$copied_rule{subrule_list_count}) {
        $copied_rule{subrule_list}[$i-1] = {};
        $copied_rule{subrule_list}->[$i-1]->{'alias'} =
         $rule_to_copy->{subrule_list}->[$i-1]->{'alias'};
        $copied_rule{subrule_list}->[$i-1]->{'name'} = $prefix.
         $rule_to_copy->{subrule_list}->[$i-1]->{'name'};
      }
    }
    $self->{rule}->{$prefix.$rule_name} = \%copied_rule;
  }
  $self->{multiple_rule_mins} += $parser_to_incorporate->{multiple_rule_mins};
  $self->{do_evaluation_in_parsing} = $self->{do_evaluation_in_parsing} ||
   $parser_to_incorporate->{do_evaluation_in_parsing};
  $self->{any_unevaluation} = $self->{any_unevaluation} ||
   $parser_to_incorporate->{any_unevaluation};
  $self->{any_minimize_children} = $self->{any_minimize_children} ||
   $parser_to_incorporate->{any_minimize_children};
  $self->{any_match_once} = $self->{any_match_once} ||
   $parser_to_incorporate->{any_match_once};
  $self->{any_parse_forward} = $self->{any_parse_forward} ||
   $parser_to_incorporate->{any_parse_forward};
  $self->{any_parse_backtrack} = $self->{any_parse_backtrack} ||
   $parser_to_incorporate->{any_parse_backtrack};
  $self->{any_maximum_child} = $self->{any_maximum_child} ||
   $parser_to_incorporate->{any_maximum_child};
  $self->{any_minimum_child} = $self->{any_minimum_child} ||
   $parser_to_incorporate->{any_minimum_child};
  $self->{fast_move_back} = $self->{fast_move_back} ||
   $parser_to_incorporate->{fast_move_back};
  $self->{no_evaluation} = $self->{no_evaluation} ||
   $parser_to_incorporate->{no_evaluation};
}

sub add_rule {
  my $self = shift;
  my $parameters = shift;
  my $rule_name = $parameters->{rule_name} || croak ("Empty rule name");
  my $rule = $parameters->{rule_definition};
  if ($self->{rule}->{$rule_name}) {
    croak ("Rule $rule_name already exists");
  }
  if (ref $rule eq 'Regexp') {
    $rule = LEAF($rule);
  }
  elsif (ref $rule eq '') {
    $rule = AND($rule);
  }

  if (ref $rule ne 'ARRAY') {
    croak ("Bad format of rule $rule_name, cannot create.");
  }

  my $separator = $self->{separator};
  my $base_rule = $rule_name;
  if (defined $parameters->{generated_name}) {
    $self->{rule}->{$rule_name}->{generated} = 1;
    $self->{rule}->{$rule_name}->{base_rule} =
     $base_rule = $parameters->{generated_name};
  }
  elsif (index($rule_name, $separator) != -1) {
    croak ("rule name $rule_name contains separator $separator");
  }
  else {
    $self->{rule}->{$rule_name}->{base_rule} = $rule_name;
  }
  my $default_alias = '';
  my @copy_of_rule; #to prevent changing input
  my $rule_type = $self->{rule}->{$rule_name}->{rule_type} = $rule->[0];
  foreach my $sub_rule (@$rule) {
    if (ref $sub_rule eq 'ARRAY' && $sub_rule->[0] eq 'EVAL') {
      my $what_to_eval = $sub_rule->[1];
      if ($self->{rule}->{$rule_name}->{parsing_evaluation}) {
        croak ("Rule $rule_name has more than one evaluation routine");
      }
      if (ref $sub_rule->[1] eq 'CODE') {
        $self->{rule}->{$rule_name}->{parsing_evaluation} = $what_to_eval;
      }
    }
    elsif (ref $sub_rule eq 'ARRAY' && $sub_rule->[0] eq 'SEVAL') {
      $self->{rule}->{$rule_name}->{string_evaluation} = $sub_rule->[1];
      $self->{rule}->{$rule_name}->{matched_string} = $sub_rule->[2];
    }
    elsif (ref $sub_rule eq 'ARRAY' && $sub_rule->[0] eq 'UNEVAL') {
      if ($self->{rule}->{$rule_name}->{parsing_unevaluation}) {
        croak ("Rule $rule_name has more than one unevaluation routine");
      }
      $self->{rule}->{$rule_name}->{parsing_unevaluation} = $sub_rule->[1]
       || $self->{rule}->{$rule_name}->{parsing_unevaluation};
      $self->{do_evaluation_in_parsing} = 1;
      $self->{any_unevaluation} = 1;
    }
    elsif (ref $sub_rule eq 'ARRAY' && $sub_rule->[0] eq 'MATCH_MIN_FIRST') {
      if ($rule_type ne 'MULTIPLE') {
        croak ("Rule $rule_name: Only multiple rules can have MATCH_MIN_FIRST");
      }
      $self->{rule}->{$rule_name}->{minimize_children} = 1;
      $self->{any_minimize_children} = 1;
    }
    elsif (ref $sub_rule eq 'ARRAY' && $sub_rule->[0] eq 'MATCH_ONCE') {
      $self->{rule}->{$rule_name}->{match_once} = 1;
      $self->{any_match_once} = 1;
    }
    elsif (ref $sub_rule eq 'ARRAY' && $sub_rule->[0] eq 'RULE_INFO') {
      if ($self->{rule_info}->{$rule_name}) {
        croak ("Rule $rule_name has more than one rule_info");
      }
      $self->{rule_info}->{$rule_name} = $sub_rule->[1];
    }
    elsif (ref $sub_rule eq 'ARRAY' && $sub_rule->[0] eq 'LEAF_DISPLAY') {
      if ($self->{rule}->{$rule_name}->{leaf_display}) {
        croak ("Rule $rule_name has more than one leaf_display");
      }
      if ($rule_type ne 'LEAF') {
        croak ("Only leaf rules can have LEAF_DISPLAY in rule $rule_name");
      }
      $self->{rule}->{$rule_name}->{leaf_display} = $sub_rule->[1];
    }
    elsif (ref $sub_rule eq 'ARRAY' && $sub_rule->[0] eq 'USE_STRING_MATCH') {
      $self->{rule}->{$rule_name}->{use_string_match} = 1;
    }
    elsif (ref $sub_rule eq 'ARRAY' && $sub_rule->[0] eq 'PARSE_FORWARD') {
      if ($self->{rule}->{$rule_name}->{parse_forward}) {
        croak ("Rule $rule_name has more than one parse_forward");
      }
      $self->{rule}->{$rule_name}->{parse_forward} = $sub_rule->[1]
       || croak ("Rule $rule_name Illegal parse_forward routine");
      $self->{any_parse_forward} = 1;
    }
    elsif (ref $sub_rule eq 'ARRAY' && $sub_rule->[0] eq 'PARSE_BACKTRACK') {
      if ($rule_type eq 'LEAF') {
        if ($self->{rule}->{$rule_name}->{parse_backtrack}) {
          croak ("Rule $rule_name has more than one parse_backtrack");
        }
        $self->{rule}->{$rule_name}->{parse_backtrack} = $sub_rule->[1]
         || croak ("Rule $rule_name Illegal parse_backtrack routine");
        $self->{any_parse_backtrack} = 1;
      }
      else {
        croak ("Parse backtrack in rule $rule_name of $rule_type (not leaf)");
      }
    }
    elsif (!defined $sub_rule) {
      croak "undefined sub_rule in rule $rule_name";
    }
    else {
      push @copy_of_rule, $sub_rule;
    }
  }
  shift @copy_of_rule; #Remove rule type
  $self->{rule}->{$rule_name}->{leaf_rule} = 0;
  $self->{rule}->{$rule_name}->{or_rule} = 0;
  $self->{rule}->{$rule_name}->{and_rule} = 0;
  $self->{rule}->{$rule_name}->{multiple_rule} = 0;
  if ($rule_type eq 'LEAF') {
    my $leaf_info = shift @copy_of_rule;
    if (ref $leaf_info eq 'Regexp') {
      $self->{rule}->{$rule_name}->{regex_match} = $leaf_info;
      if ('' =~ $leaf_info) {
        $self->{rule}->{$rule_name}->{zero} = 1;
      }
    }
    elsif (defined $leaf_info) {
      if (defined $self->{rule_info}->{$rule_name}) {
        croak ("Duplicate info on $rule_name, leaf info is put into rule_info");
      }
      $self->{rule_info}->{$rule_name} = $leaf_info;
    }
    $self->{rule}->{$rule_name}->{parse_forward} =
     $self->{rule}->{$rule_name}->{parse_forward} ||
     $self->{leaf_parse_forward};
    $self->{rule}->{$rule_name}->{parse_backtrack} =
     $self->{rule}->{$rule_name}->{parse_backtrack} ||
     $self->{leaf_parse_backtrack};
    $self->{rule}->{$rule_name}->{use_parse_match} = 1;
    $self->{rule}->{$rule_name}->{leaf_rule} = 1;
  }
  else {
    if ($rule_type eq 'AND') {
      $self->{rule}->{$rule_name}->{and_rule} = 1;
    }
    elsif ($rule_type eq 'OR') {
      $self->{rule}->{$rule_name}->{or_rule} = 1;
    }
    elsif ($rule_type eq 'MULTIPLE') {
      $self->{rule}->{$rule_name}->{multiple_rule} = 1;
      my $min =
       $self->{rule}->{$rule_name}->{minimum_child} = shift @copy_of_rule;
      my $max =
      $self->{rule}->{$rule_name}->{maximum_child} = shift @copy_of_rule;
      if (($max && ($min > $max)) || ($min < 0) || $min != int($min)
       || $max != int($max)) {
        croak("Illegal bound(s) $min and $max on $rule_name");
      }
      if ($self->{rule}->{$rule_name}->{maximum_child}) {
        $self->{any_maximum_child} = 1;
      }
      if ($self->{rule}->{$rule_name}->{minimum_child}) {
        $self->{any_minimum_child} = 1;
      }
      $self->{multiple_rule_mins} += $min;
    }
    else {
      croak "Bad rule type $rule_type on rule $rule_name";
    }
    foreach my $current_rule (@copy_of_rule) {
      my ($alias, $name);
      if (ref $current_rule eq 'HASH') {
        my @hash_info = keys (%{$current_rule});
        if ($#hash_info != 0) {
          croak ("Too many keys in rule $rule_name");
        }
        $alias = $hash_info[0];
        $current_rule = $current_rule->{$alias};
      }
      if (ref $current_rule eq '') {
        if (!defined $alias) {
          $alias = $current_rule;
        }
        $name = $current_rule;
      }
      elsif (ref $current_rule eq 'Regexp') {
        if (!defined $alias) {
          $alias = $default_alias;
        }
        $name = $base_rule.$separator.
          ++$self->{unique_name_counter}->{$base_rule};
        $self->add_rule({
         rule_name => $name, rule_definition => LEAF($current_rule),
         generated_name => $base_rule});
      }
      elsif (ref $current_rule eq 'ARRAY') {
        $name = $base_rule.$separator.
          ++$self->{unique_name_counter}->{$base_rule};
        $self->add_rule({
         rule_name => $name, rule_definition => $current_rule,
         generated_name => $base_rule});
        if (!defined $alias) {
          if (defined $self->{rule}->{$name}->{parsing_evaluation} ||
           $self->{rule}->{$name}->{rule_type} eq 'LEAF') {
            $alias = $default_alias;
          }
        }
      }
      push @{$self->{rule}->{$rule_name}->{subrule_list}},
       {alias => $alias, name => $name};
    }
    $self->{rule}->{$rule_name}->{subrule_list_count} =
     scalar(@{$self->{rule}->{$rule_name}->{subrule_list}});
    foreach my $subrule (@{$self->{rule}->{$rule_name}->{subrule_list}}) {
      if (defined $subrule->{alias}) {
           update_count($rule_type,
            $self->{rule}->{$rule_name},$subrule->{alias}, 1);
      }
      else {
        foreach my $sub_alias (keys
         %{$self->{rule}->{$subrule->{name}}->{rule_count}}) {
           update_count($rule_type,
            $self->{rule}->{$rule_name}, $sub_alias,
            $self->{rule}->{$subrule->{name}}->{rule_count}->{$sub_alias});
        }
      }
    }
    if (defined $self->{rule}->{$rule_name}->{string_evaluation}) {
      if ($self->{rule}->{$rule_name}->{parsing_evaluation}) {
        croak ("Rule $rule_name has multiple evaluation routines");
      }
      my $params = which_parameters_are_arrays($self, $rule_name);
      my @params = keys %$params;
      my $sub = "sub {\n";
      if ($self->{rule}->{$rule_name}->{use_string_match}) {
        $sub .= "\$_ = \$_[0];\n";
      }
      else {
        foreach my $param (@params) {
          if ($param =~ /\w+/ && ($param ne '_')) {
            $sub .= "my \$$param = \$_[0]->{$param};\n";
          }
          elsif ($param eq '') {
            $sub .= "\$_ = \$_[0]->{''};\n";
          }
          else {
            croak "String Evaluation of rule $rule_name cannot handle ".
             "parameter with name $param";
          }
        }
        if (my $ms = $self->{rule}->{$rule_name}->{matched_string}) {
          $sub .= "my \$".$ms." = MATCHED_STRING(\$_[1]);\n";
        }
      }
      $sub .= $self->{rule}->{$rule_name}->{string_evaluation}."}";
      $self->{rule}->{$rule_name}->{parsing_evaluation} = eval $sub;
      if ($@) {croak "Rule $rule_name error on subroutine evaluation $@"};
    }
    $self->{rule}->{$rule_name}->{sub_rule_name} =
     $self->{rule}->{$rule_name}->{subrule_list}->[0]->{name};
    $self->{rule}->{$rule_name}->{sub_alias} =
     $self->{rule}->{$rule_name}->{subrule_list}->[0]->{alias};
  }
}

sub make_sure_all_rules_reachable {
  my $self = shift;
  my $parameters = shift;
  my $start_rule = $parameters->{start_rule};
  my @rules_to_check = ($start_rule);
  my %rules_checked;
  $rules_checked{$start_rule} = 1;
  while (my $rule_to_check = shift @rules_to_check) {
    if ($self->{rule}->{$rule_to_check}->{subrule_list}) {
      foreach my $rule_name_alias
       (@{$self->{rule}->{$rule_to_check}->{subrule_list}}) {
        my $rule_name = $rule_name_alias->{name};
        if (!($rules_checked{$rule_name}++)) {
          push @rules_to_check, $rule_name;
        }
      }
    }
  }
  my @unreachable;
  foreach my $rule (keys %{$self->{rule}}) {
    if (!$rules_checked{$rule}) {
      push @unreachable, "No path to rule $rule start rule $start_rule";
    }
  }
  return @unreachable;
}

sub make_sure_all_names_covered {
  my $self = shift;
  my $parameters = shift;
  my $return_list = $parameters->{return_list};
  my @list;
  foreach my $rule (keys %{$self->{rule}}) {
    if ($self->{rule}->{$rule}->{subrule_list}) {
      foreach my $rule_name_alias (@{$self->{rule}->{$rule}->{subrule_list}}) {
        my $rule_name = $rule_name_alias->{name};
        if (!$self->{rule}->{$rule_name}) {
          if ($return_list) {
            push @list, "Rule $rule missing subrule: $rule_name";
          }
          else {
            croak ("Rule $rule has undefined subrule of $rule_name");
          }
        }
      }
    }
  }
  return @list;
}

sub which_parameters_are_arrays {
  my $self = shift;
  my $rule_name = shift;
  my $rules_details = $self->{rule};
  my %to_return;
  foreach my $child_rule_name (sort keys
   %{$rules_details->{$rule_name}->{rule_count}}) {
    if ($rules_details->{$rule_name}->{rule_count}->{$child_rule_name} > 1) {
      $to_return{$child_rule_name} = 1;
    }
    else {
      $to_return{$child_rule_name} = 0;
    }
  }
  return \%to_return;
}

sub set_up_full_rule_set {
  my $self = shift;
  my $rules_to_set_up_hash = shift;
  my $parameters = shift;
  my $start_rule = $parameters->{start_rule};

  if (scalar keys %$rules_to_set_up_hash) {
    foreach my $hash_rule_name (sort keys %$rules_to_set_up_hash) {
      $self->add_rule({rule_name => $hash_rule_name,
       rule_definition => $rules_to_set_up_hash->{$hash_rule_name}});
    }
  }

  if (!defined $start_rule) {
    my %covered_rule;
    foreach my $rule_name (keys %{$self->{rule}}) {
      foreach my $subrule
       (@{$self->{rule}->{$rule_name}->{subrule_list}}) {
        if ($subrule->{name} ne $self->{rule}->{$rule_name}->{base_rule}) {
          $covered_rule{$subrule->{name}}++;
        }
      }
    }
    START: foreach my $rule_name (keys %{$self->{rule}}) {
      if (!$covered_rule{$rule_name}) {
        $start_rule = $rule_name;
        last START;
      }
    }
    if (!defined $start_rule) {croak "No valid start rule"};
  }

  my @missing_rules = $self->make_sure_all_names_covered({return_list=>1});
  if ($#missing_rules > -1) {
    croak "Missing rules: ".join("\n",@missing_rules)."\n";
  }

  if (!$self->{unreachable_rules_allowed}) {
    my @unreachable_rules = $self->make_sure_all_rules_reachable({
     start_rule=>$start_rule});
    if ($#unreachable_rules > -1) {
      croak "Unreachable rules: ".join("\n",@unreachable_rules)."\n";
    }
  }

  $self->look_for_left_recursion;
  $self->{start_rule} = $start_rule;

}

sub look_for_left_recursion {
  my $self = shift;
  my %checked_rules;
  foreach my $rule (keys %{$self->{rule}}) {
    if ($checked_rules{$rule}) {next};
    my $current_rule = $rule;
    my $moving_down = 1;
    my %active_rules;
    my @active_rules;
    my $previous_allows_zero = 0;
    while (defined $current_rule) {
      if ($moving_down) {
        if ($active_rules{$current_rule}++) {
          croak "Left recursion in grammar: ".
           join(" leads to ", @active_rules, $current_rule);
        }
        push @active_rules, $current_rule;
        if ($checked_rules{$current_rule}
         || $self->{rule}->{$current_rule}->{leaf_rule}) {
          $moving_down = 0;
        }
        else {
          $active_rules{$current_rule} = 1;
          if ($self->{rule}->{$current_rule}->{multiple_rule}) {
            $current_rule = $self->{rule}->{$current_rule}->{sub_rule_name};
          }
          else {
            $current_rule =
             $self->{rule}->{$current_rule}->{subrule_list}->[0]->{name};
          }
        }
      }
      else {
        if ($previous_allows_zero) {
          if ($self->{rule}->{$current_rule}->{multiple_rule} ||
           $self->{rule}->{$current_rule}->{or_rule}) {
            $self->{rule}->{$current_rule}->{zero} = 1;
          }
          elsif ($self->{rule}->{$current_rule}->{and_rule} &&
           ($active_rules{$current_rule} ==
           $self->{rule}->{$current_rule}->{subrule_list_count})) {
            $self->{rule}->{$current_rule}->{zero} = 1;
          }
          else {
            $previous_allows_zero = 0;
          }
        }
        if ($self->{rule}->{$current_rule}->{multiple_rule} ||
         $self->{rule}->{$current_rule}->{leaf_rule} ||
         $checked_rules{$current_rule}) {
          delete $active_rules{$current_rule};
          $previous_allows_zero = $self->{rule}->{$current_rule}->{zero} || 0;
          pop @active_rules;
          $current_rule = $active_rules[-1];
        }
        elsif ($active_rules{$current_rule} ==
           $self->{rule}->{$current_rule}->{subrule_list_count}) {
            $previous_allows_zero = $self->{rule}->{$current_rule}->{zero} || 0;
            delete $active_rules{$current_rule};
            pop @active_rules;
            $current_rule = $active_rules[-1];
        }
        elsif ($self->{rule}->{$current_rule}->{and_rule}) {
          my $previous_rule =
           $self->{rule}->{$current_rule}->{subrule_list}->
           [$active_rules{$current_rule}-1]->{name};
          if ((defined $self->{rule}->{$previous_rule}->{zero} &&
           $self->{rule}->{$previous_rule}->{zero}) ||
           ($self->{rule}->{$previous_rule}->{multiple_rule} &&
           $self->{rule}->{$previous_rule}->{minimum_child} == 0)) {
            $current_rule =
             $self->{rule}->{$current_rule}->{subrule_list}->
             [$active_rules{$current_rule}++]->{name};
            $moving_down = 1;
          }
          else {
            $previous_allows_zero = $self->{rule}->{$current_rule}->{zero} || 0;
            delete $active_rules{$current_rule};
            pop @active_rules;
            $current_rule = $active_rules[-1];
          }
        }
        else {
          $current_rule =
           $self->{rule}->{$current_rule}->{subrule_list}->
           [$active_rules{$current_rule}++]->{name};
          $moving_down = 1;
        }
      }
    }
  }
}

sub new_unevaluate_tree_node {
  my $self = shift;
  my $parameters = shift;
  my $node = $parameters->{node};
  my $rules_details = $self->{rule};
  my $rule_name = $node->{name};
  my $rule = $rules_details->{$rule_name};
  my $subroutine_to_run = $rule->{parsing_unevaluation};
  my $params_to_eval = $node->{__parameters};

  if ($rule->{use_parse_match}) {
    $params_to_eval = $node->{parse_match};
  }

  if (defined $subroutine_to_run) {
    my $parse_hash = $parameters->{parse_hash};
    delete $parse_hash->{current_position};
    delete $parse_hash->{rule_name};
    $parse_hash->{current_node} = $node;
    &$subroutine_to_run($params_to_eval, $parse_hash);
    delete $parse_hash->{current_node};
  }

  my $parent;
  if ($parent = $node->{parent}) {

    foreach my $param (keys %{$node->{passed_params}}) {
      if (my $count = $node->{passed_params}->{$param}) {
        if ($count > scalar(@{$parent->{__parameters}->{$param}})) {
          croak("Unevaluation parameter miscount; rule $rule_name p: $param");
        }
        splice(@{$parent->{__parameters}->{$param}}, - $count);
      }
      else {
        delete $parent->{__parameters}->{$param};
      }
    }
    delete $node->{passed_params};
  }
}

sub MATCHED_STRING {
  my $parse_hash = shift;
  my $node = $parse_hash->{current_node};
  return substr(${$parse_hash->{parse_this_ref}},
   $node->{position_when_entered},
   $node->{position_when_completed} - $node->{position_when_entered});
}

sub new_evaluate_tree_node {
  my $self = shift;
  my $parameters = shift;
  my $nodes = $parameters->{nodes};
  my $rules_details = $self->{rule};
  my @results;

  my $parse_hash = $parameters->{parse_hash};
  foreach my $node (@$nodes) {
    my $rule_name = $node->{name};
    my $params_to_eval = $node->{__parameters};
    my $rule = $rules_details->{$rule_name};
    my $subroutine_to_run = $rule->{parsing_evaluation};

    if ($rule->{use_parse_match}) {
      $params_to_eval = $node->{parse_match};
    }
    elsif ($rule->{use_string_match}) {
      $params_to_eval = substr(${$parse_hash->{parse_this_ref}},
       $node->{position_when_entered},
       $node->{position_when_completed} - $node->{position_when_entered});
    }
    my $alias = $node->{alias};

    my $cv;
    if ($subroutine_to_run) {
      $parse_hash->{rule_name} = $rule_name;
      $parse_hash->{current_node} = $node;
      @results = &$subroutine_to_run($params_to_eval, $parse_hash);
      $cv = $results[0];
    }
    else {
      if ($rule->{generated} || $self->{do_not_compress_eval}) {
        $cv = $params_to_eval;
      }
      elsif ((ref $params_to_eval eq 'HASH') && (keys %$params_to_eval == 1)) {
        ($cv) = values %$params_to_eval;
      }
      else {
        $cv = $params_to_eval;
      }
    }
    $node->{computed_value} = $cv;

    my $parent;
    if ($parent = $node->{parent}) {
      my $parent_name = $parent->{name};

      if (defined $alias) {
        if ($rules_details->{$parent_name}->{rule_count}->{$alias} > 1) {
          push @{$parent->{__parameters}->{$alias}}, $cv;
          $node->{passed_params}->{$alias} = 1;
        }
        else {
          $parent->{__parameters}->{$alias} = $cv;
          $node->{passed_params}->{$alias} = 0;
        }
      }
      else { # !defined alias
        foreach my $key (keys %$cv) {
          if ($rules_details->{$rule_name}->{rule_count}->{$key} > 1) {
            if (scalar(@{$cv->{$key}})) {
              push @{$parent->{__parameters}->{$key}}, @{$cv->{$key}};
              $node->{passed_params}->{$key} = scalar(@{$cv->{$key}});
            }
          }
          elsif ($rules_details->{$parent_name}->{rule_count}->{$key} > 1) {
            push @{$parent->{__parameters}->{$key}}, $cv->{$key};
            $node->{passed_params}->{$key} = 1;
          }
          else {
            $parent->{__parameters}->{$key} = $cv->{$key};
            $node->{passed_params}->{$key} = 0;
          }
        }
      }
    }
  }
  delete $parse_hash->{current_node};

  return $results[1];
}

sub LOCATION {
  my ($text_ref, $value) = @_;
  if (ref $text_ref ne 'SCALAR') {
    croak "First arg to LOCATION must be string ref";
  }
  my $substring = substr($$text_ref,0,$value+1);
  my $line_number = 1 + ($substring =~ tr/\n//);
  $substring =~ /([^\n]*)$/;
  my $line_position = length($1);
  return ($line_number, $line_position);
}

sub parse_forward {
  my $parse_hash = shift;

}

1;

__END__