*-title english sentence	syntax recognizer
*
*   Assignment #1 in Dr. Tharp's CS 502  Computational Linguistics
*
*   Note: this program uses the 'code' function for newly generated
*	routines
*
*-stitl define functions	& read grammar
*
*
*
	 &trim = 1
	 &anchor = 1
	 trace('tree')
	 trace('e')
*
*	define all of the program's functions here
*
	 define('atn()rtn')
	 define('opt(arg)backup')
	 define('alt(arg)p,q,backup')
	 define('eval(arg)e,fname,args,backup')
	 define('testfor(arg)pos,word,info,i')
	 trace('opt','function')
	 trace('alt','function')
	 trace('eval','function')
	 trace('testfor','function')
*
*      initialize a couple of variables	that are more or less
*      self explanatory
*
	 lexicon = table(100,25)
	 alphabet = 'abcdefghijklmnopqrstuvwxyz'
	 terminals     = 'n ' !	'v ' ! 'npr ' !	'det ' ! 'prep '
+	 ! 'adj	'
-space 4
	 output	= '* * * * * * * * * * * * * * * * * * *'
	 output	= '*  functions	generated from grammar *'
	 output	= '* * * * * * * * * * * * * * * * * * *'
	 output	=
*
*      input a rewrite rule.  a	'$$$' marks the	end of the grammar
*      and the start state.  generate the function to look for
*      the sentence phrase.  code the function and define it.
*
get	 rwr = input ' '				   :f(eof1)
	 rwr   '$$$'  (break(' ') . startsymb)		   :s(eof1)
	 output	= rwr
*
*      pick off	the generator symbol that is to	be the name of the
*      function.  (the function	name is	preceeded by a 'z' to keep the
*      rewrite rule functions unique)
*
	 rwr  span(alphabet) . name  '->'  =		   :f(err1)
	 str = atn(rwr)
*
*     this is the code for the function
*
*
*   z???? - recognize phrase
*    arguments:	sentence
*    returns: tree structure
*    modifys: none
*    logic:  a copy of sent is saved as	a backup.  the
*      function	returns	the function name and the eval of the
*      string.	if this	fails restore sent and freturn
*
	 funct = "z"  name  "	  backup = sent	    ;"
+	 "     z"  name	 " = '("  name
+	 "'    eval('("	  str	")')   ')'    :s(return) ;"
+	 "     sent = backup	      :(freturn) ;"
-space 3
	 save =	funct
prnt	 save  (break(';')  len(1)) $ output  =		   :s(prnt)

	 define("z"  name  "()backup")
	 trace("z" name,'function')
*
*      code the	function
*
	 code(funct)					   :f(err5)
	 output	=					   :(get)
-stitl augmented transition network function generator
*
*   atn	- transform rewrite rule to acceptable eval string
*    arg: none
*    returns: eval string of the function
*    modifys: rwr
*    logic: recognize 4	parts of a rewrite rule: a part	of speech,
*      an optional phrase, an alternation phrase, and another phrase
*      function.
*
*
atn
*
*   initialize return type to freturn meaning no match found
*
	 rtn = 'freturn'
*
*   delete leading blanks
*
atna	 rwr  '	'  =					   :s(atna)
*
*     see if it	is a part of speech.  if so set	return type to
*     successful return	and add	a call to testfor the word
*
	 rwr  terminals	. var =				   :f(atn1)
	 rtn = 'return'
	 atn = atn  '(testfor('	 var  '))'		   :(atna)

*
*     see if this stuff	is optional.  if so set	a call to opt
*
atn1	 rwr  '(' =					   :f(atn2)
	 atn = atn  '(opt(' atn()			   :f(freturn)
	 rwr  ')' =					   :f(err2)
	 rtn = 'return'
	 atn = atn  '))'				   :(atna)

*
*      if this is alternation set a call to alt	with the things	to
*      choose from as parenthisized arguments
*
atn2	 rwr  '<' =					   :f(atn3)
	 atn = atn '(alt(('
atn2a	 atn = atn  atn()				   :f(freturn)
atn2b	 rwr  ','  =					   :f(atn2c)
	 atn = atn  ')('				   :(atn2a)
atn2c	 rwr  '>' =					   :f(atn2a)
	 rtn = 'return'
	 atn = atn  ')))'				   :(atna)
