path: root/ipl/procs/ichartp.icn

############################################################################
#
#	File:     ichartp.icn
#
#	Subject:  Procedures for a simple chart parser
#
#	Author:   Richard L. Goerwitz
#
#	Date:	  August 3, 2000
#
############################################################################
#
#   This file is in the public domain.
#
############################################################################
#
#	Version:  1.11
#
############################################################################
#
#  General:
#
#      Ichartp implements a simple chart parser - a slow but
#  easy-to-implement strategy for parsing context free grammars (it
#  has a cubic worst-case time factor).  Chart parsers are flexible
#  enough to handle a lot of natural language constructs.  They also
#  lack many of the troubles associated with empty and left-recursive
#  derivations.  To obtain a parse, just create a BNF file, obtain a
#  line of input, and then invoke parse_sentence(sentence,
#  bnf_filename, start-symbol).  Parse_sentence suspends successive
#  edge structures corresponding to possible parses of the input
#  sentence.  There is a routine called edge_2_tree() that converts
#  these edges to a more standard form.  See the stub main() procedure
#  for an example of how to make use of all these facilities.
#
############################################################################
#
#  Implementation details:
#
#      The parser itself operates in bottom-up fashion, but it might
#  just as well have been coded top-down, or for that matter as a
#  combination bottom-up/top-down parser (chart parsers don't care).
#  The parser operates in breadth-first fashion, rather than walking
#  through each alternative until it is exhausted.  As a result, there
#  tends to be a pregnant pause before any results appear, but when
#  they appear they come out in rapid succession.  To use a depth-first
#  strategy, just change the "put" in "put(ch.active, new_e)" to read
#  "push."  I haven't tried to do this, but it should be that simple
#  to implement.
#      BNFs are specified using the same notation used in Griswold &
#  Griswold, and as described in the IPL program "pargen.icn," with
#  the following difference:  All metacharacters (space, tab, vertical
#  slash, right/left parends, brackets and angle brackets) are
#  converted to literals by prepending a backslash.  Comments can be
#  include along with BNFs using the same notation as for Icon code
#  (i.e. #-sign).
#
############################################################################
#
#  Gotchas:
#
#      Pitfalls to be aware of include things like <L> ::= <L> | ha |
#  () (a weak attempt at a laugh recognizer).  This grammar will
#  accept "ha," "ha ha," etc. but will suspend an infinite number of
#  possible parses.  The right way to do this sort of thing is <L> ::=
#  ha <S> | ha, or if you really insist on having the empty string as
#  a possibility, try things like:
#
#          <S>      ::= () | <LAUGHS>
#          <LAUGHS> ::= ha <LAUGHS> | ha
#
#  Of course, the whole problem of infinite parses can be avoided by
#  simply invoking the parser in a context where it is not going to
#  be resumed, or else one in which it will be resumed a finite number
#  of times.
#
############################################################################
#
#  Motivation:
#
#      I was reading Byte Magazine (vol. 17:2 [February, 1992]), and
#  ran into an article entitled "A Natural Solution" (pages 237-244)
#  in which a standard chart parser was described in terms of its C++
#  implementation.  The author remarked at how his optimizations made
#  it possible to parse a 14-word sentence in only 32 seconds (versus
#  146 for a straight Gazdar-Mellish LISP chart parser).  32 seconds
#  struck me as hardly anything to write home about, so I coded up a
#  quick system in Icon to see how it compared.  This library is the
#  result.
#      I'm quite sure that this code could be very much improved upon.
#  As it stands, its performance seems as good as the C++ parser in
#  BYTE, if not better.  It's hard to tell, though, seeing as I have
#  no idea what hardware the guy was using.  I'd guess a 386 running
#  DOS.  On a 386 running Xenix the Icon version beats the BYTE times
#  by a factor of about four.  The Icon compiler creates an executable
#  that (in the above environment) parses 14-15 word sentences in
#  anywhere from 6 to 8 seconds.  Once the BNF file is read, it does
#  short sentences in a second or two.  If I get around to writing it,
#  I'll probably use the code here as the basic parsing engine for an
#  adventure game my son wants me to write.
#
############################################################################
#
#  Links: trees, rewrap, scan, strip, stripcom, strings
#
############################################################################
#
#  Requires:  co-expressions
#
############################################################################
#
#       Here's a sample BNF file (taken, modified, from the BYTE
#  Magazine article mentioned above).  Note again the conventions a)
#  that nonterminals be enclosed in angle brackets & b) that overlong
#  lines be continued by terminating the preceding line with a
#  backslash.  Although not illustrated below, the metacharacters <,
#  >, (, ), and | can all be escaped (i.e. can all have their special
#  meaning neutralized) with a backslash (e.g. \<).  Comments can also
#  be included using the Icon #-notation.  Empty symbols are illegal,
#  so if you want to specify a zero-derivation, use "()."  There is an
#  example of this usage below.
#
#  <S>    ::= <NP> <VP> | <S> <CONJ> <S>
#  <VP>   ::= <VP> <CONJ> <VP> | <IV> ( () | <PP> ) | \
#  	   <TV> ( <NP> | <NP> <PP> | <NP> <VP> | <REL> <S> )
#  <NP>   ::= <DET> ( <NP> | <ADJ> <NP> | <ADJ> <NP> <PP> | <NP> <PP> ) | \
#  	   <ADJ> <NP> | <N> | <N> <CONJ> <N> | \
#  	   <NP> <CONJ> <NP>
#  <PP>   ::= <P> ( <NP> | <ADJ> <NP> ) | <PP> <CONJ> <PP>
#  <ADJ>  ::= <ADJ> <CONJ> <ADJ>
#  <CONJ> ::= and
#  <DET>  ::= the | a | his | her
#  <NP>   ::= her | he | they
#  <N>    ::= nurse | nurses | book | books | travel | arrow | arrows | \
#  	  fortune | fortunes | report
#  <ADJ>  ::= outrageous | silly | blue | green | heavy | white | red | \
#  	  black | yellow
#  <IV>   ::= travel | travels | report | see | suffer
#  <TV>   ::= hear | see | suffer
#  <P>    ::= on | of
#  <REL>  ::= that
#
############################################################################
#
#  Addendum:
#
#      Sometimes, when writing BNFs, one finds oneself repeatedly
#  writing the same things.  In efforts to help eliminate the need for
#  doing this, I've written a simple macro facility.  It involves one
#  reserved word:  "define."  Just make sure it begins a line.  It
#  takes two arguments.  The first is the macro.  The second is its
#  expansion.  The first argument must not contain any spaces.  The
#  second, however, may.  Here's an example:
#
#      define <silluq-clause>    (   <silluq-phrase> | \
#                                    <tifcha-silluq-clause> | \
#                                    <zaqef-silluq-clause> \
#                                )
#
############################################################################

