parse

#!/usr/bin/env perl

# 2008-03-02, by Noah Smith, under the name cfgparse.pl, in cgw repository
# 2020-09-03, modified by Alexandra DeLucia and Jason Eisner:
#    * alter input flag handling and input format (now mostly matches old Dyna parse program)
#    * print xent
#    * fix bug with multiple-counting of inside probs
#    * minor refactoring
# 2020-09-15, modified by Arya D. McCarthy to support the count semiring
# 2020-09-17, modified by Jason Eisner to warn about unary-rule underestimates
#    (and to clarify comments: underestimation does not only affect cyclic cases)
# 2021-09-11, modified by Jason Eisner to fix a careless bug that was resulting in
#    parse count of 0 (h/t Brian Lu) and clean up a few minor things

# This script implements a probabilistic CKY parser.  It does the following:
#
# - loads a probabilistic CFG with root symbol ROOT
#   from a file that has one context-free rule per line, in the format
#        prob X Y ... Z      # representing the rule X -> Y ... Z
#   (the '#' symbol says that the rest of the line is a comment to be ignored)
#
# - renormalizes the probabilities so rules with the same left-hand
#   nonterminal sum to one
#
# - internally makes sure all rules are at most binary, transforming as needed
#
# - runs the CKY Viterbi algorithm on sentences read into STDIN
#   (one sentence per line, with whitespace separating words).
#   The input sentence may also include nonterminals as if they were words.
#
# - the CKY inside algorithm and parse-counting algorithm are run alongside
#   the CKY Viterbi algorithm
#
# - for each sentence, can write out the Viterbi derivation, its probability,
#   the inside probability of the sentence, the probability of the Viterbi
#   derivation given the sentence, and the number of parses.
#
# - This version of CKY has been extended to handle unary rules, but it
#   only uses them as necessary to find the Viterbi parse.  This means that
#   the unary rule closure for inside probabilities and counts *will* be
#   underestimated in the cyclic case and *may* be underestimated in the
#   acyclic case.  Potential underestimates are reported in the output
#   by printing inequality symbols.
#
# - This version of CKY does not handle epsilon rules (rules with empty
#   right-hand sides).

use IO::Handle;
STDOUT->autoflush();    # ensure that output reaches the user immediately

use Getopt::Std;
$Getopt::Std::STANDARD_HELP_VERSION = 1;
getopts('s:o:cPg:hv') || die;

if ($opt_h) {
    print <<'EOM';
Usage:  parse [options] [grammar_files...]

Sentences (one per line, whitespace separating words) are expected on stdin.
Parse trees will go to stdout (one per line).
Extra info as requested will go to stdout as comment lines starting with #.

The weighted rules of a probabilistic CFG are read from the grammar files.

Options:
  -s symbol   seek a parse tree with this symbol at the top (default ROOT)
  -o oov      convert unknown input words to the specified oov symbol
  -c          print number of grammatical parses
  -P          print probability information
  -g file     alternative way to specify a grammar file (for compatibility with another version)
  -v          verbose output
  -h          print this help message
EOM
    exit 0;
}
push @ARGV, $opt_g if defined $opt_g;
if ( @ARGV == 0 ) {
    print "No grammar files specified.\n";
    print "Use the -h option to get usage help.\n";
    exit 0;
}

# Process other options.
$ROOT_symbol = defined $opt_s ? $opt_s : "ROOT";
$OOV         = defined $opt_o;
$OOV_symbol  = $opt_o if $OOV;
$COUNT       = $opt_c;
$PROBS       = $opt_P;
$VERBOSE     = $opt_v;

