#!/usr/bin/perl -I/home/phil/perl/cpan/DataTableText/lib/
#-------------------------------------------------------------------------------
# Create a parse tree from an array of terms representing an expression.
# Philip R Brenan at appaapps dot com, Appa Apps Ltd Inc., 2021
#-------------------------------------------------------------------------------
package Tree::Term;
use v5.26;
our $VERSION = 20210629;                                                        # Version
use warnings FATAL => qw(all);
use strict;
use Carp qw(confess cluck);
use Data::Dump qw(dump ddx pp);
use Data::Table::Text qw(:all);
use feature qw(say state current_sub);

#D1 Parse                                                                       # Create a parse tree from an array of terms representing an expression.

sub new($@)                                                                     #P New term.
 {my ($operator, @operands) = @_;                                               # Operator, operands.
  my $t = genHash(__PACKAGE__,                                                  # Description of a term in the expression.
     operands => @operands ? [@operands] : undef,                               # Operands to which the operator will be applied.
     operator => $operator,                                                     # Operator to be applied to one or more operands.
     up       => undef,                                                         # Parent term if this is a sub term.
   );
  $_->up = $t for grep {ref $_} @operands;                                      # Link to parent if possible

  $t
 }

sub parse(@)                                                                    # Parse an expression.
 {my (@expression) = @_;                                                        # Expression to parse

  my @s;                                                                        # Stack

  my sub term()                                                                 # Convert the longest possible expression on top of the stack into a term
   {my $n = scalar(@s);
#   lll "TTTT $n \n", dump([@s]);

    my sub test($*)                                                             # Check the type of an item in the stack
     {my ($item, $type) = @_;                                                   # Item to test, expected type of item
      return index($type, 't') > -1 if ref $item;                               # Term
      index($type, substr($item, 0, 1)) > -1                                    # Something other than a term defines its type by its first letter
     };

    if (@s >= 3)                                                                # Go for term infix-operator term
     {my ($r, $d, $l) = reverse @s;
      if (test($l,t) and test($r,t) and test($d,ads))                           # Parse out infix operator expression
       {pop @s for 1..3;
        push @s, new $d, $l, $r;
        return 1;
       }
      if (test($l,b) and test($r,B) and test($d,t))                             # Parse bracketed term
       {pop @s for 1..3;
        push @s, $d;
        return 1;
       }
     }

    if (@s >= 2)                                                                # Convert ( ) to an empty term
     {my ($r, $l) = reverse @s;
      if (test($l,b) and test($r,B))                                            # Empty pair of brackets
       {pop @s for 1..2;
        push @s, new 'empty1';
        return 1;
       }
      if (!ref($l) and ref($r) and $l =~ m(\Ap))                                # Prefix operator applied to a term
       {pop @s for 1..2;
        push @s, new $l, $r;
        return 1;
       }
      if (!ref($r) and ref($l) and $r =~ m(\Aq))                                # Post fix operator applied to a term
       {pop @s for 1..2;
        push @s, new $r, $l;
        return 1;
       }
#     if (!ref($l) and !ref($r) and $l =~ m(\Ab) and $r =~ m(\As))              # Open semi-colon implies one intervening empty term
#      {pop @s for 1;
#       push @s, new 'empty2';
#       push @s, $r;
#       return 1;
#      }
#     if (!ref($l) and !ref($r) and $l =~ m(\As) and $r =~ m(\As))              # Semi-colon, semi-colon implies an empty term
#      {pop @s for 1;
#       push @s, new 'empty3';
#       push @s, $r;
#       return 1;
#      }
      if (!ref($l) and !ref($r) and $l =~ m(\As) and $r =~ m(\AB))              # Semi-colon, close implies remove unneeded semi
       {pop @s for 1..2;
        push @s, $r;
        return 1;
       }
     }
    if (@s >= 1)                                                                # Convert variable to term
     {my ($t) = reverse @s;
      if (!ref($t) and $t =~ m(\Av))                                            # Single variable
       {pop @s for 1;
        push @s, new $t;
        return 1;
       }
     }
    if (@s == 1)                                                                # Convert leading semi to empty, semi
     {my ($t) = @s;
      if (!ref($t) and $t =~ m(\As))                                            # Semi
       {@s = (new('empty4'), $t);
        return 1;
       }
     }
    undef                                                                       # No move made
   };

  for my $i(keys @expression)                                                   # Each input element
   {my $e = $expression[$i];
#   lll "AAAA $i $e\n", dump([@s]);

    my sub error($)                                                             # Write an error message
     {my ($m) = @_;                                                             # Error message
      confess "$m on $e at $i\n".dump([@s]). "\n";
     };

     if (!@s)                                                                   # Empty stack
     {error "Expression must start with a variable or open or a prefix operator or a semi"
        if !ref($e) and $e !~ m(\A(b|p|s|v));
      push @s, $e;
      term;
      next;
     }

    my $s = $s[-1];                                                             # Stack has data

    my sub type()                                                               # Type of the current stack top
     {return 't' if ref $s;                                                     # Term on top of stack
      substr($s, 0, 1);                                                         # Something other than a term defines its type by its first letter
     };

    my sub check($)                                                             # Check that the top of the stack has one of the specified elements
     {my ($types) = @_;                                                         # Possible types to match
      return 1 if index($types, type) > -1;                                     # Check type allowed
      confess qq(Expected one of "$types" on $e at $i\nBut got: $s\n);
     };

    my sub test($)                                                              # Check that the second item on the stack contains one of the expected items
     {my ($types) = @_;                                                         # Possible types to match
      return undef unless @s >= 2;                                              # Stack not deep enough so cannot contain any of the specified types
      my $s = ref($s[-2]) ? 't' : substr($s[-2], 0, 1);                         # Type is first character of element
      return 1 if index($types, $s) > -1;
      undef
     };

# a assign
# b open B close
# d dyad
# p prefix
# q suffix
# s semi-colon
# t term
# v variable

    if ($e =~ m(a))                                                             # Assign
     {check("Bqtv");
      1 while test("t");
      push @s, $e;
      next;
     }

    if ($e =~ m(b))                                                             # Open
     {check("abds");
      push @s, $e;
      next;
     }

    if ($e =~ m(B))                                                             # Closing parenthesis
     {check("abqstv");
      1 while term;
      push @s, $e;
      1 while term;
      check("bst");
      #pop @s;
     }

    if ($e =~ m(d))                                                             # Infix but not assign or semi-colon
     {check("Bqtv");
      1 while test("t");
      push @s, $e;
      next;
     }

    if ($e =~ m(p))                                                             # Prefix
     {check("abdps");
      push @s, $e;
      next;
     }

    if ($e =~ m(q))                                                             # Suffix
     {check("Bqtv");
      push @s, $e;
      term;
      next;
     }

    if ($e =~ m(s))                                                             # Semi colon
     {check("bBqstv");
      if ($s =~ m(\A(s|b)))                                                         # Insert an empty element between two consecutive semicolons
       {push @s, new 'empty5';
        1 while term;
       }
      1 while term;
      push @s, $e;
#     1 while term;
      next;
     }

    if ($e =~ m(v))                                                             # Variable
     {check("abdps");
      push @s, $e;
      term;
      1 while test("p") and term;
      next;
     }
   }

# lll "DDDD\n", dump([@s]);
  pop @s while @s > 1 and $s[-1] =~ m(s);                                       # Remove any trailing semi colons
  1 while term;                                                                 # Final reductions
# pop @s while @s > 1 and $s[-1] =~ m(s);

# lll "EEEE\n", dump([@s]);
  @s == 1 or confess "Incomplete expression";
  $s[0]
 } # parse