link trees
link scan
link rewrap
link strip
link stripcom
link strings

record stats(edge_list, lhs_table, term_set)
record chart(inactive, active)               # inactive - set; active - list
record retval(no, item)

record edge(LHS, RHS, LEN, DONE, BEG, END, SEEN)
record short_edge(LHS, RHS)

#
# For debugging only.
#
procedure main(a)

    local res, filename, line
    # &trace := -1
    filename := \a[1] | "bnfs.byte"
    while line := read(&input) do {
	res := &null
        every res := parse_sentence(line, filename, "S") do {
            if res.no = 0 then
	        write(stree(edge2tree(res.item)))
#	        write(ximage(res.item))
	    else if res.no = 1 then {
		write("hmmm")
		write(stree(edge2tree(res.item)))
	    }
        }
	/res & write("can't parse ",line)
    }

end


#
# parse_sentence:  string x string -> edge records
#                  (s, filename) -> Es
#     where s is a chunk of text presumed to constitute a sentence
#     where filename is the name of a grammar file containing BNFs
#     where Es are edge records containing possible parses of s
#
procedure parse_sentence(s, filename, start_symbol)

    local file, e, i, elist, ltbl, tset, ch, tokens, st, 
        memb, new_e, token_set, none_found, active_modified
    static master, old_filename
    initial master := table()

    #
    # Initialize and store stats for filename (if not already stored).
    #
    if not (filename == \old_filename) then {
        file := open(filename, "r") | p_err(filename, 7)
        #
        # Read BNFs from file; turn them into edge structs, and
        # store them all in a list; insert terminal symbols into a set.
        #
        elist := list(); ltbl := table(); tset := set()
        every e := bnf_file_2_edges(file) do {
            put(elist, e)                      # main edge list (active)
            (/ltbl[e.LHS] := set([e])) | insert(ltbl[e.LHS], e) # index LHSs
            every i := 1 to e.LEN do           # LEN holds length of e.RHS
                if /e.RHS[i].RHS then          # RHS for terminals is null
                    insert(tset, e.RHS[i].LHS)
        }
        insert(master, filename, stats(elist, ltbl, tset))
        old_filename := filename
        close(file)
    }
    elist := fullcopy(master[filename].edge_list)
    ltbl  := fullcopy(master[filename].lhs_table)
    tset  := master[filename].term_set
    
    #
    # Make edge list into the active section of chart; tokenize the
    # sentence s & check for unrecognized terminals.
    #
    ch := chart(set(), elist)
    tokens := tokenize(s)

    #
    # Begin parse by entering all tokens in s into the inactive set
    # in the chart as edges with no RHS (a NULL RHS is characteristic
    # of all terminals).
    #
    token_set := set(tokens)
    every i := 1 to *tokens do {
        # Flag words not in the grammar as errors.
        if not member(tset, tokens[i]) then
            suspend retval(1, tokens[i])
        # Now, give us an inactive edge corresponding to word i.
        insert(ch.inactive, e := edge(tokens[i], &null, 1, 1, i, i+1))
        # Insert word i into the LHS table.
        (/ltbl[tokens[i]] := set([e])) | insert(ltbl[tokens[i]], e)
	# Watch out for those empty RHSs.
	insert(ch.inactive, e := edge("", &null, 1, 1, i, i))
        (/ltbl[""] := set([e])) | insert(ltbl[""], e)
    }
    *tokens = 0 & i := 0
    insert(ch.inactive, e := edge("", &null, 1, 1, i+1, i+1))
    (/ltbl[""] := set([e])) | insert(ltbl[""], e)

    #
    # Until no new active edges can be built, keep ploughing through
    # the active edge list, trying to match unconfirmed members of their
    # RHSs up with inactive edges.
    #
    until \none_found do {
#	write(ximage(ch))
        none_found := 1
        every e := !ch.active do {
            active_modified := &null
            # keep track of inactive edges we've already tried
            /e.SEEN := set()
            #
            # e.RHS[e.DONE+1] is the first unconfirmed category in the
            # RHS of e; ltbl[e.RHS[e.DONE+1].LHS] are all edges having
            # as their LHS the LHS of the first unconfirmed category in
            # e's RHS; we simply intersect this set with the inactives,
            # and then subtract out those we've seen before in connec-
            # tion with this edge -
            #
            if *(st := \ltbl[e.RHS[e.DONE+1].LHS] ** ch.inactive -- e.SEEN) > 0
            then {
                # record all the inactive edges being looked at as seen
                e.SEEN ++:= st
                every memb := !st do {
		    # make sure this inactive edge starts where the
		    # last confirmed edge in e.RHS ends!
		    if memb.BEG ~= \e.RHS[e.DONE].END then next
		    # set none_found to indicate we've created a new edge
		    else none_found := &null
                    # create a new edge, having the LHS of e, the RHS of e,
                    # the start point of e, the end point of st, and one more
                    # confirmed RHS members than e
                    new_e := edge(e.LHS, fullcopy(e.RHS),
				  e.LEN, e.DONE+1, e.BEG, memb.END)
                    new_e.RHS[new_e.DONE] := memb
                    /new_e.BEG := memb.BEG
                    if new_e.LEN = new_e.DONE then {      # it's inactive
                        insert(ch.inactive, new_e)
                        insert(ltbl[e.LHS], new_e)
                        if new_e.BEG = 1 & new_e.END = (*tokens+1) then {
                            if new_e.LHS == start_symbol  # complete parse
                            then suspend retval(0, new_e)
                        }
                    } else {
                        put(ch.active, new_e)            # it's active
                        active_modified := 1
                    }
                }
            }
            # restart if the ch.active list has been modified
            if \active_modified then break next
        }
    }

