#!/usr/bin/perl

# Tree Program v.1.0.3
# Copyright (C) 1999-2001 Matt Chisholm - matt@theory.org
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307 USA

# March 5, 2000 1.0.1
# made latextenv package
# deleted many global config vars
# I really need a way to get correct character widths

# May 2, 2000 1.0.2
# added OPAREN, CPAREN to use alternate open and close parens

# February 13, 2001 1.0.3
# if (( $ALIGNED ) and ( $tree->{depth} == 1 )) { $y = 0 }
# becomes 
# if (( $ALIGNED ) and ( $tree->{depth} == 1 )) { $y = $LATEXTENV->{letterheight}; }
# to fix alignment problems.
# No longer runs gv on output file. 

use strict;
use vars qw( $HEIGHT $ALIGNED $BOXES $BREAKS $TRIANGLES $HEADBAL $XBAR $LINESTYLE $LATEXTENV $PREVIEW $OPAREN $CPAREN);

# ------------------------------------------------ #
#     D e F a U l T   c O n F i G u R a T i O n    #
# ------------------------------------------------ #

sub resetvars {
  $ALIGNED = $BOXES = 0; 
  $HEADBAL = $BREAKS = $TRIANGLES = $XBAR = 1;
  $LINESTYLE = \&line; #ref to line drawing fcn
  $LATEXTENV = undef;
  $OPAREN = quotemeta( "(" );
  $CPAREN = quotemeta( ")" );
}
# ------------------------------------------------ #

if ($ARGV[0] =~ m/^\-+h(elp)*$/ ) { &help; } 
&resetvars();

my (@filelist, @clargs); 
map { 
  if ( $_ =~ m/^\-(.+)/ ) { 
    push @clargs, $1;
  } else {
    push @filelist, $_;
  }
} @ARGV;

readargs( \@clargs ); 

map { &main($_) } @filelist;

sub main {
  my $infile  = shift();
  ( my $outfile = $infile ) =~ s/^(.+)\.tex$/\1_tree/;
  my ($args, $tree);
  print $outfile; 
  open INFILE,  $infile; 
  open OUTFILE, ">$outfile.tex";
  foreach (<INFILE>) { 
    if (m/^\%\#tree\:(.*)$/) {
      if ($args) {
	chomp( $tree = $1 );
	&readvars( $args ); 
	print OUTFILE &maketree( $tree );
	undef $args, $tree;
      } else {
	chomp( $args = $1 ); 
      }
    } else {
      print OUTFILE $_; 
    }
  }
  close OUTFILE;
  close INFILE; 
  # now take a look: 
  if ($PREVIEW){
    system( "latex $outfile.tex" );
    system( "dvips $outfile.dvi -o $outfile.ps" );
#    system( "gv -antialias $outfile.ps" );
#    system( "mv $outfile.dvi $outfile.ps $outfile.log $outfile.aux /tmp/" );
  }
}

# ----------------------------- #
#     S u B r O u T i N e S     #
# ----------------------------- #

# reads command line arguments
sub readargs {
  my @args = @{ shift() };
  #set default values
  $PREVIEW = 1; 
  #read arguments 
  map { 
    $PREVIEW = 0 if ( $_ eq 'P' );
    $PREVIEW = 1 if ( $_ eq 'p' );
  } (@args);
}

# makes tree
sub maketree{
  my $string = shift; 
  my $tree = parse_string( $string ); 
  if (!(defined $tree)) { 
    print "Malformed tree \"$string\".\n";
    exit;
  }
  my $height = $LATEXTENV->{letterheight} * $tree->{depth} * 2 - 1; 
  my $width  = $tree->{width};

  $HEIGHT = $height;  
  offset( $tree );

  return "\\begin{picture}($width,$height)(0,0)\n" . 
    &latex( $tree, 0, $height - $LATEXTENV->{letterheight} ) . 
#      (($BOXES)?"\\put(0,0){\\framebox($width,$height){}}":"").
	"\\end{picture}\n"; 
}

