Category : Files from Magazines
Archive   : AIAPR87.ZIP
Filename : AIAPP.DEC

Code Taken from
'AI Apprentice' column
AI EXPERT magazine -- Dec. 1986 issue


GRAMMAR.PAS


{$R+}
PROGRAM grammar ;

(* Copyright 1986 - MicroExpert Systems
Box 430 R.D. 2
Nassau, NY 12123 *)

(* GRAMMAR implements the parser described in the December 1986 AI Apprentice
column in AI Expert magazine.

This program has been tested using Turbo ver 3.01A on an IBM PC. It has
been run under both DOS 2.1 and Concurrent 4.1 .

To change the vocabulary that the program recognizes, change the constant
declarations in the procedures noun, verb etc. To change the grammar,
write down the new rewrite rules and code a new procedure for each one.

We would be pleased to hear your comments, good or bad, or any applications
and modifications of the program. Contact us at the above address or
on Compuserve or BIX. Our Compuserve id is 76703,4324 and may be reached by
Easyplex mail or in the AI Expert forum. Our BIX id is bbt and we may be
contacted by BIX mail or by leaving comments in the MicroExpert conference.

Bill and Bev Thompson *)

CONST
tab = ^I ;

TYPE
string80 = string[80] ;

VAR
line : string80 ;


PROCEDURE strip_leading_blanks(VAR s : string80) ;
(* generic procedure for removing leading blanks *)
BEGIN
IF length(s) > 0
THEN
IF (s[1] = ' ') OR (s[1] = tab)
THEN
BEGIN
delete(s,1,1) ;
strip_leading_blanks(s) ;
END ;
END ; (* strip_leading_blanks *)


FUNCTION toupper(s : string80) : string80 ;
(* Convert the string, s, to upper case *)
VAR
i : byte ;
BEGIN
IF length(s) > 0
THEN
FOR i := 1 TO length(s) DO
s[i] := upcase(s[i]) ;
toupper := s ;
END ; (* toupper *)


PROCEDURE sentence(word_string : string80) ;
VAR
indent : string80 ;

PROCEDURE error(error_msg : string80) ;
(* Display an error message and halt the program. This is a sloppy way
to end the parsing procedure. It should be changed to return an error
code and exit more elagantly. *)
BEGIN
writeln ;
writeln ;
writeln('Error : ',error_msg) ;
halt ;
END ; (* error *)

FUNCTION get_word : string80 ;
(* Returns the first word, in upper case, from word_string *)
VAR
token : string80 ;
BEGIN
token := '' ;
strip_leading_blanks(word_string) ;
WHILE (word_string <> '') AND (copy(word_string,1,1) <> ' ') DO
BEGIN
token := concat(token,copy(word_string,1,1)) ;
delete(word_string,1,1)
END ;
get_word := toupper(token) ;
END ; (* get_word *)

PROCEDURE noun_phrase ;
(* noun_phrase ::- determiner noun | determiner adj_set noun *)
VAR
temp_word : string80 ;

PROCEDURE determiner ;
(* Is the first word in the current sentence a determiner *)
CONST
det_list = ' THE A ' ;
VAR
det_word : string80 ;
BEGIN
det_word := get_word ;
IF pos(concat(' ',det_word,' '),det_list) = 0
THEN error(concat('Illegal determiner --- ',det_word))
ELSE writeln(indent,'Determiner : ',det_word) ;
END ; (* determiner *)