end


#
# tokenize:  break up a sentence into constituent words, using spaces,
#            tabs, and other punctuation as separators (we'll need to
#            change this a bit later on to cover apostrophed words)
#
procedure tokenize(s)

    local l, word

    l := list()
    s ? {
        while tab(upto(&letters)) do
            put(l, map(tab(many(&letters))))
    }
    return l

end


#
# edge2tree:  edge -> tree
#             e -> t
#
#    where e is an edge structure (active or inactive; both are okay)
#    where t is a tree like what's described in Ralph Griswold's
#    structs library (IPL); I don't know about the 2nd ed. of
#    Griswold & Griswold, but the structure is described in the 1st
#    ed. in section 16.1
#
#    fails if, for some reason, the conversion can't be made (e.g. the
#    edge structure has been screwed around with in some way)
#
procedure edge2tree(e)

    local memb, t

    t := [e.LHS]
    \e.RHS | (return t)                                 # a terminal
    type(e) == "edge" | (return put(t, []))             # An incomplete edge
    every memb := !e.RHS do                             # has daughters.
	put(t, edge2tree(memb))
    return t

end


#
# bnf_file_2_edges: concatenate backslash-final lines & parse
#
procedure bnf_file_2_edges(f)

    local getline, line, macro_list, old, new, i

    macro_list := list()
    getline := create stripcom(!f)
    while line := @getline do {
        while line ?:= 1(tab(-2) || tab(slshupto('\\')), pos(-1)) || @getline
	line ? {
	    if ="define" then {
		tab(many('\t '))
		old := tab(slshupto('\t ')) |
		    stop("bnf_file_2_edges", 7, tab(0))
		tab(many('\t '))
		new := tab(0)
		(!macro_list)[1] == old &
		    stop("bnf_file_2_edges", 8, old)
		put(macro_list, [old, new])
		next		# go back to main loop
	    }
	    else {
		every i := 1 to *macro_list do
		    # Replace is in the IPL (strings.icn).
		    line := replace(line, macro_list[i][1], macro_list[i][2])
		suspend bnf_2_edges(line)
	    }
	}
    }

