(DEFUN TOP-LEVEL ()
  (DECLARE (SPECIAL *SHOW-SYNTAX?*))
  (DECLARE (SPECIAL *SHOW-SEMANTICS?*))
  (declare (special *time*))
  (declare (ignore semantics))
  (WHEN (Y-OR-N-P "~&Shall I clear the database?")
    (DB-CLEAR)
    (setf *time* 0))
  (LOOP
    (FORMAT T "~&>")
    (LET ((SENT (READ-LINE)))
      (COND ((eq (length sent) 0))
	    ((EQ (AREF SENT 0) #\( )
	     (FORMAT T "~&= ~a" (EVAL (READ-FROM-STRING SENT))))
	    (T (LET ((PARSE (CAR (P SENT))))
		 (IF *SHOW-SYNTAX?* (FORMAT T "~& Syntax: ~a" PARSE))
		 (PHRASE-SEMANTICS PARSE)))))))

(DEFUN SAY-PP-OR-NP (PP-OR-NP)
  (COND ((AND (LISTP PP-OR-NP) (EQ (CAR PP-OR-NP) :RELATION))
	 (FORMAT T "~a " (SECOND PP-OR-NP))
	 (let ((loc (GETF PP-OR-NP :LOCATION)))
	   (if loc
	       (say-np loc)
	     (say-s (getf pp-or-np :action)))))
	(T (SAY-NP PP-OR-NP))))

(defun say-s (s)
  (let ((subj (cadr (member ':agent s)))
	(obj (cadr (member ':patient s)))
	(bene (cadr (member ':beneficiary s)))
	(verb (car s))
	(tense (cadr (member ':tense s)))
	(loc (cadr (member ':locative s)))
	(time-loc (cadr (member ':time-locative s))))
    (say-np subj)
    (if (eq tense 'past)
	(format t " ~a+past " verb)
      (format t " ~a+pres " verb))
    (if bene (say-np bene))
    (if obj (say-np obj))
    (if loc (say-pp-or-np loc))))
    
(DEFUN PROCESS-SENTENCE (SENTENCE)
  (DECLARE (SPECIAL *SHOW-SEMANTICS?*))
  (declare (special *time*))
  (setf sentence (add-feature SENTENCE :time *time*)) 
  (IF *SHOW-SEMANTICS?* (FORMAT T "~& Semantics: ~s~%" SENTENCE))
  (DB-ADD SENTENCE)
  (setf *time* (+ *time* 1))
  (FORMAT T "~&OK."))

(DEFUN Y/N-QUESTION (QUESTION)
  (DECLARE (SPECIAL *SHOW-SEMANTICS?*))
  (IF *SHOW-SEMANTICS?*
      (FORMAT T "~& Semantics: Yes/No-Question ~s~%" QUESTION))
  (LET ((E (MATCH QUESTION)))
    (COND ((NULL E)
	   (if (and (member ':time-locative question)
		    (correct-order question))
	       (format t "~&YES.")
	     (FORMAT T "~&I DON'T THINK SO.")))
	  (T (FORMAT T "~&YES.")))))

(DEFUN WH-QUESTION (WH QUESTION)
  (DECLARE (SPECIAL *SHOW-SEMANTICS?*))
  (IF *SHOW-SEMANTICS?* (FORMAT T "~& Semantics: WH-Question ~a ~s~%" WH QUESTION))
  (LET ((ENVS (DB-MATCH-N QUESTION)))
    (COND ((NULL ENVS)
	   (if (member ':time-locative question)
	       (let ((resp (find-neighbor question)))
		 (if resp
		     (say-pp-or-np resp)
		   (FORMAT T "~&I DON'T KNOW.")))))
	  (T (LET ((ANSWER (REMOVE-DUPLICATES
			     (MAPCAR #'(LAMBDA (E) (USER::INSTANTIATE WH E))
				     ENVS))))
	       (SAY-RESPONSE ANSWER)
	       (IF *SHOW-SEMANTICS?*
		   (FORMAT T "~& Answer Semantics: ~s~%" ANSWER)))))))


(defun match (s)
  (declare (special *db*))
  (let ((subj (cadr (member ':agent s)))
	(obj (cadr (member ':patient s)))
	(bene (cadr (member ':beneficiary s)))
	(verb (car s))
	(tense (cadr (member ':tense s)))
	(loc (cadr (member ':locative s)))
	(time-loc (cadr (member ':time-locative s))))
    (remove-if #'null
		(mapcar
		 #'(lambda (db-s)
		     (let ((db-subj (cadr (member ':agent db-s)))
			   (db-obj (cadr (member ':patient db-s)))
			   (db-bene (cadr (member ':beneficiary db-s)))
			   (db-verb (car db-s))
			   (db-tense (cadr (member ':tense db-s)))
			   (db-loc (cadr (member ':locative db-s)))
			   (db-time-loc (cadr (member ':time-locative db-s))))
		       (if (not (and (eq db-subj subj) (eq db-verb verb)))
			   nil
			 (if (and (or (or (not obj) (not db-obj))
				      (equal obj db-obj))
				  (or (or (not bene) (not db-bene))
				      (equal bene db-bene))
				  (or (or (not tense) (not db-tense))
				      (equal tense db-tense))
				  (or (or (not loc) (not db-loc))
				      (equal loc db-loc))
				  (or (or (not time-loc) (not db-time-loc))
				      (equal time-loc db-time-loc)))
			     db-s))))
		 *db*))))

(defun correct-order (question)
  (defun main-iter (one two rel)
    (if (null one)
	nil
      (if (sub-iter (first one) two rel)
	  t
	(main-iter (cdr one) two rel))))
  (defun sub-iter (event1 two rel)
    (if (null two)
	nil
      (if (apply rel (list (get-time event1) (get-time (car two))))
	  t
	(sub-iter event1 (cdr two) rel))))
  (let ((events1 (match (remove-time-loc question)))
	(events2 (match (get-ref-action question)))
	(direction (get-time-relation question)))
    (if (or (null events1) (null events2))
	nil
      (main-iter events1 events2 direction))))

(defun find-neighbor (question)
  (declare (special *db*))
  (defun iter1 (matches db)
    (if matches
	(let ((time (get-time (car matches))))
	  (iter2 time db))))
  (defun iter2 (time events)
    (if (null events)
	nil
      (let ((time2 (get-time (car events))))
	(if (= 1 (abs (- time time2)))
   	    (if (> time time2)
		(append '(:relation after :action) (list (car events)))
	      (append '(:relation before :action) (list (car events))))
	  (iter2 time (cdr events))))))
  (iter1 (match (remove-time-loc question)) (cdr *db*)))

(defun remove-time-loc (question)
  (if (null question)
      question
    (if (eq (car question) ':time-locative)
	(cddr question)
      (cons (car question) (remove-time-loc (cdr question))))))

(defun get-ref-action (question)
  (cadr (member ':action (cadr (member ':time-locative question)))))

(defun get-time-relation (question)
  (let ((word (cadr (member ':relation
			    (cadr (member ':time-locative question))))))
    (if (eq word 'before)
	#'<
      #'>)))

(defun get-time (action)
  (cadr (member ':time action)))