#D1 Print                                                                       # Print a parse tree to make it easy to visualize its structure.

sub depth($)                                                                    #P Depth of a term in an expression.
 {my ($term) = @_;                                                              # Term
  my $d = 0;
  for(my $t = $term; $t; $t = $t->up) {++$d}
  $d
 }

sub listTerms($)                                                                #P List the terms in an expression in post order
 {my ($expression) = @_;                                                        # Root term
  my @t;                                                                        # Terms

  sub                                                                           # Recurse through terms
   {my ($e) = @_;                                                               # Term
    my $o = $e->operands;
    return unless $e;                                                           # Operator
    if (my @o = $o ? grep {ref $_} @$o : ())                                    # Operands
     {my ($p, @p) = @o;
      __SUB__->($p);                                                            # First operand
      push @t, $e;                                                              # Operator
      __SUB__->($_) for @p;                                                     # Second and subsequent operands
     }
    else                                                                        # No operands
     {push @t, $e;                                                              # Operator
     }
   } ->($expression);
  @t
 }

sub flat($@)                                                                    # Print the terms in the expression as a tree from left right to make it easier to visualize the structure of the tree.
 {my ($expression, @title) = @_;                                                # Root term, optional title
  my @t = $expression->listTerms;                                               # Terms in expression in post order
  my @s;                                                                        # Print

  my sub align                                                                  # Align the ends of the lines
   {my $L = 0;                                                                  # Longest line
    for my $s(@s)
     {my $l = length $s; $L = $l if $l > $L;
     }

    for my $i(keys @s)                                                          # Pad to longest
     {my $s = $s[$i] =~ s/\s+\Z//rs;
      my $l = length($s);
      if ($l < $L)
       {my $p = ' ' x ($L - $l);
        $s[$i] = $s . $p;
       }
     }
   };

  for my $t(@t)                                                                 # Initialize output rectangle
   {$s[$_] //= '' for 0..$t->depth;
   }

  for my $t(@t)                                                                 # Traverse tree
   {my $d = $t->depth;
    my $p = $t->operator;                                                       # Operator

    align if $p =~ m(\A(a|d|s));                                                # Shift over for some components

    $s[$d] .= " $p";                                                            # Describe operator or operand
    align unless $p =~ m(\A(p|q|v));                                            # Vertical for some components
   }

  shift @s while @s and $s[ 0] =~ m(\A\s*\Z)s;                                  # Remove leading blank lines

  for my $i(keys @s)                                                            # Clean up trailing blanks so that tests are not affected by spurious white space mismatches
   {$s[$i] =~ s/\s+\n/\n/gs;
    $s[$i] =~ s/\s+\Z//gs;
   }

  unshift @s, join(' ', @title) if @title;                                      # Add title
  join "\n", @s, '';
 }