# Read grammar files, transforming long rules into multiple binary rules.
while ( <> ) {
    s/\#.*//;           # remove comments
    next unless /\S/;   # skip blank lines
    die "Bad rule: $_" unless ( $p, $lhs, $rhs ) = (m/^\s*(\S+)\s+(\S+)\s*(.*?)\s*$/);
    die "invalid probability $p on line $. (must be positive)" unless $p > 0.0;

    @r = split /\s+/, $rhs;
    foreach $s (@r) { $Symbol{$s} = 1; }
    $Symbol{$lhs} = 1;
    if ( scalar(@r) == 0) {
      die "Rule with empty right-hand-side not currently supported: $_";
    }
    elsif ( scalar(@r) == 1 ) {
	$Unary{ $r[0] }{$lhs} += $p;
	$Tot{$lhs} += $p;
    }
    elsif ( scalar(@r) == 2 ) {
	$Binary{ $r[0] }{ $r[1] }{$lhs} += $p;
	$Tot{$lhs} += $p;
    }
    else {   # must binarize the rule
	$x = $r[-2] . "#" . $r[-1];
	$y = $r[-2];
	$z = $r[-1];
	for ( $i = scalar(@r) - 3 ; $i >= 0 ; --$i ) {
	    $Binary{$y}{$z}{$x} += 1.0;
	    $Tot{$x} += 1.0;
	    $z = $x;
	    $x = $r[$i] . "#" . $x;
	    $y = $r[$i];
	}
	$Binary{$y}{$z}{$lhs} += $p;
	$Tot{$lhs} += $p;
    }
}


# Index the rules for quick lookup.
foreach $y ( keys %Binary ) {
    foreach $x ( keys %{ $Binary{$y} } ) {
        foreach $z ( keys %{ $Binary{$y}{$x} } ) {
            $Binary{$y}{$x}{$z} = log( $Binary{$y}{$x}{$z} ) - log( $Tot{$z} );

            # print "$z -> $y $x $Binary{$y}{$x}{$z}\n";
        }
    }
}
foreach $y ( keys %Unary ) {
    foreach $x ( keys %{ $Unary{$y} } ) {
        $Unary{$y}{$x} = log( $Unary{$y}{$x} ) - log( $Tot{$x} );

        # print "$x -> $y $Unary{$y}{$x}\n";
    }
}

