; ELIZA - WORKSHEET #6

(DEFUN ELIZA()
	(SETQ WWORDCOUNT 0)
	(SETQ PUNTCOUNT 0)
	(FORMAT T "WELCOME TO MY SOFA~%")
	(FORMAT T "PLEASE ENCLOSE YOUR INPUT IN PARENTHESES ~%")
  (LOOP	(SETQ S (YOU-ME-MAP (READ)))
	(COND	((MATCH '(BYE) S)
		 (RETURN 'GOODBYE))
		((MATCH '(YOU ARE (* X)) S)
		 (PRINTL (APPEND '(PLEASE TELL ME)
				  (LIST (WWORD))
				 '(YOU ARE)
				  X)))
		((MATCH '(YOU HAVE (* X)) S)
		 (PRINTL (APPEND '(HOW LONG HAVE YOU HAD) X)) )
		((MATCH '(YOU FEEL (* X)) S)
		 (PRINTL '(I SOMETIMES FEEL THE SAME WAY)) )
		((MATCH '(BECAUSE (* X)) S)
		 (PRINTL '(IS THAT REALLY THE REASON) ))
		((MATCH NIL S)(FORMAT T "SAY SOMETHING~%"))
		((MATCH '(YES (* X)) S)
		 (PRINTL (APPEND '(HOW CAN YOU BE SO SURE) X)) )
		((MATCH '(ME ARE (* X)) S)
		 (PRINTL (APPEND '(OH YEAH I AM) X)) )
		((MATCH '((VERB V) (* X)) S)
		 (PRINTL (APPEND '(OY YOI YOI HE WANTS THAT
				   I SHOULD GO AND) (LIST V) X) ) )
		((MATCH '((WPRED W)(* X)) S)
		 (PRINTL (APPEND '(YOU TELL ME)(LIST W)) ) )
		((MATCH '((DPRED W) ME (* X)) S)
		 (PRINTL (APPEND '(PERHAPS I)(LIST W) X) ) )
		((MATCH '(DO ME THINK (* X)) S)(PRINTL '(I THINK YOU
			SHOULD ANSWER THAT YOURSELF)))
		((MEMBER 'DREAM S)(FORMAT T " FOR DREAM ANALYSIS SEE FREUD~%"))
		((MEMBER 'LOVE S)(FORMAT T "ALL IS FAIR IN LOVE AND WAR~%"))
		((MEMBER 'NO S)(FORMAT T "DONT BE SO NEGATIVE~%"))
		((MEMBER 'MAYBE S)(FORMAT T "BE MORE DECISIVE~%"))
		((MEMBER 'YOU S)(PRINTL S))
	        (T	
			(SETQ PUNTCOUNT (+ 1 PUNTCOUNT))
			(IF(= PUNTCOUNT 6)(SETQ PUNTCOUNT 0))
			(PRINTL (GETNTH PUNTCOUNT PUNTS)) ) ) )
	) 

(DEFUN PRINTL (MESSAGE)
  (MAPCAR #'(LAMBDA (TXT) (FORMAT T "~A " TXT) )MESSAGE)
  (TERPRI)
)

(DEFUN WWORD ()
  (SETQ WWORDCOUNT (+ 1 WWORDCOUNT))
	(IF (= WWORDCOUNT 5)(SETQ WWORDCOUNT 0))
             (GETNTH WWORDCOUNT
		 '(WHEN WHY WHERE WHENEVER THAT)))

(DEFUN WPRED (W)
 (MEMBER W '(WHY WHERE WHEN WHAT)) )

(DEFUN DPRED (W)
 (MEMBER W '(DO CAN SHOULD WOULD)) )

(DEFUN GETNTH (N LST)
 (COND  ((NULL LST) NIL)
	((ZEROP N)(CAR LST))
	(T (GETNTH (- N 1)(CDR LST))) ))

(SETQ PUNTS   '((PLEASE GO ON)
		(TELL ME MORE)
		(I SEE)
		(WHAT DOES THAT INDICATE)
		(BUT WHY BE CONCERNED ABOUT IT)
		(JUST TELL ME HOW YOU FEEL) ))

(DEFUN YOU-ME (W)
 (COND	((EQ W 'I) 'YOU)
	((EQ W 'ME) 'YOU)
	((EQ W 'YOU) 'ME)
	((EQ W 'MY) 'YOUR)
	((EQ W 'YOUR) 'MY)
	((EQ W 'YOURS) 'MINE)
	((EQ W 'MINE) 'YOURS)
	((EQ W 'AM) 'ARE)
	(T W) ) )

(DEFUN YOU-ME-MAP (LST) (MAPCAR 'YOU-ME LST))

(DEFUN VERB (W)
 (MEMBER W '(GO HAVE BE TRY EAT TAKE HELP MAKE GET JUMP
		 WRITE TYPE FILL PUT TURN COMPUTE
		 THINK DRINK BLINK CRASH CRUNCH ADD) ) )

; MATCH.LSP -- a recursive pattern-matching function
;	for use in production-systems programming.
(DEFUN MATCH (P S)
  (COND
	((NULL P)(NULL S))	;case I: both P and S null


	((ATOM (CAR P))		;case II: CAR P is an atom
	 (AND	S			;S must not be null.
		(EQUAL (CAR P) (CAR S))
		(MATCH (CDR P) (CDR S)) ) )

	((AND			;case III: P starts with ? form.
		S			
		(EQ (CAAR P) '?) )
	 (COND	((MATCH (CDR P)(CDR S))	(SET (CADAR P) (CAR S)) T)
		(T NIL) ) )

	((EQ (CAAR P) '*)	;case IV: P starts with * form.
	 (COND
		((AND S (MATCH (CDR P)(CDR S)))		;subcase 1
		 (SET (CADAR P) (LIST (CAR S))) T)

		((MATCH (CDR P) S)			;subcase 2
		 (SET (CADAR P) NIL) T)

		((AND S (MATCH P (CDR S)))		;subcase 3
		 (SET (CADAR P) (CONS (CAR S)(EVAL (CADAR P)))) T)

		(T NIL) ) )

	((AND			;case V: P starts with predicate form.
		S			
		(APPLY (CAAR P) (LIST (CAR S)))
		(MATCH (CDR P) (CDR S)) )
	 		(SET (CADAR P)(CAR S)) T)

	(T NIL)
 ) )