#D
#-------------------------------------------------------------------------------
# Export - eeee
#-------------------------------------------------------------------------------

use Exporter qw(import);

use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);

@ISA          = qw(Exporter);
@EXPORT       = qw();
@EXPORT_OK    = qw(
 );
%EXPORT_TAGS = (all=>[@EXPORT, @EXPORT_OK]);

# podDocumentation
=pod

=encoding utf-8

=head1 Name

Tree::Term - Create a parse tree from an array of terms representing an expression.

=head1 Synopsis

The expression to L<parse> is presented as an array of words, the first letter
of each word indicates its lexical role as in:

  my @e = qw(b b p2 p1 v1 q1 q2 B  d3 b p4 p3 v2 q3 q4  d4 p6 p5 v3 q5 q6 B s B s);

Where:

  a assign     - infix operator with priority 2 binding right to left
  b open       - open parenthesis
  B close      - close parenthesis
  d dyad       - infix operator with priority 3 binding left to right
  p prefix     - monadic prefix operator
  q suffix     - monadic suffix operator
  s semi-colon - infix operator with priority 1 binding left to right
  v variable   - a variable in the expression

The results of parsing the expression can be printed with L<flat> which
provides a left to right representation of the parse tree.

  is_deeply parse(@e)->flat, <<END;

      d3
   q2       d4
   q1    q4    q6
   p2    q3    q5
   p1    p4    p6
   v1    p3    p5
         v2    v3
END

=head1 Description

Create a parse tree from an array of terms representing an expression.


Version 20210629.


The following sections describe the methods in each functional area of this
module.  For an alphabetic listing of all methods by name see L<Index|/Index>.



=head1 Parse

Create a parse tree from an array of terms representing an expression.

=head2 parse(@expression)

Parse an expression.

     Parameter    Description
  1  @expression  Expression to parse

B<Example:>


  ok T [qw(b b p2 p1 v1 q1 q2 B  d3 b p4 p3 v2 q3 q4  d4 p6 p5 v3 q5 q6 B s B s)], <<END; 
      d3
   q2       d4
   q1    q4    q6
   p2    q3    q5
   p1    p4    p6
   v1    p3    p5
         v2    v3
  END
  

=head1 Print

Print a parse tree to make it easy to visualize its structure.

=head2 flat($expression, @title)

Print the terms in the expression as a tree from left right to make it easier to visualize the structure of the tree.

     Parameter    Description
  1  $expression  Root term
  2  @title       Optional title

B<Example:>


  ok T [qw(p2 p1 v1 q1 q2 d3 p4 p3 v2 q3 q4  d4 p6 p5 v3 q5 q6 s)], <<END;        
      d3
   q2       d4
   q1    q4    q6
   p2    q3    q5
   p1    p4    p6
   v1    p3    p5
         v2    v3
  END
  


=head1 Hash Definitions




=head2 Tree::Term Definition


Description of a term in the expression.




=head3 Output fields


=head4 operands

Operands to which the operator will be applied.

=head4 operator

Operator to be applied to one or more operands.

=head4 up

Parent term if this is a sub term.



=head1 Private Methods

=head2 new($operator, @operands)

New term.

     Parameter  Description
  1  $operator  Operator
  2  @operands  Operands.

=head2 depth($term)

Depth of a term in an expression.

     Parameter  Description
  1  $term      Term

=head2 listTerms($expression)

List the terms in an expression in post order

     Parameter    Description
  1  $expression  Root term


=head1 Index


1 L<depth|/depth> - Depth of a term in an expression.

2 L<flat|/flat> - Print the terms in the expression as a tree from left right to make it easier to visualize the structure of the tree.

3 L<listTerms|/listTerms> - List the terms in an expression in post order

4 L<new|/new> - New term.