# Parse sentences from stdin.
$logprob = 0;
$logprob_underestimate = 0;
$words   = 0;
while (<>) {
    %C = ();   # log of Viterbi probability
    %B = ();   # backpointer for Viterbi parse
    %I = ();   # log of inside probability
    %N = ();   # count of parses (computed in parallel to inside probability)
    $underestimate = 0;  # will set to 1 if we ever have unpropagated inside probability / counts
    s/^\s*//;
    s/\s*$//;            # Remove leading and trailing spaces from sentence.
    @W = split /\s+/;    # Convert sentence (string) to list of words (strings).
    $n = scalar(@W);     # n is the number of words
    $words += $n;        # total number of words in corpus (for computing cross-entropy per word at the end)

    for ( $i = 0 ; $i < $n ; ++$i ) {   # initialize chart with words
        $w = $W[$i];
        unless ( defined $Symbol{$w} ) {
            if ($OOV) {
                $w = $OOV_symbol;
            }
            else {
                print STDERR "warning: input word \"$w\" is not in the grammar (consider using -o)\n";
            }
        }
        $C{$i}{ $i + 1 }{$w} = 0.0;  # Probability of the word is 1 (stored in log domain).
        $I{$i}{ $i + 1 }{$w} = 0.0;  # Inside probability of span is also 1 (stored in log domain).
        $N{$i}{ $i + 1 }{$w} = 1;    # Parse count of span is 1.
    }
    for ( $l = 1 ; $l <= $n ; ++$l ) {   # width l of constituents to build

        for ( $i = 0 ; $i <= $n - $l ; ++$i ) {   # start position i
            $k = $i + $l;                         # end position k

	    # Build using binary rules.
            for ( $j = $i + 1 ; $j < $k ; ++$j ) {  # midpoint j (with i < j < k)
                foreach $Y ( keys %{ $C{$i}{$j} } ) {   # left subconstituent Y from i to j
                    $q  = $C{$i}{$j}{$Y};
                    $qI = $I{$i}{$j}{$Y};
                    $qN = $N{$i}{$j}{$Y};
                    foreach $Z ( keys %{ $C{$j}{$k} } ) {   # right subconstituent Z from j to k
                        $r  = $C{$j}{$k}{$Z};
                        $rI = $I{$j}{$k}{$Z};
                        $rN = $N{$j}{$k}{$Z};
                        foreach $X ( keys %{ $Binary{$Y}{$Z} } ) {   # newly built constituent X from i to k
                            $p  = $Binary{$Y}{$Z}{$X} + $q + $r;
                            $pI = $Binary{$Y}{$Z}{$X} + $qI + $rI;
                            $pN = ($Binary{$Y}{$Z}{$X} != -inf) * $qN * $rN;
                            if ( !( defined $C{$i}{$k}{$X} )
                                or $p > $C{$i}{$k}{$X} )
                            {
                                $C{$i}{$k}{$X} = $p;
                                $B{$i}{$k}{$X} = "$Y\t$Z\t$j";
                                print "$i $k $X $p\n" if $VERBOSE;
                            }
                            $I{$i}{$k}{$X} = logadd( $I{$i}{$k}{$X}, $pI );
                            $N{$i}{$k}{$X} = $N{$i}{$k}{$X} + $pN;
                            print "$i $k $X ", $I{$i}{$k}{$X}, " (INSIDE)\n" if $VERBOSE;
                            print "$i $k $X ", $N{$i}{$k}{$X}, " (COUNT)\n" if $VERBOSE;
                        }
                    }
                }
            }

            # Handle unary rules, only propagating as long as the Viterbi parse changes.
	    # (It's inefficient to repeat this for every span ($i,$k) as we do here; almost
	    # all of the work is position-independent, and should be factored out and memoized.)
            %E       = ();
            %EN      = ();
            do {
                $changes = 0;
                foreach $Y ( keys %{ $I{$i}{$k} } ) {
		    # nonterminals $Y with positive unpropagated inside probability over span ($i,$k)
                    $q  = $C{$i}{$k}{$Y};
                    $qI = $I{$i}{$k}{$Y};
                    $qN = $N{$i}{$k}{$Y};
                    # move $Y's inside mass that we're about to propagate from $I to $E so we won't propagate it again on the next loop
                    $E{$Y} = logadd( $E{$Y}, $qI );
                    $EN{$Y}= $EN{$Y} + $qN;
                    delete $I{$i}{$k}{$Y};
                    delete $N{$i}{$k}{$Y};
		    # propagate from $Y to $X (the inside mass lands in $I so it can be propagated further on this loop or the next loop)
                    foreach $X ( keys %{ $Unary{$Y} } ) {
		        # nonterminals $X with unary rule $X -> $Y in the grammar
                        $p  = $Unary{$Y}{$X} + $q;
                        $pI = $Unary{$Y}{$X} + $qI;
                        $pN = $qN;
                        if ( !defined $C{$i}{$k}{$X} or $p > $C{$i}{$k}{$X} ) {
			    # better Viterbi parse
                            $C{$i}{$k}{$X} = $p;
                            $B{$i}{$k}{$X} = $Y;
                            ++$changes;
                            print "$i $k $X $p  (u)\n" if $VERBOSE;
                        }
                        $I{$i}{$k}{$X} = logadd( $I{$i}{$k}{$X}, $pI );
                        $N{$i}{$k}{$X} = $N{$i}{$k}{$X} + $pN;
                        print "$i $k $X ", $I{$i}{$k}{$X}, " (INSIDE; u)\n"
                          if $VERBOSE;
                        print "$i $k $X ", $N{$i}{$k}{$X}, " (COUNT; u)\n"
                          if $VERBOSE;
                    }
                }
            } while ( $changes > 0 );

            foreach $Y ( keys %{ $I{$i}{$k} } ) {
	        # We found a nonterminal $Y that still has unpropagated inside probability
	        # even now that the Viterbi parses have settled.
	        # Thus, we'll commit now to warning that the final overall sentence
	        # probability and counts may be underestimates (although they are
  	        # only underestimates if some such $Y actually appears in the final
	        # parse forest).
	        $underestimate = 1;
	      }

	    # Add all the propagated mass that we moved into $E back into $I.
            foreach $Y ( keys %E ) {
                $I{$i}{$k}{$Y} = logadd( $I{$i}{$k}{$Y}, $E{$Y} );
                $N{$i}{$k}{$Y} = $N{$i}{$k}{$Y} + $EN{$Y};
            }
        }
    }
    if ( defined $C{0}{$n}{$ROOT_symbol} ) {
        print backtrace( 0, $n, $ROOT_symbol, 0 ), "\n";
    }
    else {
        print "failure\n";
        $C{0}{$n}{$ROOT_symbol} = nan;
        $I{0}{$n}{$ROOT_symbol} = -inf;
        $N{0}{$n}{$ROOT_symbol} = 0;
    }

    if ( $COUNT ) {
	print "# number of parses",
	  $underestimate ? " >= " : " = ",
	  $N{0}{$n}{$ROOT_symbol},
	  $underestimate ? " (incomplete computation)\n" : "\n";
    }

    if ($PROBS) {
        printf(
	    $underestimate
               ? "# P(best_parse) = %3.3e\n# P(sentence) >= %3.3e (incomplete computation)\n# P(best_parse | sentence) <= %3.3f\n"
               : "# P(best_parse) = %3.3e\n# P(sentence) = %3.3e\n# P(best_parse | sentence) = %3.3f\n",
            exp( $C{0}{$n}{$ROOT_symbol} )
            , # different order than in the old Dyna parse program, but probably better
            exp( $I{0}{$n}{$ROOT_symbol} ),
            exp( $C{0}{$n}{$ROOT_symbol} - $I{0}{$n}{$ROOT_symbol} )
        );
        $logprob += $I{0}{$n}{$ROOT_symbol};
	$logprob_underestimate = 1 if $underestimate;
    }
}