FUNCTION adj : boolean ;
(* Look ahead at the first word, is it an adjective ?
This routine doesn't remove the word, just looks at it *)
CONST
adj_list = ' BIG RED ' ;
VAR
adj_word : string80 ;
BEGIN
adj_word := get_word ;
word_string := concat(concat(' ',adj_word),word_string) ;
IF pos(concat(' ',adj_word,' '),adj_list) <> 0
THEN
BEGIN
adj := true ;
writeln(indent,'Adjective : ',adj_word) ;
END
ELSE adj := false ;
END ; (* adj *)

PROCEDURE adj_set ;
(* remove the adjectives from the front of the sentence. Stop when
a word is encountered that is not an adjective *)
VAR
adj_word : string80 ;
BEGIN
IF adj
THEN
BEGIN
adj_word := get_word ;
adj_set ;
END ;
END ; (* adj_set *)

PROCEDURE noun ;
(* Is the first word a noun *)
CONST
nouns = ' GIRL BALL TABLE ' ;
VAR
noun_word : string80 ;
BEGIN
noun_word := get_word ;
IF pos(concat(' ',noun_word,' '),nouns) = 0
THEN error(concat('Illegal noun --- ',noun_word))
ELSE writeln(indent,'Noun : ',noun_word) ;
END ; (* noun *)

BEGIN
writeln(indent,'Noun phrase :') ;
indent := concat(' ',indent) ;
determiner ;
IF adj
THEN
BEGIN
temp_word := get_word ;
adj_set ;
noun ;
END
ELSE noun ;
delete(indent,1,2) ;
END ; (* noun_phrase *)

PROCEDURE verb_phrase ;
(* verb_phrase ::- verb | verb noun_phrase | verb noun_phrase prep_pharse *)

PROCEDURE verb ;
(* Does the reamining part of the sentence start with a verb ? *)
CONST
verbs = ' MOVED PUSHED ' ;
VAR
verb_word : string80 ;
BEGIN
verb_word := get_word ;
IF pos(concat(' ',verb_word,' '),verbs) = 0
THEN error(concat('Illegal verb --- ',verb_word))
ELSE writeln(indent,'Verb : ',verb_word) ;
END ; (* verb *)

PROCEDURE prep_phrase ;
(* prep_phrase ::- preposition noun_phrase *)

PROCEDURE preposition ;
(* Is the first word a preposition ? *)
CONST
prep_list = ' TO FROM ' ;
VAR
prep_word : string80 ;
BEGIN
prep_word := get_word ;
IF pos(concat(' ',prep_word,' '),prep_list) = 0
THEN error(concat('Illegal preposition --- ',prep_word))
ELSE writeln(indent,'Preposition : ',prep_word) ;
END ; (* preposition *)

BEGIN
writeln(indent,'Prepositional phrase :') ;
indent := concat(' ',indent) ;
preposition ;
noun_phrase ;
delete(indent,1,2) ;
END ; (* prep_phrase *)

BEGIN
writeln(indent,'Verb phrase :') ;
indent := concat(' ',indent) ;
verb ;
IF word_string <> ''
THEN
BEGIN
noun_phrase ;
IF word_string <> ''
THEN prep_phrase ;
IF word_string <> ''
THEN error(concat('Illegal word ---- ',word_string)) ;
END ;
delete(indent,1,2) ;
END ; (* verb_phrase *)

BEGIN
writeln('Sentence :') ;
indent := ' ' ;
noun_phrase ;
verb_phrase ;
writeln ;
writeln('This is a legal sentence.') ;
END ; (* sentence *)

BEGIN
clrscr ;
writeln('Grammar - Copyright [c] 1986 MicroExpert Systems') ;
writeln ;
write('Enter a sentence : ') ;
readln(line) ;
sentence(line) ;
END.


GRAMMAR.PRO

/*
Copyright 1986 - MicroExpert Systems
Box 430 R.D. 2
Nassau, NY 12123

This program implements the parser described in the December 1986 AI Apprentice
column in AI Expert magazine.

The program was developed and tested using PDPROLOG 1.7f. It should
work on just about any version of PROLOG.

To run the program, type : consult(grammar).
go.

To change the vocabulary that the program recognizes, change the constant
declarations in the procedures noun, verb etc. To change the grammar,
write down the new rewrite rules and code a new procedure for each one.

We would be pleased to hear your comments, good or bad, or any applications
and modifications of the program. Contact us at the above address or
on Compuserve or BIX. Our Compuserve id is 76703,4324 and may be reached by
Easyplex mail or in the AI Expert forum. Our BIX id is bbt and we may be
contacted by BIX mail or by leaving comments in the MicroExpert conference.

Bill and Bev Thompson

*/

go :-
print('Enter a sentence, terminated with a "."'),nl,nl,
print('See December 1986 AI Expert for the proper grammar'),nl,
print('and vocabulary'),nl,nl,
print('==> '),
read_in(SS),nl,
parse(SS),!.


parse(S) :-
sentence(S),
nl,nl,
print('You have entered a well formed sentence.'),nl.

parse(S) :-
nl,nl,
print('This string of words is not a well formed sentence.'),nl.


/* A sentence is a sentence if it is made up of sentence parts */

sentence(S) :-
sentence_parts(S,['.']).

/* Sentence parts are noun_phrase verb_phrase */

sentence_parts(S0,S) :-
print('Sentence : '),nl,
noun_phrase(S0,S1," "),!,
verb_phrase(S1,S," ").


/* noun_phrase ::= determiner noun | determiner adj_set noun
the program actually treats adj_set as if it could be empty.
This is different than the Pascal and LISP versions */

noun_phrase(S0,S,Indent) :-
print_string(Indent),
print('Noun phrase : '),nl,
append(" ",Indent,Indent2),
determiner(S0,S1,Indent2),
adj_set(S1,S2,Indent2),!,
noun(S2,S,Indent2).


/* verb_phrase ::= verb | verb noun_phrase | verb noun_phrase prep_phrase
The program breaks this down into:
verb_phrase ::= verb obj
obj ::= [] | noun_phrase modifier
modifier ::= [] | prep_phrase
This makes it easier to trap errors and avoids duplicate printing of
nonterminals on backtracking. */

verb_phrase(S0,S,Indent) :-
print_string(Indent),
print('Verb Phrase : '),nl,
append(" ",Indent,Indent2),
verb(S0,S1,Indent2),!,
obj(S1,S,Indent2).

obj(['.'],['.'],Indent).

obj(S0,S,Indent) :-
noun_phrase(S0,S1,Indent),!,
modifier(S1,S,Indent).

modifier(['.'],['.'],Indent).

modifier(S0,S,Indent) :-
prep_phrase(S0,S,Indent).


/* adj_set := [] | adj | adj adj_set */

adj_set(S0,S,Indent) :-
adj(S0,S1,Indent),
adj_set(S1,S,Indent).

adj_set(S0,S,Indent) :-
adj(S0,S,Indent).

adj_set(S0,S0,Indent).


prep_phrase(S0,S,Indent) :-
print_string(Indent),
print('Prepositional phrase : '),nl,
append(" ",Indent,Indent2),
preposition(S0,S1,Indent2),
noun_phrase(S1,S,Indent2).

/* Terminal symbol definitions :
Each, except adj, has two definitions. The second signals an error
has occurred. */

determiner([Det|S],S,Indent) :-
member(Det,[the,a]),
print_string(Indent),
print('Determiner : ',Det),nl.

determiner([Det|S],S,Indent) :-
nl,print('Error : Illegal determiner --- ',Det),nl,
fail.

adj([Adj|S],S,Indent) :-
member(Adj,[big,red]),
print_string(Indent),
print('Adjective : ',Adj),nl.

noun([Noun_word|S],S,Indent) :-
member(Noun_word,[girl,ball,table]),
print_string(Indent),
print('Noun : ',Noun_word),nl.

noun([Noun_word|S],S,Indent) :-
nl,print('Error : Illegal noun --- ',Noun_word),nl,
fail.

verb([Verb_word|S],S,Indent) :-
member(Verb_word,[moved,pushed]),
print_string(Indent),
print('Verb : ',Verb_word),nl.

verb([Verb_word|S],S,Indent) :-
nl,print('Error : Illegal verb --- ',Verb_word),nl,
fail.

preposition([P|S],S,Indent) :-
member(P,[to,from]),
print_string(Indent),
print('Preposition : ',P),nl.

preposition([P|S],S,Indent) :-
nl,print('Error : Illegal preposition --- ',P),nl,
fail.

/* Some Utility predicates */

member(X,[X|_]).

member(X,[_|Y]) :-
member(X,Y).


append([],L,L).

append([X|L1],L2,[X|L3]) :- append(L1,L2,L3).


print_string([]).

print_string([H|T]) :-
put(H),print_string(T).

/* read_in - From Clocksin and Mellish */

read_in([W|Ws]) :-
get0(C),
readword(C,W,C1),
restsent(W,C1,Ws).

restsent( W,_,[]) :-
lastword(W), !.

restsent(W,C,[W1|Ws]) :-
readword(C,W1,C1),
restsent(W1,C1,Ws).

readword(C,W,C1) :-
single_character(C), !,
name(W,[C]),
get0(C1).

readword(C,W,C2) :-
in_word(C,NewC), !,
get0(C1),
restword(C1,Cs,C2),
name(W,[NewC|Cs]).

readword(C,W,C2) :-
get0(C1),
readword(C1,W,C2).

restword(C,[NewC|Cs],C2) :-
in_word(C,NewC), !,
get0(C1),
restword(C1,Cs,C2).
restword(C,[],C).

single_character(44). /* , */
single_character(59). /* ; */
single_character(58). /* : */
single_character(63). /* ? */
single_character(33). /* ! */
single_character(46). /* . */

in_word(C,C) :- C>96, C<123. /* a b..z */
in_word(C,L) :- C>64, C<91, L is C+32. /* A,B..Z */
in_word(C,C) :- C>47, C<58. /* 1,2,..9 */
in_word(39,39). /* ' */
in_word(45,45). /* - */

lastword( '.' ).
lastword( '!' ).
lastword( '?' ).



GRAMMAR1.LSP

; Copyright 1986 - MicroExpert Systems
; Box 430 R.D. 2
; Nassau, NY 12123
;
; Sentence implements the parser described in the December 1986 AI Apprentice
; column in AI Expert magazine. This is the Pascal "clone" program. It is
; an example of some pretty poor LISP style.
;
; The program was implemented and tested under XLISP 1.6. It should work
; with later versions.
;
; To change the vocabulary that the program recognizes, change the constant
; declarations in the procedures noun, verb etc. To change the grammar,
; write down the new rewrite rules and code a new procedure for each one.
;
; We would be pleased to hear your comments, good or bad, or any applications
; and modifications of the program. Contact us at the above address or
; on Compuserve or BIX. Our Compuserve id is 76703,4324 and may be reached by
; Easyplex mail or in the AI Expert forum. Our BIX id is bbt and we may be
; contacted by BIX mail or by leaving comments in the MicroExpert conference.
;
; Bill and Bev Thompson
;
(defun sentence (word-list)
;
(let ((indent " "))
;
; Some simple print functions
;
(defun print-with-indent (stuff)
(princ indent)
(princ stuff))
;
(defun print-line (stuff)
(print-with-indent stuff)
(terpri))
;
(defun print-with-title (title stuff)
(print-with-indent title)
(princ " ")
(princ stuff)
(terpri))
;
; The error function. It uses the XLISP primitive "error"
; to terminate the program
;
(defun parse-error (message error-word)
(terpri)
(terpri)
(terpri)
(error (strcat message " --- " (symbol-name error-word))))
;
; Extract the first word from "word-list"
;
(defun get-word ()
(let ((token (car word-list)))
(setq word-list (cdr word-list))
token))
;
(defun noun-phrase ()
;
(defun determiner ()
(let ((det-list '(a the))
(det-word (get-word)))
(cond ((member det-word det-list)
(print-with-title "Determiner : " det-word))
(T (parse-error "Illegal determiner" det-word)))))
;
(defun adj ()
(let ((adj-list '(big red))
(adj-word (get-word)))
(setq word-list (cons adj-word word-list))
(cond ((member adj-word adj-list)
(print-with-title "Adjective : " adj-word) T)
(T nil))))
;
(defun adj-set ()
(cond ((adj) (get-word) (adj-set))))
;
(defun noun ()
(let ((nouns '(girl ball table))
(noun-word (get-word)))
(cond ((member noun-word nouns)
(print-with-title "Noun : " noun-word))
(T (parse-error "Illegal noun" noun-word)))))
;
(print-line "Noun phrase : ")
(setq indent (strcat " " indent))
(determiner)
(cond ((adj) (get-word)
(adj-set)
(noun))
(T (noun)))
(setq indent (substr indent 3)))
;
;
(defun verb-phrase ()
;
(defun verb ()
(let ((verbs '(moved pushed))
(verb-word (get-word)))
(cond ((member verb-word verbs)
(print-with-title "Verb : " verb-word))
(T (prase-error "Illegal verb" verb-word)))))
;
(defun prep-phrase ()
;
(defun preposition ()
(let ((prep-list '(to from))
(prep-word (get-word)))
(cond ((member prep-word prep-list)
(print-with-title "Preposition : " prep-word))
(T (parse-error "Illegal preposition" prep-word)))))
;
(print-line "Prepositional phrase : ")
(setq indent (strcat " " indent))
(preposition)
(noun-phrase)
(setq indent (substr indent 3)))
;
(print-line "Verb phrase : ")
(setq indent (strcat " " indent))
(verb)
(cond ((not (null word-list)) (noun-phrase)
(cond ((not (null word-list))
(prep-phrase)))))
(setq indent (substr indent 3)))
;
;
(print-line "Sentence : ")
(setq indent (strcat " " indent))
(noun-phrase)
(verb-phrase)
(terpri)
(terpri)
(terpri)
(print "You have entered a legal sentence")
NIL))
;
;
; Opening instructions
;
(terpri)
(princ "To run the parser, Type: (sentence '(the girl moved the ball))")
(terpri)
(terpri)
(princ "See December 1986 AI Expert magazine for a description of")
(terpri)
(princ "the grammar that this routine implements.")
(terpri)
(terpri)


GRAMMAR2.LSP


; Copyright 1986 - MicroExpert Systems
; Box 430 R.D. 2
; Nassau, NY 12123
;
; Sentence implements the parser described in the December 1986 AI Apprentice
; column in AI Expert magazine. This is the Pascal "clone" program. This is
; the slightl more LISP-like version. It could also stand some improvement.
; For example,most of the local varaibles are unnecessary.
;
; The program was implemented and tested under XLISP 1.6. It should work
; with later versions.
;
; To change the vocabulary that the program recognizes, change the constant
; declarations in the procedures noun, verb etc. To change the grammar,
; write down the new rewrite rules and code a new procedure for each one.
;
; We would be pleased to hear your comments, good or bad, or any applications
; and modifications of the program. Contact us at the above address or
; on Compuserve or BIX. Our Compuserve id is 76703,4324 and may be reached by
; Easyplex mail or in the AI Expert forum. Our BIX id is bbt and we may be
; contacted by BIX mail or by leaving comments in the MicroExpert conference.
;
; Bill and Bev Thompson
;
(defun print-line (indent line)
(princ indent)
(princ line)
(terpri))
;
;
(defun print-word (indent title word)
(princ indent)
(princ title)
(princ word)
(terpri))
;
;
(defun parse-error (message error-word)
(terpri)
(terpri)
(terpri)
(error (strcat message " --- " (symbol-name error-word))))
;
;
(defun determiner (word-list indent)
(let ((det-list '(a the)))
(cond ((member (car word-list) det-list)
(print-word indent "Determiner : " (car word-list))
(cdr word-list))
(T (parse-error "Illegal determiner " (car word-list))))))
;
;
(defun adj (word-list indent)
(let ((adj-list '(big red)))
(cond ((member (car word-list) adj-list)
(print-word indent "Adjective : " (car word-list))
T)
(T nil))))
;
;
(defun adj-set (word-list indent)
(cond ((adj word-list indent) (adj-set (cdr word-list) indent))
(T word-list)))
;
;
(defun noun (word-list indent)
(let ((nouns '(girl ball table)))
(cond ((member (car word-list) nouns)
(print-word indent "Noun : " (car word-list))
(cdr word-list))
(T (parse-error "Illegal noun " (car word-list))))))
;
;
(defun noun-phrase (word-list indent)
(let ((remaining-words nil))
(print-line indent "Noun phrase : ")
(setq remaining-words (determiner word-list (strcat " " indent)))
(cond ((adj remaining-words (strcat " " indent))
(setq remaining-words (adj-set (cdr remaining-words)
(strcat " " indent)))
(noun remaining-words (strcat " " indent)))
(T (noun remaining-words (strcat " " indent))))))
;
;
(defun verb (word-list indent)
(let ((verbs '(moved pushed)))
(cond ((member (car word-list) verbs)
(print-word indent "Verb : " (car word-list))
(cdr word-list))
(T (parse-error "Illegal verb " (car word-list))))))
;
;
(defun preposition (word-list indent)
(let ((prep-list '(to from)))
(cond ((member (car word-list) prep-list)
(print-word indent "Preposition : " (car word-list))
(cdr word-list))
(T (parse-error "Illegal preposition " (car word-list))))))
;
;
(defun prep-phrase (word-list indent)
(let ((remaining-words nil))
(print-line indent "Prepositional phrase :")
(setq remaining-words (preposition word-list (strcat " " indent)))
(noun-phrase remaining-words (strcat " " indent))))
;
;
(defun verb-phrase (word-list indent)
(let ((remaining-words nil))
(print-line indent "Verb phrase :")
(setq remaining-words (verb word-list (strcat " " indent)))
(cond ((not (null remaining-words))
(setq remaining-words (noun-phrase remaining-words
(strcat " " indent)))
(cond ((not (null remaining-words))
(setq remaining-words
(prep-phrase remaining-words
(strcat " " indent)))))))))
;
;
;
(defun sentence (word-list)
(let ((remaining-words nil))
(print-line "" "Sentence : ")
(setq remaining-words (noun-phrase word-list " "))
(cond ((null (verb-phrase remaining-words " "))
(terpri)
(princ "You have entered a legal sentence.")
(terpri)
NIL))))
;
;
; Opening instructions
;
(terpri)
(princ "To run the parser, Type: (sentence '(the girl moved the ball))")
(terpri)
(princ "See December 1986 AI Expert magazine for a description of")
(terpri)
(terpri)
(princ "the grammar that this routine implements.")
(terpri)
(terpri)



FIGURES IN THIS MONTH'S COLUMN


sentence ::= noun_phrase verb_phrse
noun_phrase ::= determiner adj_set noun | determiner noun
adj_set ::= adj | adj adj_set
verb_phrase ::= verb | verb noun_phrase | verb noun_pharse prep_phrase
prep_phrase ::= preposition noun_phrase
determiner ::= "a" | "the"
noun ::= "girl" | "ball"
adj ::= "big" | "red"
verb ::= "moved" | "pushed"
preposition ::= "to | "from"

Figure 1 - Rules for a simple context-free grammar



PROCEDURE sentence | (defun sentence (word_string)
(word_string : string) | .
. | .
. | (print-line "Sentence : ")
. | (setq indent " ")
. | (noun-phrase)
| (verb-phrase))
BEGIN |
writeln('Sentence : ') ; |
indent := ' ' ; |
noun_phrase ; |
verb_phrase ; |
END ; (* sentence *) |
|

Figure 2 - Pascal and LISP code to begin parsing the grammar.



PROCEDURE noun_phrase ; | (defun noun ()
. | .
. | .
. | (print-line indent "Noun Phrase :")
. | (setq indent (strcat " " indent))
| (determiner)
BEGIN | (cond ((adj) (get-word)
writeln(indent,'Noun Phrase :') ; | (adj-set)
indent := concat (' ',indent) ; | (noun))
determiner ; | (T (noun)))
IF adj |
THEN |
BEGIN |
temp := get_word ; |
adj_set ; |
noun ; |
END |
ELSE noun ; |
delete (indent,1,2) ; |
END ; (* noun_phrase *) |

Figure 3 - Pascal and LISP code for finding noun phrases.




PROCEDURE determiner ; | (defun determiner ()
CONST | (let ((det-list '(a the))
det_list = ' a the ' ; | (det-word (get-word))
VAR | (cond ((member det-word det-list)
det_word : string80 ; | (print-line indent "Determiner : " det-word))
BEGIN | (T (parse-error "Illegal Determiner --- " det-word)))))
det_word := get_word ; |
IF pos(concat(' ',det_word,' '),det_list) = 0 |
THEN error(concat(Illegal determiner --- ',det_word))|
ELSE writeln(indent,'Determiner : ',det_word) ; |
END ; (* determiner *) |

Figure 4 - Pascal and LISP code for finding determiners.



Sentence :
Noun phrase :
Determiner : the
Noun : girl
Verb phrase :
Verb : moved
Noun phrase :
Determiner : the
Noun : ball
Prepositional phrase :
Preposition : to
Noun phrase :
Determiner : the
Adjective : big
Adjective : red
Noun : table

Figure 5 - The parse tree for "the girl moved the ball to the big red table"




sentence
noun_phrase
determiner
adj
adj_set
noun
verb_phrase
verb
prep_phrase
preposition

Figure 6 - The block structure of the recursive descent parser.