5 L<parse|/parse> - Parse an expression.

=head1 Installation

This module is written in 100% Pure Perl and, thus, it is easy to read,
comprehend, use, modify and install via B<cpan>:

  sudo cpan install Tree::Term

=head1 Author

L<philiprbrenan@gmail.com|mailto:philiprbrenan@gmail.com>

L<http://www.appaapps.com|http://www.appaapps.com>

=head1 Copyright

Copyright (c) 2016-2021 Philip R Brenan.

This module is free software. It may be used, redistributed and/or modified
under the same terms as Perl itself.

=cut



# Tests and documentation

sub test
 {my $p = __PACKAGE__;
  binmode($_, ":utf8") for *STDOUT, *STDERR;
  return if eval "eof(${p}::DATA)";
  my $s = eval "join('', <${p}::DATA>)";
  $@ and die $@;
  eval $s;
  $@ and die $@;
  1
 }

test unless caller;

1;
# podDocumentation
__DATA__
use Time::HiRes qw(time);
use Test::More;

my $develop   = -e q(/home/phil/);                                              # Developing
my $log       = q(/home/phil/perl/cpan/TreeTerm/lib/Tree/zzz.txt);              # Log file
my $localTest = ((caller(1))[0]//'Tree::Term') eq "Tree::Term";                 # Local testing mode

Test::More->builder->output("/dev/null") if $localTest;                         # Reduce number of confirmation messages during testing

if ($^O =~ m(bsd|linux)i)                                                       # Supported systems
 {plan tests => 23;
 }
else
 {plan skip_all =>qq(Not supported on: $^O);
 }

sub T                                                                           #P Test a parse
 {my ($expression, $expected) = @_;                                             # Expression, expected result

  my $g = parse(@$expression)->flat;
  my $r = $g eq $expected;
  owf($log, $g) if -e $log;                                                     # Save result if testing
  confess "Failed test" unless $r;
  $r
 }

eval {goto latest};

ok T [qw(v1)], <<END;
 v1
END

ok T [qw(s)], <<END;
 empty4
END

ok T [qw(s s)], <<END;
        s
 empty4   empty5
END

ok T [qw(v1 d2 v3)], <<END;
    d2
 v1    v3
END

ok T [qw(v1 a2 v3)], <<END;
    a2
 v1    v3
END

ok T [qw(v1 a2 v3 d4 v5)], <<END;
    a2
 v1       d4
       v3    v5
END

ok T [qw(v1 a2 v3 d4 v5 s6 v8 a9 v10)], <<END;
                s6
    a2                a9
 v1       d4       v8    v10
       v3    v5
END

ok T [qw(v1 a2 v3 s s s  v4 a5 v6 s s)], <<END;
                                       s
                            s            empty5
                   s             a5
          s          empty5   v4    v6
    a2      empty5
 v1    v3
END

ok T [qw(b B)], <<END;
 empty1
END

ok T [qw(b b B B)], <<END;
 empty1
END

ok T [qw(b b v1 B B)], <<END;
 v1
END

ok T [qw(b b v1 a2 v3 B B)], <<END;
    a2
 v1    v3
END

ok T [qw(b b v1 a2 v3 d4 v5 B B)], <<END;
    a2
 v1       d4
       v3    v5
END

ok T [qw(p1 v1)], <<END;
 p1
 v1
END

ok T [qw(p2 p1 v1)], <<END;
 p2
 p1
 v1
END

ok T [qw(v1 q1)], <<END;
 q1
 v1
END

ok T [qw(v1 q1 q2)], <<END;
 q2
 q1
 v1
END

ok T [qw(p2 p1 v1 q1 q2)], <<END;
 q2
 q1
 p2
 p1
 v1
END

ok T [qw(p2 p1 v1 q1 q2 d3 p4 p3 v2 q3 q4)], <<END;
    d3
 q2    q4
 q1    q3
 p2    p4
 p1    p3
 v1    v2
END

ok T [qw(p2 p1 v1 q1 q2 d3 p4 p3 v2 q3 q4  d4 p6 p5 v3 q5 q6 s)], <<END;        #Tflat
    d3
 q2       d4
 q1    q4    q6
 p2    q3    q5
 p1    p4    p6
 v1    p3    p5
       v2    v3
END

ok T [qw(b s B)], <<END;
 empty5
END

ok T [qw(b s s B)], <<END;
        s
 empty5   empty5
END


ok T [qw(b b p2 p1 v1 q1 q2 B  d3 b p4 p3 v2 q3 q4  d4 p6 p5 v3 q5 q6 B s B s)], <<END; #Tparse
    d3
 q2       d4
 q1    q4    q6
 p2    q3    q5
 p1    p4    p6
 v1    p3    p5
       v2    v3
END