if ($PROBS) {
    printf(
        "# cross-entropy %s %.3f bits = -(%.3f log-prob. / %d words)\n",
	$logprob_underestimate ? "<=" : "=",
        -$logprob / log(2) / $words,
        $logprob / log(2), $words
    );
}

sub backtrace {
    my $i      = shift;
    my $k      = shift;
    my $X      = shift;
    my $indent = shift;
    my $ret    = "";

    # print "bt($i, $k, $X)\n";
    my @l;
    $ret .= " ($X" unless ( $X =~ m/#/ );
    if ( $X eq $W[$i] or $X eq $OOV_symbol ) {
        return " " . $W[$i];
    }
    else {
        die "backtrace error ($i, $k, $X)" unless ( defined $B{$i}{$k}{$X} );
        @l = split /\t/, $B{$i}{$k}{$X};
        if ( scalar(@l) == 1 ) {
            $ret .= backtrace( $i, $k, $l[0], $indent + 2 );
        }
        else {
            $ret .= backtrace( $i,    $l[2], $l[0], $indent + 2 );
            $ret .= backtrace( $l[2], $k,    $l[1], $indent + 2 );
        }
    }
    $ret .= ")" unless ( $X =~ m/#/ );
    return $ret;
}

sub logadd {
    my $lx = shift;
    my $ly = shift;
    if ( !defined $lx || $lx eq '-inf' ) { return $ly; }
    if ( !defined $ly || $ly eq '-inf' ) { return $lx; }
    my $d = $lx - $ly;
    if ( $d >= 0.0 ) {
        return $lx if ( $d > 745 );
        return $lx + log( 1.0 + exp( -$d ) );
    }
    else {
        return $ly if ( $d < -745 );
        return $ly + log( 1.0 + exp($d) );
    }
}