; 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) ))

You are viewing proxied material from gopher.floodgap.com. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.