# makes the latex
sub latex{
  my ( $tree, $x, $y ) = @_;
  my $width = $tree->{width}; 
  my $return; 

#  print "\n\n>>>>>", $LATEXTENV->{pretext}, $LATEXTENV->{posttext}, $LATEXTENV->{premath}, $LATEXTENV->{postmath}, "\n";

  # put all terminal children along the bottom?
  if (( $ALIGNED ) and ( $tree->{depth} == 1 )) { $y = $LATEXTENV->{letterheight}; }

  #draw the text for this node
  $return .= "\\put($x,$y){\\framebox($width, " . $LATEXTENV->{letterheight} . "){}}\n" if ($BOXES);
  $return .= "\\put(".($tree->{offset}+$x).", $y){\\makebox(0,".$LATEXTENV->{letterheight}."){" . $LATEXTENV->{pretext} . $tree->shorthand() . $LATEXTENV->{posttext} . "}}\n";

  # draw the break line
  if ( $BREAKS ) {
    $return .= &line( $x+$width, 0, $x+$width, $HEIGHT ) if ($tree->{aft});
    $return .= &line( $x, 0, $x, $HEIGHT ) if ($tree->{fore}); 
  }

  # now draw the children
  $y -= $LATEXTENV->{letterheight} * 2;
  my $nx = $x;


  foreach ( @{$tree->{children}}) { 
    my $ny = $y;
    
    # draw the parts for the kiddies
    $return .= latex( $_, $nx, $y );
    
    # put all terminal nodes along the bottom?
    if (( $ALIGNED ) and ( $_->{depth} == 1 )) { $ny = $LATEXTENV->{letterheight}; } 
    
    # draw lines or triangles to children
    if ($tree->{triangle}) {

    } elsif (( $TRIANGLES ) and                       # we are drawing triangles
	( $_->{depth} == 1 ) and                 # this poor node is childless
	( scalar @{$tree->{children}} == 1 ) and # it's an only child too
	( $_->{content} =~ /\s/ )) {             # it's child's name contains whitespace
      $return .= &triangle( $tree->{offset}+$x, $y+$LATEXTENV->{letterheight}*2, # draw triangle
			    $nx +6, $ny+$LATEXTENV->{letterheight},
			    $nx+$_->{width}-6 , $ny+$LATEXTENV->{letterheight} );
    } else {
      # draw line to each child
      $return .= &{$LINESTYLE}( $tree->{offset}+$x, $y+$LATEXTENV->{letterheight}*2 , 
				$nx+$_->{offset}, $ny+$LATEXTENV->{letterheight} );
    }
    $nx += $_->{width}; 
  }

  if (($#{$tree->{children}} > 0) and ($tree->{triangle})) {
    my $lchild = $tree->{children}->[0];
    my $rchild = $tree->{children}->[-1];
    my $lx = (length($lchild->{content}) > 3 )? ($x) : ($x+$rchild->{offset});
    my $rx = (length($rchild->{content}) > 3 )? ($tree->{width}+$x) : ($nx-$rchild->{width}+$rchild->{offset});
    $return .= &triangle( $tree->{offset}+$x, $y+$LATEXTENV->{letterheight}*2,
			  $lx, $y+$LATEXTENV->{letterheight},
			  $rx, $y+$LATEXTENV->{letterheight}
			);
  } 
  
  return $return;
}

# sets offsets
sub offset{
  my $tree = shift;
  my $offset; 
  my $width = $tree->{width};    # for speed of typing
  my $kids  = $tree->{children};
  my $phrase = ''; 
  my $headed = ''; 

  # recurse - calculate children's offsets
  map { offset( $_ ) } ( @{$kids} );

  # set offsets
  if ( $#{ $kids } >= 1 ) {         #many children
    $offset = $kids->[0]->{offset} + $width - $kids->[-1]->{width} + $kids->[-1]->{offset}; 
    $offset /= 2;
  } elsif ( $#{ $kids } == 0 ) {    #one child
    my $kid = $kids->[0];
    if ( $width > $kid->{width} ) { # seldom true: example: Art.(a) 
      $offset = $width / 2;
      while ( $kid ) {              # if all children are smaller than parent
	$kid->{offset} = $offset;   
	$kid = $kid->{children}->[0];
      }
    } else {                        # children larger than parent
      $offset = $kid->{offset}; 
    }
  } else { # no children
    $offset = $width/2;
  }

  # Xbar - head balancing  
  if ( $HEADBAL )  {
    # adjuncts 
#    if ( $#{$kids} == 1 ) {
#      if ($kids->[0]->{content} eq $tree->{content}) {
#	$offset = $kids->[0]->{offset};
#      } elsif ( $kids->[1]->{content} eq $tree->{content} ) {
#	$offset = $kids->[1]->{offset} + $kids->[0]->{width};
#      }
#    }
    # heads
    if ( my $next = &head( $tree->{content} ) ) { 
      my $width = 0; 
      map { 
	if ( $_->{content} =~ /^$next$/ ) { $offset = $_->{offset} + $width; }
	else { $width += $_->{width}; } } ( @{$kids} );
    }  
  }

  $tree->{offset} = $offset;
}

# --------------------------------- #
#      L i N e   D r A w I n G      #
# --------------------------------- #

sub qbez    { "\\qbezier($_[0],$_[1])($_[2],$_[3])($_[4],$_[5])\n" } 

sub avg     { ( $_[0]  + $_[1] ) / 2 } 

sub line    { qbez( @_[0..1], avg( $_[0], $_[2] ), avg( $_[1], $_[3] ), @_[2..3] )}

sub path    { return &mondrian( @_ ); }

sub convex  { return &qbez( @_[0..1], $_[0], $_[3], @_[2..3] ); }

sub concave { return &qbez( @_[0..1], $_[2], $_[1], @_[2..3] ); }

sub square  {
  if ( $_[0] != $_[2] ) {
    my $i = $_[1]-$LATEXTENV->{letterheight}/2; 
    return &line(@_[0..1],$_[0],$i).&line($_[0],$i,$_[2],$i).&line($_[2],$i,@_[2..3]);
  } else { return &line( @_ ); }
}

sub mondrian{
  my $Y = avg( $_[1], $_[3] );
  return ( $_[0] != $_[2] ) ? &line( $_[0], $Y, $_[2], $Y ) : &line( @_ );
}

sub curly   {
  if ( $_[0] != $_[2] ) {
    my $Y = $_[1]-$LATEXTENV->{letterheight}/2;
    my $i = $LATEXTENV->{letterheight}/2*($_[2]<=>$_[0]); 
    return qbez( @_[0..1], $_[0], $Y, $_[0]+$i, $Y) . 
      line( $_[0]+$i, $Y, $_[2]+$i*(-1), $Y ) . 
	qbez( $_[2]+$i*(-1), $Y, $_[2], $Y,  @_[2..3] );
  } else { 
    return &line( @_ );
  }
}

sub triangle{ &line(@_[0..3]).&line(@_[2..5]).&line(@_[0..1], @_[4..5]) }

# ----------------------- #
#       P a R s E r       #
# ----------------------- #

sub parse_string {
  my @string = split //, shift;
  my @stack = (); 
  my $tmp;
  my $break;
  foreach ( @string ) {
    if ( /$OPAREN/ or /$CPAREN/ or /\|/ or /,/ ) {    # special characters
      if ( defined $tmp ) {
	$tmp =~ s/\s*$//o;                  # ignore whitespace after a node
	push @stack, Node->new( $tmp );
	undef $tmp;	
	if ( $break == -1 ) {               # the vertical break line
	  $stack[-1]->{fore} = 1;
	  undef $break;
	}
      } # else { print "\$tmp undefined on string \"$_\"\n"; }
      # begin character dependent stuff
      if ( /$OPAREN/ ) {                         # opening paren
	push @stack, $_; 
      } elsif ( /$CPAREN/ ) {                    # close paren == a reduce
	if ($#stack <= 0) { 
	  print "Syntax error near \"", $_, "\" \n";  
	  return undef; 
	}
	my @children = ();                  # array of children
	my $here = pop @stack;
	while ( ref( $here ) eq "Node" ) {
	  push @children, $here;
	  $here = pop @stack;               # this also pops off the open paren
	}
	$stack[-1]->add_children( reverse @children );
      } elsif ( /\|/ ) {                    # the vertical break line 
	if ( ref ( $stack[-1] ) eq "Node" ) {
	  $stack[-1]->{aft} = 1;
	} else {
	  $break = -1;
	}
      }
    } else {                                # all other characters
      $tmp .= $_ unless ( !$tmp and /\ / ); # don't start a node with whitespace
    }
  }
  if ($#stack > 0) { 
    print "Syntax error near \"", @stack[-1]->{content}, "\"\n"; 
    return undef; 
  } else {
    return $stack[0];
  }
}

# --------------------------------------------------- #
#     C o N f I g U r A b L e   F u N c T i O n S     #
# --------------------------------------------------- #

# return next headlevel
sub head {
  local $_ = shift;
  return ( $1."\'" ) if ( /^(A|N|P|V|C|I|T|S|D|Neg)P$/ ) ;
  return ( $1 )      if ( /^(A|N|P|V|C|I|T|S|D|Neg)\'$/ ) ;
  return ( "Poss" )  if ( /^PossP$/ ) ;
  return 0;
}

# read variables from tree line
sub readvars {
  my $args = shift;
  &resetvars;#       if ( $args =~ m/-r/ ); # reset variables to default values
  $ALIGNED   = 1    if ( $args =~ m/-a/ ); # align nodes along the bottom
  $BOXES     = 1    if ( $args =~ m/-box/ ); # draw with layout boxes  
  $BREAKS    = 0    if ( $args =~ m/-breaks/ ); # turn breaks off

  $TRIANGLES = 1    if ( $args =~ m/-t/ ); # triangles on
  $TRIANGLES = 0    if ( $args =~ m/-T/ ); # triangles off

  $PREVIEW   = 1    if ( $args =~ m/-p/ ); # preview on
  $PREVIEW   = 0    if ( $args =~ m/-P/ ); # preview off

  $HEADBAL   = 0    if ( $args =~ m/-H/ ); # head balancing off
  $HEADBAL   = 1    if ( $args =~ m/-h/ ); # head balancing on 

  $XBAR      = 1    if ( $args =~ m/-x\=bar/ );
  $XBAR      = 0    if ( $args =~ m/-x\=prime/ );

  ($OPAREN, $CPAREN) = (quotemeta($1), quotemeta($2)) if ( $args =~ m/-paren=(.{1})(.{1})/ ); 

  my $fcn = \&{$1}  if ( $args =~ m/\-line\=(\w+)/ ); # linestyle
  $LINESTYLE = $fcn if ( defined &{$fcn} );

  #set up LaTeXtenv
  my $stylestring = '';
  $stylestring = $1 if ( $args =~ /-style=([^\s]+)/ ); 
  my $fontsize = 5;
  $fontsize = $1-1 if ( $args =~ m/-f\s*(\d+)/ ); # $1 == 1..10 
  my $letterheight = undef;
  $letterheight = $1 if ($args =~ m/-l\s*(\d+)/ );

  $LATEXTENV = new LaTeXtenv( $fontsize, $stylestring, $letterheight );
}

sub help {
  print "Usage:
tree.pl file.tex
--------------------------------------------------------------------------------
Syntax in file: 
%#tree: [tree specific arguments]
%#tree: S(NP(D(the), N(program)), VP(V(ate), NP(PosP(my), N(homework)) ) )
--------------------------------------------------------------------------------
Tree specific arguments: 
-a        align terminal nodes along bottom
-box      draw layout boxes (for debugging layout algorithm)
-breaks   turn vertical break lines for transformations off
-f[1-10]  font size 1-10
-h        turn head balancing on (X-bar theory, see below) 
-H        turn head balancing off 
-l[1-10]  line size 1-10
-line=    linestyle: line, convex, concave, curly, square, mondrian 
-r        reset all config variables for this tree 
-style=   text style: bf, it, tt, sf 
-t        turn triangles on
-T        turn triangles off
-x=bar    X' -> \overline{X} ( see X' shorthand below )
-x=prime  X' -> X\'
--------------------------------------------------------------------------------
Shorthand:
S(\\d)     -> S_\\d
NP(i|j|k) -> NP_(i|j|k)
Va        -> V_Aux
VPb       -> VP_Bare
VPe       -> VP_EN
VPi       -> VP_ING
X'        -> \overline{X} or X\' ( depending on -x option above )
0         -> \emptyset
[+f1\+f2] -> _[\begin{array}{c}+f1\\+f2\end{array}]
--------------------------------------------------------------------------------
Head Balancing:
XP(X'(X(...))) structures headed by A, C, I, N, P, T, and V are head-balanced.
XP is placed directly above X' and X' directly above X. 
";
  exit;
}

# ----------------------------- #
#     N o D e   o B j E c T     #
# ----------------------------- #

package Node;

sub new {
  my $pkg = shift;
  my $content = shift;
  my $parent = undef;
  my @children = ();
  my $width = 0;      
  my $offset = 0; # points to the right of the start pos'n to draw words
  my $depth = 1;  # depth from this node down
  my $fore = 0;   # break line before this node
  my $aft  = 0;   # break line after this node
  my @features = ();
  my $triangle = 0; 
  
  $content =~ s/(\^)$//o;
  if ($1) {$triangle = 1}
  
  $content =~ s/(.*)\[(.+)\]$/\1/;
  if ( $2 ) { @features = split /\\/, $2; $width+=3;}

  $width++ while ( $content =~ m/[a-z0-9\-\+\.\>\ ]/go );      # smaller characters
  $width+=1.5 while ( $content =~ m/[A-Z\_\!\`\^]/go );            # larger characters

#  $width+= [reverse sort (grep {length} @features)]->[0];
  $width*= $::LATEXTENV->{letterwidth}; # multiply by guessed avg letter width

  $content =~ s/\ /\\\ /go;

  bless { 
	 content  => $content, 
	 parent   => $parent, 
	 children => \@children, 
	 width    => $width,
	 offset   => $offset,
	 depth    => $depth,
	 fore     => $fore,
	 aft      => $aft,
	 features => \@features,
	 triangle => $triangle,
	}, $pkg;
}

sub add_children{ 
  my $self = shift; 
  my $width = 0;
  foreach ( @_ ) { 
    push @{$self->{children}}, $_;
    $_->{parent} = $self;
    $self->{depth} = $_->{depth} + 1 if ( $self->{depth} < $_->{depth} + 1 );
    $width += $_->{width};
  }  
  $self->{width} = $width if ( $width > $self->{width} );  
}

sub shorthand {
  my $self = shift;
  local $_ = $self->{content};

  s/^S(\d)$/S\$_\1\$/;
  s/^N(P|\')(i|j|k)$/N$1\$_\2\$/;
  s/^Va$/V\$_\{AUX\}\$/;
  s/^VPb$/VP\$_\{Bare\}\$/;
  s/^VPe$/VP\$_\{EN\}\$/;
  s/^VPi$/VP\$_\{ING\}\$/;
  s/^0$/\$\\emptyset\$/; 
  s/^e$/\\emph\{e\}/;
  s/^\_p$/\\emph\{\\_\$\_\{p\}\$\}/;

  #logical crap
  s/\^/\$\\wedge\$/g;
  s/\-\>/\$\\rightarrow\$/g;
  s/\!/\$\\neg\$/g;
  s/`/\$\\vee\$/g;

  if ($main::XBAR) { 
    my $pre  = $main::LATEXTENV->{premath};
    my $post = $main::LATEXTENV->{postmath};
    s/^([A-Z])\'/\$$pre\\overline\{\1\}$post\$/; } 
  else { s/^([A-Z])\'/\1\$\'\$/; }

  if ( $#{$self->{features}} > 0 ) {
    $_ .= "\$_{\\left[\\begin{array}{lr}\\scriptscriptstyle" .
	join("\\\\\\scriptscriptstyle",@{$self->{features}}) . 
	  "\\end{array}\\right]}\$"; 
  } elsif ( ${$self->{features}}[0] ) {
    $_ .= "\$_{\\scriptscriptstyle\\left[\\scriptscriptstyle".@{$self->{features}}[0]."\\right]}\$"; 
  }

  return $_; 
}

package LaTeXtenv; 
# latex text environment: contains font size, line height, typeface info, and whatnot for whole tree

sub new {
  my $pkg = shift;
  my $fontsize = shift;
  my @typestyles = split /,/, shift; 
  if ($#typestyles == -1) { push @typestyles, "rm";} #sometimes necessary for math mode 

  my $user_defined_letter_height = shift;

  my $sizecommand  = "\\".[qw( tiny scriptsize footnotesize small normalsize large Large LARGE huge Huge )]->[$fontsize]. " "; # LaTeX size name
  my $letterwidth  = [qw( 4.5 5 5.5 6  7.5 8.5 9  11 12.5 15.5 )]->[$fontsize];  # average letter width
  my $letterheight = [qw( 7   8 9   10 11  12  14 18 24   28   )]->[$fontsize]; # default line height

  $letterheight = $user_defined_letter_height if (defined $user_defined_letter_height) ;

  my $pretext = "$sizecommand";
  my ( $posttext, $premath, $postmath );
  map { 
    $pretext .= "\\text$_\{"; 
    $premath .= "\\math$_\{";
    $posttext .= "\}"; 
    $postmath .= "\}";
  } @typestyles;

  bless { 
	 pretext  => $pretext,
	 posttext => $posttext,
	 premath  => $premath,
	 postmath => $postmath,
	 sizecommand  => $sizecommand,
	 letterwidth  => $letterwidth,
	 letterheight => $letterheight,
	}, $pkg; 
}
 
#sub height {
#  my $self = shift; 
#  return $self->{letterheight}->[$self->{fontsize}]; 
#}

#sub width {
#  my $self = shift; 
#  return $self->{letterwidth}->[$self->{fontsize}]; 
#}

#sub style {
#  my $self = shift; 
#  return $self->{letterwidth}->[$self->{fontsize}]; 
#}