end


#
# bnf_2_edges: string -> edge records
#              s -> Es (a generator)
#    where s is a CFPSG rule in BNF form
#    where Es are edges
#
procedure bnf_2_edges(s)
    
    local tmp, RHS, LHS
    #
    # Break BNF-style CFPSG rule into LHS and RHS.  If there is more
    # than one RHS (a la the | alternation op), suspend multiple re-
    # sults.
    #
    s ? {
	# tab upto the ::= sign
	tmp := (tab(slshupto(':')) || ="::=") | p_err(s, 1)
	# strip non-backslashed spaces, and extract LHS symbol
	stripspaces(tmp) ? {
	    LHS := 1(tab(slashbal(':', '<', '>')), ="::=") | p_err(s, 1)
	    LHS ?:= strip(2(="<", tab(-1), =">"), '\\') | p_err(s, 2)
	    LHS == "" & p_err(s, 6)
	}
        every RHS := do_slash(tab(0) \ 1) do {
            RHS := string_2_list(RHS)
            suspend edge(LHS, RHS, *RHS, 0, &null, &null)
        }
    }

end


#
# string_2_list:  string -> list
#                 s -> L
#    where L is a list of partially constructed (short) edges, having
#    only LHS and RHS; in the case of nonterminals, the RHS is set
#    to 1, while for terminals the RHS is null (and remains that way
#    throughout the parse)
#
procedure string_2_list(s)

    local tmp, RHS_list, LHS

    (s || "\x00") ? {
	tab(many(' \t'))
        pos(-1) & (return [short_edge("", &null)])
        RHS_list := list()
        repeat {
	    tab(many(' \t'))
	    pos(-1) & break
            if match("<") then {
                tmp := ("" ~== tab(slashbal(&cset, '<', '>'))) | p_err(s, 4)
		LHS := stripspaces(tmp)
                LHS ?:= strip(2(="<", tab(-1), =">"), '\\') | p_err(s, 4)
		LHS == "" & p_err(s, 10)
                put(RHS_list, short_edge(LHS, 1))
            } else {
                LHS := stripspaces(tab(slshupto(' <') | -1))
                slshupto('>', LHS) & p_err(s, 5)
                put(RHS_list, short_edge(strip(LHS, '\\'), &null))
            }
        }
    }
    return RHS_list

