;;; *****************************
;;; *  PORTABLE AI LAB  - IDSIA *
;;; *****************************
;;;  
;;; Filename:    Net-5 
;;; Module:      ATN AUGMENTED TRANSITION NETWORKS
;;; Author(s):   Mike Lenz - Fabio Baj 
;;; Short Desc:  A sample network file
;;;===================================================================


;; A complicated network that handles interrogatives, passive
;; sentences, some auxiliary verbs, "there" insertion, etc.
;; Returns a list of sentence components rather than a parse
;; tree.
;;
;; Note this network uses its own custom functions "agree"
;; and "isftr", defined below.
;;
;; Sample sentence:
;;   "Is a book given by Paolo to the man on the bus?"
;;
;; (Note this sentence is ambiguous, depending on whether
;; "on the bus" binds to "the man" or to "given".)
;;

(in-package :atn)
(setq *network*
  '(
    (S
     (regs NUM SUBJ VOICE TYPE OBJ INDOBJ V AUX VMOD)
     (init (progn (setr VOICE 'ACTIVE)
		  (setr TYPE 'DCL)))
     (s/
      (push NP s/np t () (setr SUBJ *))
      (cat AUX s/qaux t
	   (progn (setr TYPE 'Q)
		  (setr AUX *lex*)))
      (word "there" s/there t ())
      )
     (s/np
      (cat AUX s/aux (agree (getftr num) (getr NUM))
	   (setr AUX *lex*))
      (cat V s/v (and (isftr (getftr form) 'ACTIVE)
		      (agree (getftr num) (getr NUM)))
	   (setr V *lex*))
      )
     (s/there
      (cat AUX s/qaux t (setr AUX *lex*))
      )
     (s/qaux
      (push NP s/qaux2 t () (setr SUBJ *))
      )
        ;; Note s/qaux2 exists only so we can check N/V agreement
        ;; for a question! -- messy?
        ;;     
     (s/qaux2
      (jump s/aux
	    (agree (getftr num AUX) (getr NUM))
	    ())
      )
     (s/aux
      (cat V s/v (or (isftr (getftr form) 'PASSIVE)
		     (isftr (getftr form) 'PART))
	   (progn (setr V *lex*)
		  (if (isftr (getftr form) 'PASSIVE)
		      (progn (setr VOICE 'PASSIVE)
			     (setr OBJ (getr SUBJ))
			     (setr SUBJ 'Someone)))))
      (jump s/v t
	    (setr V (getr AUX)))         ;; in case "aux" is main verb
      )     (s/v
      (push NP s/obj (and (getftr TR V)
			  (not (eq (getr VOICE) 'PASSIVE)))
	    ()
	    (setr OBJ *))
      (push NP s/mod (and (getftr INDOBJ V)
			  (eq (getr VOICE) 'PASSIVE))
	    ()
	    (progn (setr INDOBJ (getr OBJ))
		   (setr OBJ *)))
      (jump s/mod t ())
      )
     (s/obj
      (push NP s/mod (getftr INDOBJ V) ()
	    (progn (setr INDOBJ (getr OBJ))
		   (setr OBJ *)))
      (jump s/mod t ())
      )
     (s/mod    
      (push PP s/mod2 t
	    (sendr INVP t)
	    (setr VMOD *))
      (jump s/pop t ()))
     (s/mod2
      (push PP s/mod2 t
	    (sendr INVP t)
	    (setr VMOD (append (getr VMOD) *)))
      (jump s/pop t ()))
     (s/pop
      (pop t
           (format nil "~%Type:    ~a~%Subject: ~a~%Verb:    ~a~%Tense:   ~a~%VMod:    ~a~%Object:  ~a~%Ind Obj: ~a"
		   (getr TYPE)
		   (getr SUBJ)
		   (getftr root V)
		   (if (getr AUX) (getftr tns AUX) (getftr tns V))
		   (if (getr VMOD) (getr VMOD) "--")
		   (if (getr OBJ) (getr OBJ) "--")
		   (if (getr INDOBJ) (getr INDOBJ) "--")))
      )
     )
    (NP
     (regs DETNUM)
     (0 (cat NPR 3 t
	     (progn (setr NUM (getftr num))
		    *))
	(cat DET 1 t
	     (progn (setr DETNUM (getftr num))
		    *))
	(cat N 2
	     (or (isftr (getftr num) 'PL)
		 (getftr COLL))
	     (progn (setr NUM (getftr num))
		    *))
	)
     (1 (cat N 2
	     (agree (getftr num) (getr DETNUM))
	     (progn (setr NUM (getftr num))
		    *))
	)
     (2 (push PP 2 t (sendr INVP nil) ())
	(jump 3 t ())
	)
     (3	(pop t *))
     )
      ;;
      ;; PP: local reg INVP is sendr'd from calling network--
      ;; is t if the PP is a VP constituent, nil otherwise.
      ;;
    (PP	
     (regs BY TO INVP)
     (0 (cat PREP 1
	     (not (getr INVP))
	     *)
	(cat PREP 1
	     (getr INVP)
	     (progn (if (and (equal * "by")
			     (eq (getr VOICE) 'PASSIVE)
			     (eq (getr SUBJ) 'Someone))
			(setr BY t))
		    (if (and (equal * "to")
			     (getftr INDOBJ V)
			     (eq (getr INDOBJ) nil))
			(setr TO t))
		    *)))
     (1 (push NP 2 t ()
	      (progn (if (getr BY)
			 (setr SUBJ *))
		     (if (getr TO)
			 (setr INDOBJ *))
		     *)))
     (2 (pop t (if (or (getr BY)
		       (getr TO))
		   nil
		 *)))
     )
    ))
 



;;
;; Sample functions, called from within n5.
;;

(defun agree (ftrs item)
  (or (null item)
      (null ftrs)
      (isftr ftrs item)))

;;

(defun isftr (ftrs item)
  (if (listp ftrs)
      (member item ftrs)
    (eql ftrs item)))
