; shrink.lsp - a "doctor" like program for xlisp
;
;   Donated to amus By Tom Niccum of Beta Research
;
;   Taken from the book:
;	The Elements of Arificial Intelligence
;	An Introduction using Lisp - by Steven L. Tanimoto, 
;		Computer Science Press, 1987
;




(defun printl (message)
	(prog ()
		(MAPCAR
 			(FUNCTION (LAMBDA (TXT)
				(PROG () (PRIN1 TXT) (princ " " )) ))
			MESSAGE)
			(terpri) ) )

(defun wword ()
	(setq wwordcount (+ wwordcount 1))
	(cond ((equal wwordcount 3) (setq wwordcount 0)))
	(nth wwordcount '(when why where)) )

(defun wpred (w)
	(member w '(why where when what)) )

(defun dpred (w)
	(member w '(do can should would)) )

(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 youme (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 youmemap (lst)
  (mapcar (function youme) lst))

(defun verbp (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) ) )

(defun match (p s)
  (cond 
    (( null p) (null s))
    ((atom (car p))
     (and s
       (equal (car p) (car s)) 
	(match (cdr p) (cdr s)) ) )
       ((and 
         s
         (eq (caar p) '?) )
        (cond ((match (cdr p) (cdr s))
               (set (cadar p) (car s))
               t)
              (t nil) ) )

       ((eq (caar p) '*)
        (cond
          ((and s (match (cdr p) (cdr s)))
           (set (cadar p) (list (car s))) t)
          ((match (cdr p) s)
           (set (cadar p) nil) t)
          ((and s (match p (cdr s)))
           (set (cadar p) (cons (car s) (eval (cadar p)))) t)
          (t nil) ) )

       ((and
          s
          (apply (caar p) (list (car s)))
          (match (cdr p) (cdr s)) )
         (set (cadar p)(car s)) t)

       (t nil) ) )



(defun shrink ()
  (prog ()
    (setq wwordcount 0)
    (setq puntcount  0)
    (princ "please lie down on the couch")
    (terpri)
    (princ "please enclose your input in parentheses")
    (terpri)
loop (setq s (youmemap (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 '(because (* x)) s)
         (princ "is that really the reason") 
	 (terpri) )
	((match nil s) (princ "please say something, anything")
	 (terpri) )
	((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 '((verbp v) (* x)) s)
	 (printl (append '(oy  s/he wants that i should go and)
		(list v) x) ) )
	((match '((wpred w) (* x)) s)
	 (printl (append '(you tell me) (list w) x) ) )
	((match '((dpred w) me (* x)) s)
	 (printl (append '(perhaps i)(list w) x) ) )
	((match '(do me think (* x)) s) 
	 (princ "I think that you should answer that yourself")
	 (terpri) )
	((member 'dream s)
	 (princ "for dream analysis see freud")
	 (terpri) )
	((member 'love s)
	 (princ "all is fair in love and war")
	 (terpri) )
	((member 'no s)
	 (princ "negativity will get you nowhere")
	 (terpri) )
	((member 'maybe s)
	 (princ "be more decisive")
	 (terpri) )
	((member 'you s) (printl s))

	(t (setq puntcount (+ puntcount 1))
	   (cond ((equal puntcount 7)
		(setq puntcount 0)))
	   (printl (nth puntcount punts)) ) )
	(go loop) ))


.