; A very small ATN interpreter ; in vanilla-flavored LISP ; by ; Tim Finin ; converted to Common LISP by ; Lois Boggess ; two differences from standard ATN interpreter notation: 1) getf is ; now a Common LISP built-in command, so it has been replaced as an ; ATN command by "getfeat". "TO" is a Franz Allegro built-in function, ; changing the definition of which is strongly discouraged by Franz. ; Therefore, the standard ATN "to" has been changed to "to*". (defmacro parse (sent &optional (initstate 's) (numparses 1)) ; (parse ) ;sets global variables number-of-parses state parses stack jumpflag `(progn (setq parses nil stack nil jumpflag nil) (setq sentence ',sent) (setq state ',initstate) (setq number-of-parses ,numparses) (setq * (car sentence)) (atn state sentence) (mapc #'(lambda (x) (terpri)(terpri)(setf *pretty-print* t)(pprint x)) parses) (and parses t))) (defun pushlex () (setq *lexenvironment* (cons (list * sentence) *lexenvironment*))) (defun poplex () (setq * (caar *lexenvironment*) sentence (cadar *lexenvironment*) *lexenvironment* (cdr *lexenvironment*)) ) (defun ATN (state sentence) ; * is the current word and sentence is the input from the current word on. (PROG (ARCS result (savealist alist)) (PTRACE TRACESTATE? '"in " STATE '" with word " *) (COND ((NULL (SETQ ARCS (get STATE 'ARCS))) (PTRACE TRACESTATE? '"state " STATE '" has no arcs!") (RETURN NIL))) LOOP (COND ((SETQ RESULT (EVALARC (CAR ARCS) ALIST)) (RETURN RESULT)) ((SETQ ARCS (CDR ARCS)) (setq alist savealist)(GO LOOP)) (T (PTRACE TRACESTATE? '"failing from " STATE) (RETURN NIL))))) (defun evalarc (arc alist) ; arc has form: ( .. ..) (ptrace tracearc? '" trying arc: " arc) (prog ((type (car arc))(head (cadr arc)) (test (caddr arc)) (actions (cdddr arc)) ) (return (cond ((null (eval test)) nil) ((eq type 'vir) (setq * (unhold head)) (and * (setq jumpflag t)(evall actions))) ((eq type 'jump) (evall actions) (pushlex) (cond ((atn head sentence)) (t (poplex) nil))) ((eq type 'pop) (evall actions) (popatn (eval head))) ((null *) nil) ((eq type 'wrd)(and (intersect * (cadr arc))(evall actions))) ((eq type 'cat) (and (intersect head (get * 'categories)) (setq * (root *)) (evall actions))) ((eq type 'push) (pushatn head actions)) (t (ptrace t '"bad arc: " arc) nil) )))) (defun evall (lst) (eval (cons 'progn lst))) (defmacro to* (state) ; effect a state transition to state state. Advance input unless ; jumpflag is t. Fail if there are no more words in the input. `(cond (jumpflag (setq jumpflag nil) (pushlex) (setq * (car sentence)) (cond ((atn ',state sentence)) (t (poplex) nil))) (sentence (pushlex) (setq * (cadr sentence)) (setq sentence (cdr sentence)) (cond ((atn ',state sentence)) (t (poplex) nil))) (t (ptrace tracestate? 'to* ',state '" blocked - out of words") nil))) (defun popatn (value) ; Pops from a subnetwork. (ptrace tracestate? '"Popping with: " value) (cond (stack ; pop to an earlier push (liftr holdlist (getr holdlist)) (prog ((save *)(savestack stack)(savealist alist) (continuation (cdar stack))) (setq alist (append (getr liftlist)(caar stack))) (setq stack (cdr stack)) (setq * value) (setr sendlist nil) (setq jumpflag t) (return (cond ((evall continuation)) (t (setq * save stack savestack alist savealist) nil)))) ) (sentence (ptrace tracestate? '"Pop blocked - unused words") nil) ((getr holdlist) (ptrace tracestate? "Pop blocked - non-empty holdlist") nil) (t ; final pop (setq parses (cons value parses)) (setq alist nil) (not (< (length parses) number-of-parses))))) (defun pushatn (state actions) ; Pushes to a subnetwork. (ptrace tracestate? '"pushing to " state) (setq actions (processactions actions)) (sendr holdlist (getr holdlist)) (prog ((savestack stack)(savealist alist)) (setq stack (cons (cons alist actions) stack)) (setq alist (getr sendlist)) (pushlex) (return (cond ((atn state sentence)) (t (poplex) (setq stack savestack alist savealist) nil))))) (defun processactions (actions) ; scans a list of arc actions. Any sendr's are done immediately ; and removed from the list. (cond ((null actions) nil) ((equal (caar actions) 'sendr) (eval (car actions)) (processactions (cdr actions))) (t (cons (car actions) (processactions (cdr actions)))))) (defmacro ds (&rest args) ; define an atn state: (ds ... ) `(progn (setf (get ',(car args) 'arcs) ',(cdr args) ) ',(car args))) ;; register accessing/setting functions (defmacro getr (regname) `(getr1 (quote ,regname))) ; (getr ) (defun getr1 (regname) (cdr (assoc regname alist))) (defmacro setr (regname value) `(setr1 (quote ,regname) ,value)) (defun setr1 (regname value) (ptrace tracereg? '" " regname '" <-- " value) (setq alist (cons (cons regname value) (remove (assoc regname alist) alist)))) (defmacro addr (regname value) `(addr1 (quote ,regname) ,value)) (defun addr1 (regname value) (setr1 regname (cons value (getr1 regname)))) (defmacro sendr (regname &optional value) `(addr sendlist (cons (quote ,regname) (cond (,value) (t (getr1 (quote ,regname))))))) (defmacro liftr (regname &optional value) `(addr liftlist (cons (quote ,regname) (cond (,value) (t (getr1 (quote ,regname))))))) (defmacro getfeat (featurename &optional source) ; (getfeat plural) --> does the current word (i.e. *) have the plural feature? ; (getfeat plural (getr verb)) --> does the word in register verb have the ; plural feature? `(intersect ',featurename (cond (,source (get ,source 'features)) (t (cond (* (get * 'features)) (t nil)))))) (defmacro cat (cattype &optional source) ; (cat prep) --> is the current word (i.e. *) in the prep category? ; (cat prep (getr v)) --> is the word in register v in the prep category? `(intersect ',cattype (cond (,source (get ,source 'categories)) (t (cond (* (get * 'categories)) (t nil)))))) (defun root (word) ; returns the root form of word. (or (get word 'root) word)) (defun hold (item symbol) ; puts item on the holdlist indexed under symbol. (addr1 'holdlist (cons symbol item ))) ; put item on hold (defun unhold (symbol) ; If there is an item on the holdlist indexed under symbol, returns it ; after removing it. Returns nil otherwise. ((lambda (constituent) (and constituent (setr holdlist (delete constituent (getr holdlist)))) (cdr constituent)) (assoc symbol (getr holdlist)))) (defmacro dw (&rest args) ; Define word - (dw ) `(progn (setf (get ',(car args) 'categories) ',(cadr args) ) (setf (get ',(car args) 'features) ',(caddr args) ) (setf (get ',(car args) 'root) ',(cadddr args) ) ',(car args))) (defmacro buildq (&rest form-registers) ; (buildq

... ) `(car (build1 (quote ,form-registers)))) (defun build1 (form-reg) ; car is actual form. cdr is registers (cond ((equal (car form-reg) '+) (cons (getr1 (cadr form-reg)) (cddr form-reg))) ((atom (car form-reg)) form-reg) ((equal (caar form-reg) '@) (do* ((template (cdar form-reg) (cdr template)) (piece (build1 (cons (car template) (cdr form-reg))) (build1 (cons (car template) (cdr piece)))) (answer (car piece) (append (car piece) answer))) ((null (cdr template)) (cons (reverse answer)(cdr piece)))) ) (t (prog ((form (car form-reg)) (registers (cdr form-reg)) temp1 temp2) (setq temp1 (build1 (cons (car form) registers))) (setq registers (cdr temp1)) (setq temp2 (build1 (cons (cdr form) registers))) (return (cons (cons (car temp1)(car temp2)) (cdr temp2))))))) ;; tracing functions (defun tracestate (x) (setq tracestate? x)) (defun tracearc (x) (setq tracearc? x)) (defun tracereg (x) (setq tracereg? x)) (defun traceall (x) (tracestate (tracereg (tracearc x)))) (defun ptrace (&rest args) ; prints tracing information: (ptrace ...) (cond ((car args) (terpri) (indent (* 2 (length stack))) (mapc #'(lambda (x) (princ x)) (cdr args))))) (defun indent (n) (cond ((< n 0)) (t (princ '" ") (indent (1- n))))) (defun intersect (list1 list2) ; returns t iff the intersection of list1 and list2 is non-empty. ; an atom (non-nil, that is) is interpreted as a singleton list. (and list1 list2 (intersect1 (cond ((atom list1)(list list1))(t list1)) (cond ((atom list2)(list list2))(t list2))))) (defun intersect1 (l1 l2) (cond ((null l1) nil) ((member (car l1) l2)) ((intersect1 (cdr l1) l2)))) (defun definestate (state) ; define an atn state which is part of the network definition (setf (get (car state) 'arcs) (cdr state))) (defun definenetwork (net) (mapc #'definestate net)) (defun loaddict (defns) (mapc #'defineword defns)) (defun defineword (worddef) ; Define word in dictionary list ( ) (setf (get (car worddef) 'categories) (cadr worddef) ) (setf (get (car worddef) 'features) (caddr worddef) ) (setf (get (car worddef) 'root) (cadddr worddef) ) (car worddef)) ; global variables (setf alist nil stack nil sentence nil state nil * nil tracestate? nil tracereg? nil tracearc? nil *lexenvironment* nil) (print "type (traceall nil) to turn off tracing") (print "format for parsing is (parse (the cat chased the old dog)), for example") (print "(exit) leaves LISP")