end


#
# fullcopy:  make full recursive copy of object
#
procedure fullcopy(obj)

    local retval, i, k

    case type(obj) of {
        "co-expression"  : return obj
        "cset"           : return obj
        "file"           : return obj
        "integer"        : return obj
        "list"           : {
            retval := list(*obj)
            every i := 1 to *obj do
                retval[i] := fullcopy(obj[i])
            return retval
        }
        "null"           :  return &null
        "procedure"      :  return obj
        "real"           :  return obj
        "set"            :  {
            retval := set()
            every insert(retval, fullcopy(!obj))
            return retval
        }
        "string"         :  return obj
        "table"          :  {
            retval := table(obj[[]])
            every k := key(obj) do
                insert(retval, fullcopy(k), fullcopy(obj[k]))
            return retval
        }
        # probably a record; if not, we're dealing with a new
        # version of Icon or a nonstandard implementation, and
	# we're screwed
        default          :  {
            retval := copy(obj)
            every i := 1 to *obj do
                retval[i] := fullcopy(obj[i])
            return retval
        }
    }

end


#
# do_slash:  string -> string(s)
#     Given a|b suspend a then b.  Used in conjunction with do_parends().
#
procedure do_slash(s)

    local chunk
    s ? {
	while chunk := tab(slashbal('|', '(', ')')) do {
	    suspend do_parends(chunk)
	    move(1)
	}
	suspend do_parends(tab(0))
    }

end


#
# do_parends:  string -> string(s)
#    Given a(b)c suspend abc; given a(b|c)d suspend abd and acd, etc.
#    Used in conjuction with do_slash().
#
procedure do_parends(s)

    local chunk, i, j
    s ? {
	if not (i := slshupto('(')) then {
	    chunk := tab(0)
	    slshupto(')') & p_err(s, 8)
	    suspend chunk
	} else {
	    j := i + slashbal(')', '(', ')', s[i+1:0]) | p_err(s, 9)
	    suspend tab(i) ||
		(move(1), do_slash(tab(j))) ||
		(move(1), do_parends(tab(0)))
	}
    }

end


#
# p_err:  print error message to stderr & abort
#
procedure p_err(s, n)

    local i, msg
    static errlist
    initial {
        errlist := [[1,  "malformed LHS"],
                    [2,  "nonterminal lacks proper <> enclosure"],
                    [3,  "missing left angle bracket"],
                    [4,  "unmatched left angle bracket"],
                    [5,  "unmatched right angle bracket"],
		    [6,  "empty symbol in LHS"],
                    [7,  "unable to open file"],
                    [8,  "unmatched right parenthesis"],
                    [9,  "unmatched left parenthesis"],
                    [10, "empty symbol in RHS"]
                   ]
    }
    every i := 1 to *errlist do
        if errlist[i][1] = n then msg := errlist[i][2]
    writes(&errout, "error ", n, " (", msg, ") in \n")
    every write("\t", rewrap(s) | rewrap())
    exit(n)

end


#
# Remove non-backslashed spaces and tabs.
#
procedure stripspaces(s)

    local s2

    s2 := ""
    s ? {
        while s2 ||:= tab(slshupto(' \t')) do
            tab(many(' \t'))
        s2 ||:= tab(0)
    }

    return s2

end