*
*	this must be the name of another rewrite rule.	set up as
*      function	call.  if nothing matched then freturn
*
atn3	 rwr  span(alphabet) . nonterminal =		   :f($(rtn))
	 rtn = 'return'
	 atn = atn  '(z'  nonterminal  '())'		   :(atna)
-stitl	slave functions
*
*     these functions apply the	operations defined by the rewrite rules
*
-space 2
*
*   opt	- test for optional component
*    arg: (function)
*    returns: tree structure if	s; null	if fail
*    modifys: none
*    logic: execute successful return regardless of evaluation
*      function.  don't	let sent get messed up if eval matched part
*      of the string then failed.
*
*
opt	 backup	= sent
	 opt = eval(arg)				   :s(return)
	 sent =	backup					   :(return)
-space 3
*
*   alt:try several functions
*    arg: ( (cond1) (cond2) . .	. (condn))
*    returns: tree structure  of the cond that succeeded
*    modifys: none
*    logic: step through list calling eval on each expression.	if
*      any succeeds then alt succeeds, alt fails otherwise.
*
alt	 arg  '('  rtab(1) . p	')'
	 backup	= sent
alt1	 sent =	backup
	 p  bal	. q  =					   :f(freturn)
	 alt = eval(q)				  :s(return)f(alt1)
-space 3
*
*
*   eval - evaluate an expression
*    arg: ((function1(arg1)) (function2(arg2)) ...)
*    returns: tree structure if	all functions succeed
*    modifys: none
*    logic: apply each function	to its arguments
*      ((this) looks (like (lisp)))
*
eval	 arg '('  rtab(1) . e  ')'
	 backup	= sent
eval1	 e  '('	 break('(') . fname  bal . args	 ')'  =	   :f(return)
	 eval =	eval  apply(fname,args)			   :s(eval1)
	 sent =	backup					   :(freturn)
-space 3
*
*   testfor - test next	word in	sent for a part	of speech
*    arg: (a_part_of_speech)
*    returns: tree structure if	word is	a_part_of_speech
*    modifys: sent
*    logic: one	word taken from	sent.  if it is	the a_p_o_s then
*      return (a_p_o_s word) ,	else put word back onto	sent
*      and freturn.
*
testfor	 arg  '('  break(')') .	pos
	 sent  break(' ') . word  span(' ')  =
	 lexicon<word>	break('/') . info
test1	 info  break(',') . i len(1) =			   :f(test2)
	 ident(pos,i ' ')				   :f(test1)
	 testfor = testfor  '('	 pos  word  ')'		   :(return)
test2	 sent =	word  '	'  sent				   :(freturn)
-stitl	read lexicon & analyze sentences
eof1
*
*     read in lexicon
*
lexloop	 card =	input					   :f(end)
	 output	= card
	 card	'$$$'					   :s(eof2)
	 card  break(' ') . word  span(' ')  rem . stuff
	 lexicon<word> = stuff				   :(lexloop)


eof2
*	 input('diskin','diskin')
*
*      read sentences from disk	file and analyze them
*
loop	 sent =	input ' '				   :f(eof3)
	 output	=
	 save =	sent
	 tree =	apply("z" startsymb,'')	 ident(sent)	   :f(no)
	 output	= 	   '***	yes ***'
	 output	= tree					   :(loop)
no	 output	= 	 '*** no  ***'
	 output	= dupl(' ',size(save) -	size(sent))  '!'   :(loop)
eof3
end
s->np vp
vp->v (<np,adj >) (pp)
np-><(det ) n (pp),npr >
pp-> prep np
$$$s
the det,/
a det,/
of prep,/
is v,/
things n,/
broom n,/
beetle n,/
era n,/
rodger npr,/
david npr,/
known v,/
home n,/
on prep,/
charles	npr,/
go v,/
stop v,/
pontiac	n,/
bite v,/
room-40	n,/
past n,v,/
rides v,/
drives v,/
paul-revere npr,/
saturday n,/
thing n,/
works n,v,/
saturdays n,/
yellow n,/
work n,v,/
snitch n,v,/
polyglot n,/
any adj,/
better adj,/
was v,/
owners n,/
do v,/
not adj,/
man n,/
dog n,/
broke v,n,/
$$$
charles is a polyglot