; ELIZA PROGRAM

(DEFUN ELIZA()
        (SETF WWORDCOUNT 0)
        (SETF PUNTCOUNT 0)
        (FORMAT T "WELCOME TO MY SOFA~%")
        (FORMAT T "PLEASE ENCLOSE YOUR INPUT IN PARENTHESES ~%")
  (LOOP (SETF 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
                        (SETF PUNTCOUNT (+ 1 PUNTCOUNT))
                        (IF (= PUNTCOUNT 6) (SETF PUNTCOUNT 0))
                        (PRINTL (GETNTH PUNTCOUNT PUNTS)) ) ) )
        )

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

(DEFUN WWORD ()
  (SETF WWORDCOUNT (+ 1 WWORDCOUNT))
        (IF (= WWORDCOUNT 5) (SETF 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) (FIRST LST))
        (T (GETNTH (- N 1) (REST LST))) ))

(SETF 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 (FIRST P))       ;case II: FIRST P is an atom
         (AND   S                       ;S must not be null.
                (EQUAL (FIRST P) (FIRST S))
                (MATCH (REST P) (REST S)) ) )

        ((AND                   ;case III: P starts with ? form.
                S
                (EQ (FIRST (FIRST P)) '?) )
         (COND  ((MATCH (REST P)(REST S))
                        (SET (FIRST (REST (FIRST P))) (FIRST S)) T)
                (T NIL) ) )

        ((EQ (FIRST (FIRST P)) '*)       ;case IV: P starts with * form.
         (COND
                ((AND S (MATCH (REST P) (REST S)))         ;subcase 1
                 (SET (FIRST (REST (FIRST P))) (LIST (FIRST S))) T)

                ((MATCH (REST P) S)                      ;subcase 2
                 (SET (FIRST (REST (FIRST P))) NIL) T)

                ((AND S (MATCH P (REST S)))              ;subcase 3
                 (SET (FIRST (REST (FIRST P)))
                         (CONS (FIRST S) (EVAL (FIRST (REST (FIRST P)))))
                 ) T)

                (T NIL) ) )

        ((AND                   ;case V: P starts with predicate form.
                S
                (APPLY (FIRST (FIRST P)) (LIST (FIRST S)))
                (MATCH (REST P) (REST S)) )
                        (SET (FIRST (REST (FIRST P))) (FIRST S)) T)

        (T NIL)
 ) )