# HG changeset patch
# User Jim Blandy <jimb@redhat.com>
# Date 682477527 0
# Node ID 10994e9105913611c3283c491f4a817e63c1ca66
# Parent  21aa17a1560d9623943b05b52615f9017d161881
Initial revision

diff -r 21aa17a1560d -r 10994e910591 lisp/play/doctor.el
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/play/doctor.el	Sun Aug 18 01:05:27 1991 +0000
@@ -0,0 +1,1610 @@
+;; Psychological help for frustrated users.
+;; Copyright (C) 1985, 1987 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 1, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(defun doctor-cadr (x) (car (cdr x)))
+(defun doctor-caddr (x) (car (cdr (cdr x))))
+(defun doctor-cddr (x) (cdr (cdr x)))
+
+(defun // (x) x)
+
+(defmacro $ (what)
+  "quoted arg form of doctor-$"
+  (list 'doctor-$ (list 'quote what)))
+
+(defun doctor-$ (what)
+  "Return the car of a list, rotating the list each time"
+  (let* ((vv (symbol-value what))
+	(first (car vv))
+	(ww (append (cdr vv) (list first))))
+    (set what ww)
+    first))
+
+(defvar doctor-mode-map nil)
+(if doctor-mode-map
+    nil
+  (setq doctor-mode-map (make-sparse-keymap))
+  (define-key doctor-mode-map "\n" 'doctor-read-print)
+  (define-key doctor-mode-map "\r" 'doctor-ret-or-read))
+
+(defun doctor-mode ()
+  "Major mode for running the Doctor (Eliza) program.
+Like Text mode with Auto Fill mode
+except that RET when point is after a newline, or LFD at any time,
+reads the sentence before point, and prints the Doctor's answer."
+  (interactive)
+  (text-mode)
+  (make-doctor-variables)
+  (use-local-map doctor-mode-map)
+  (setq major-mode 'doctor-mode)
+  (setq mode-name "Doctor")
+  (turn-on-auto-fill)
+  (doctor-type '(i am the psychotherapist \.
+		 ($ please) ($ describe) your ($ problems) \.
+		 each time you are finished talking, type \R\E\T twice \.))
+  (insert "\n"))
+
+(defun make-doctor-variables ()
+  (make-local-variable 'monosyllables)
+  (setq monosyllables
+	"
+     Your attitude at the end of the session was wholly unacceptable.
+     Please try to come back next time with a willingness to speak more
+     freely. If you continue to refuse to talk openly, there is little
+     I can do to help!
+")
+  (make-local-variable 'typos)
+  (setq typos
+	(mapcar (function (lambda (x)
+			    (put (car x) 'doctor-correction  (doctor-cadr x))
+			    (put (doctor-cadr x) 'doctor-expansion (doctor-caddr x))
+			    (car x)))
+		'((theyll they\'ll (they will))
+		  (theyre they\'re (they are))
+		  (hes he\'s (he is))
+		  (he7s he\'s (he is))
+		  (im i\'m (you are))
+		  (i7m i\'m (you are))
+		  (isa is\ a (is a))
+		  (thier their (their))
+		  (dont don\'t (do not))
+		  (don7t don\'t (do not))
+		  (you7re you\'re (i am))
+		  (you7ve you\'ve (i have))
+		  (you7ll you\'ll (i will)))))
+  (make-local-variable 'found)
+  (setq found nil)
+  (make-local-variable 'owner)
+  (setq owner nil)
+  (make-local-variable 'history)
+  (setq history nil)
+  (make-local-variable '*debug*)
+  (setq *debug* nil)
+  (make-local-variable 'inter)
+  (setq inter
+	'((well\,)
+	  (hmmm \.\.\.\ so\,)
+	  (so)
+	  (\.\.\.and)
+	  (then)))
+  (make-local-variable 'continue)
+  (setq continue
+	'((continue)
+	  (proceed)
+	  (go on)
+	  (keep going) ))
+  (make-local-variable 'relation)
+  (setq relation
+	'((your relationship with)
+	  (something you remember about)
+	  (your feelings toward)
+	  (some experiences you have had with)
+	  (how you feel about)))
+  (make-local-variable 'fears)
+  (setq fears '( (($ whysay) you are ($ afraidof) (// feared) \?)
+		 (you seem terrified by (// feared) \.)
+		 (when did you first feel ($ afraidof) (// feared) \?) ))
+  (make-local-variable 'sure)
+  (setq sure '((sure)(positive)(certain)(absolutely sure)))
+  (make-local-variable 'afraidof)
+  (setq afraidof '( (afraid of) (frightened by) (scared of) ))
+  (make-local-variable 'areyou)
+  (setq areyou '( (are you)(have you been)(have you been) ))
+  (make-local-variable 'isrelated)
+  (setq isrelated '( (has something to do with)(is related to)
+		     (could be the reason for) (is caused by)(is because of)))
+  (make-local-variable 'arerelated)
+  (setq arerelated '((have something to do with)(are related to)
+		     (could have caused)(could be the reason for) (are caused by)
+		     (are because of)))
+  (make-local-variable 'moods)
+  (setq moods '( (($ areyou)(// found) often \?)
+		 (what causes you to be (// found) \?)
+		 (($ whysay) you are (// found) \?) ))
+  (make-local-variable 'maybe)
+  (setq maybe
+	'((maybe)
+	  (perhaps)
+	  (possibly)))
+  (make-local-variable 'whatwhen)
+  (setq whatwhen
+	'((what happened when)
+	  (what would happen if)))
+  (make-local-variable 'hello)
+  (setq hello
+	'((how do you do \?) (hello \.) (howdy!) (hello \.) (hi \.) (hi there \.)))
+  (make-local-variable 'drnk)
+  (setq drnk
+	'((do you drink a lot of (// found) \?)
+	  (do you get drunk often \?)
+	  (($ describe) your drinking habits \.) )) 
+  (make-local-variable 'drugs)
+  (setq drugs '( (do you use (// found) often \?)(($ areyou)
+						 addicted to (// found) \?)(do you realize that drugs can
+						 be very harmful \?)(($ maybe) you should try to quit using (// found)
+						 \.)))
+  (make-local-variable 'whywant)
+  (setq whywant '( (($ whysay) (// subj) might ($ want) (// obj) \?)
+		   (how does it feel to want \?)
+		   (why should (// subj) get (// obj) \?)
+		   (when did (// subj) first ($ want) (// obj) \?)
+		   (($ areyou) obsessed with (// obj) \?)
+		   (why should i give (// obj) to (// subj) \?)
+		   (have you ever gotten (// obj) \?) ))
+  (make-local-variable 'canyou)
+  (setq canyou '((of course i can \.)
+		 (why should i \?)
+		 (what makes you think i would even want to \?)
+		 (i am the doctor\, i can do anything i damn please \.)
+		 (not really\, it\'s not up to me \.)
+		 (depends\, how important is it \?)
+		 (i could\, but i don\'t think it would be a wise thing to do \.)
+		 (can you \?)
+		 (maybe i can\, maybe i can\'t \.\.\.)
+		 (i don\'t think i should do that \.)))
+  (make-local-variable 'want)
+  (setq want '( (want) (desire) (wish) (want) (hope) ))
+  (make-local-variable 'shortlst)
+  (setq shortlst
+	'((can you elaborate on that \?)
+	  (($ please) continue \.)
+	  (go on\, don\'t be afraid \.)
+	  (i need a little more detail please \.)
+	  (you\'re being a bit brief\, ($ please) go into detail \.)
+	  (can you be more explicit \?)
+	  (and \?)
+	  (($ please) go into more detail \?)
+	  (you aren\'t being very talkative today\!)
+	  (is that all there is to it \?)
+	  (why must you respond so briefly \?)))
+
+  (make-local-variable 'famlst)
+  (setq famlst
+	'((tell me ($ something) about (// owner) family \.)
+	  (you seem to dwell on (// owner) family \.)
+	  (($ areyou) hung up on (// owner) family \?)))
+  (make-local-variable 'huhlst)
+  (setq huhlst
+	'((($ whysay)(// sent) \?)
+	  (is it because of ($ things) that you say (// sent) \?) ))
+  (make-local-variable 'longhuhlst)
+  (setq longhuhlst
+	'((($ whysay) that \?)
+	  (i don\'t understand \.)
+	  (($ thlst))
+	  (($ areyou) ($ afraidof) that \?)))
+  (make-local-variable 'feelings)
+  (setq feelings-about
+	'((feelings about)
+	  (aprehensions toward)
+	  (thoughts on)
+	  (emotions toward)))
+  (make-local-variable 'random)
+  (setq random-adjective
+	'((vivid)
+	  (emotionally stimulating)
+	  (exciting)
+	  (boring)
+	  (interesting)
+	  (recent)
+	  (random)   ;How can we omit this?
+	  (unusual)
+	  (shocking)
+	  (embarrassing)))
+  (make-local-variable 'whysay)
+  (setq whysay
+	'((why do you say)
+	  (what makes you believe)
+	  (are you sure that)
+	  (do you really think)
+	  (what makes you think) ))
+  (make-local-variable 'isee)
+  (setq isee
+	'((i see \.\.\.)
+	  (yes\,)
+	  (i understand \.)
+	  (oh \.) ))
+  (make-local-variable 'please)
+  (setq please 
+	'((please\,)
+	  (i would appreciate it if you would)
+	  (perhaps you could)
+	  (please\,)
+	  (would you please)
+	  (why don\'t you)
+	  (could you)))
+  (make-local-variable 'bye)
+  (setq bye
+	'((my secretary will send you a bill \.)
+	  (bye bye \.)
+	  (see ya \.)
+	  (ok\, talk to you some other time \.)
+	  (talk to you later \.)
+	  (ok\, have fun \.)
+	  (ciao \.)))
+  (make-local-variable 'something)
+  (setq something
+	'((something)
+	  (more)
+	  (how you feel)))
+  (make-local-variable 'things)
+  (setq things 
+	'(;(your interests in computers)   ;; let's make this less computer oriented
+	  ;(the machines you use)
+	  (your plans)
+	  ;(your use of computers)
+	  (your life)
+	  ;(other machines you use)
+	  (the people you hang around with)
+	  ;(computers you like)
+	  (problems at school)
+	  (any hobbies you have)
+	  ;(other computers you use)
+	  (your sex life)
+	  (hangups you have)
+	  (your inhibitions)
+	  (some problems in your childhood)
+	  ;(knowledge of computers)
+	  (some problems at home)))
+  (make-local-variable 'describe)
+  (setq describe
+	'((describe)
+	  (tell me about)
+	  (talk about)
+	  (discuss)
+	  (tell me more about)
+	  (elaborate on)))
+  (make-local-variable 'ibelieve)
+  (setq ibelieve 
+	'((i believe) (i think) (i have a feeling) (it seems to me that)
+	  (it looks like)))
+  (make-local-variable 'problems)
+  (setq problems '( (problems)
+		    (inhibitions)
+		    (hangups)
+		    (difficulties)
+		    (anxieties)
+		    (frustrations) ))
+  (make-local-variable 'bother)
+  (setq bother
+	'((does it bother you that)
+	  (are you annoyed that)
+	  (did you ever regret)
+	  (are you sorry)
+	  (are you satisfied with the fact that)))
+  (make-local-variable 'machlst)
+  (setq machlst 
+	'((you have your mind on (// found) \, it seems \.)
+	  (you think too much about  (// found) \.)
+	  (you should try taking your mind off of (// found)\.)
+	  (are you a computer hacker \?)))
+  (make-local-variable 'qlist)
+  (setq qlist
+	'((what do you think \?)
+	  (i\'ll ask the questions\, if you don\'t mind!)
+	  (i could ask the same thing myself \.)
+	  (($ please) allow me to do the questioning \.)
+	  (i have asked myself that question many times \.)
+	  (($ please) try to answer that question yourself \.)))
+  (make-local-variable 'elist)
+  (setq elist
+	'((($ please) try to calm yourself \.)
+	  (you seem very excited \. relax \. ($ please) ($ describe) ($ things)
+	       \.)
+	  (you\'re being very emotional \. calm down \.)))
+  (make-local-variable 'foullst)
+  (setq foullst
+	'((($ please) watch your tongue!)
+	  (($ please) avoid such unwholesome thoughts \.)
+	  (($ please) get your mind out of the gutter \.)
+	  (such lewdness is not appreciated \.)))
+  (make-local-variable 'deathlst)
+  (setq deathlst
+	'((this is not a healthy way of thinking \.)
+	  (($ bother) you\, too\, may die someday \?)
+	  (i am worried by your obssession with this topic!)
+	  (did you watch a lot of crime and violence on television as a child \?))
+	)
+  (make-local-variable 'sexlst)
+  (setq sexlst 
+	'((($ areyou) ($ afraidof) sex \?)
+	  (($ describe)($ something) about your sexual history \.)
+	  (($ please)($ describe) your sex life \.\.\.)
+	  (($ describe) your ($ feelings-about) your sexual partner \.)
+	  (($ describe) your most ($ random-adjective) sexual experience \.)
+	  (($ areyou) satisfied with (// lover) \.\.\. \?)))
+  (make-local-variable 'neglst)
+  (setq neglst
+	'((why not \?)
+	  (($ bother) i ask that \?)
+	  (why not \?)
+	  (why not \?)
+	  (how come \?)
+	  (($ bother) i ask that \?)))
+  (make-local-variable 'beclst)
+  (setq beclst '(
+		 (is it because (// sent) that you came to me \?)
+		 (($ bother)(// sent) \?)
+		 (when did you first know that (// sent) \?)
+		 (is the fact that (// sent) the real reason \?)
+		 (does the fact that (// sent) explain anything else \?)
+		 (($ areyou)($ sure)(// sent) \? ) ))
+  (make-local-variable 'shortbeclst)
+  (setq shortbeclst '(
+		      (($ bother) i ask you that \?)
+		      (that\'s not much of an answer!)
+		      (($ inter) why won\'t you talk about it \?)
+		      (speak up!)
+		      (($ areyou) ($ afraidof) talking about it \?)
+		      (don\'t be ($ afraidof) elaborating \.)
+		      (($ please) go into more detail \.)))
+  (make-local-variable 'thlst)
+  (setq thlst '(
+		(($ maybe)($ things)($ arerelated) this \.)
+		(is it because of ($ things) that you are going through all this \?)
+		(how do you reconcile ($ things) \? )
+		(($ maybe) this ($ isrelated)($ things) \?) ))
+  (make-local-variable 'remlst)
+  (setq remlst '( (earlier you said ($ history) \?)
+		  (you mentioned that ($ history) \?)
+		  (($ whysay)($ history) \? ) ))
+  (make-local-variable 'toklst)
+  (setq toklst
+	'((is this how you relax \?)
+	  (how long have you been smoking	grass \?)
+	  (($ areyou) ($ afraidof) of being drawn to using harder stuff \?)))
+  (make-local-variable 'states)
+  (setq states
+	'((do you get (// found) often \?)
+	  (do you enjoy being (// found) \?)
+	  (what makes you (// found) \?)
+	  (how often ($ areyou)(// found) \?)
+	  (when were you last (// found) \?)))
+  (make-local-variable 'replist)
+  (setq replist 
+	'((i . (you))
+	  (my . (your))
+	  (me . (you))
+	  (you . (me))
+	  (your . (my))
+	  (mine . (yours))
+	  (yours . (mine))
+	  (our . (your))
+	  (ours . (yours))
+	  (we . (you))
+	  (dunno . (do not know))
+;;	  (yes . ())
+	  (no\, . ())
+	  (yes\, . ())
+	  (ya . (i))
+	  (aint . (am not))
+	  (wanna . (want to))
+	  (gimme . (give me))
+	  (gotta . (have to))
+	  (gonna . (going to))
+	  (never . (not ever))
+	  (doesn\'t . (does not))
+	  (don\'t . (do not))
+	  (aren\'t . (are not))
+	  (isn\'t . (is not))
+	  (won\'t . (will not))
+	  (can\'t . (cannot))
+	  (haven\'t . (have not))
+	  (i\'m . (you are))
+	  (ourselves . (yourselves))
+	  (myself . (yourself))
+	  (yourself . (myself))
+	  (you\'re . (i am))
+	  (you\'ve . (i have))
+	  (i\'ve . (you have))
+	  (i\'ll . (you will))
+	  (you\'ll . (i shall))
+	  (i\'d . (you would))
+	  (you\'d . (i would))
+	  (here . (there))
+	  (please . ())
+	  (eh\, . ())
+	  (eh . ())
+	  (oh\, . ())
+	  (oh . ())
+	  (shouldn\'t . (should not))
+	  (wouldn\'t . (would not))
+	  (won\'t . (will not))
+	  (hasn\'t . (has not))))
+  (make-local-variable 'stallmanlst)
+  (setq stallmanlst '(
+		      (($ describe) your ($ feelings-about) him \.)
+		      (($ areyou) a friend of Stallman \?)
+		      (($ bother) Stallman is ($ random-adjective) \?)
+		      (($ ibelieve) you are ($ afraidof) him \.)))
+  (make-local-variable 'schoollst)
+  (setq schoollst '(
+		    (($ describe) your (// found) \.)
+		    (($ bother) your grades could ($ improve) \?)
+		    (($ areyou) ($ afraidof) (// found) \?)
+		    (($ maybe) this ($ isrelated) to your attitude \.)
+		    (($ areyou) absent often \?)
+		    (($ maybe) you should study ($ something) \.)))
+  (make-local-variable 'improve)
+  (setq improve '((improve) (be better) (be improved) (be higher)))
+  (make-local-variable 'elizalst)
+  (setq elizalst '(
+		   (($ areyou) ($ sure) \?)
+		   (($ ibelieve) you have ($ problems) with (// found) \.)
+		   (($ whysay) (// sent) \?)))
+  (make-local-variable 'sportslst)
+  (setq sportslst '(
+		    (tell me ($ something) about (// found) \.)
+		    (($ describe) ($ relation) (// found) \.)
+		    (do you find (// found) ($ random-adjective) \?)))
+  (make-local-variable 'mathlst)
+  (setq mathlst '(
+		  (($ describe) ($ something) about math \.)
+		  (($ maybe) your ($ problems) ($ arerelated) (// found) \.)
+		  (i do\'nt know much (// found) \, but ($ continue)
+		     anyway \.)))
+  (make-local-variable 'zippylst)
+  (setq zippylst '(
+		   (($ areyou) Zippy \?)
+		   (($ ibelieve) you have some serious ($ problems) \.)
+		   (($ bother) you are a pinhead \?)))
+  (make-local-variable 'chatlst)
+  (setq chatlst '(
+		  (($ maybe) we could chat \.)
+		  (($ please) ($ describe) ($ something) about chat mode \.)
+		  (($ bother) our discussion is so ($ random-adjective) \?)))
+  (make-local-variable 'abuselst)
+  (setq abuselst '(
+		   (($ please) try to be less abusive \.)
+		   (($ describe) why you call me (// found) \.)
+		   (i\'ve had enough of you!)))
+  (make-local-variable 'abusewords)
+  (setq abusewords '(boring bozo clown clumsy cretin dumb dummy
+			    fool foolish gnerd gnurd idiot jerk
+			    lose loser louse lousy luse luser
+			    moron nerd nurd oaf oafish reek
+			    stink stupid tool toolish twit))
+  (make-local-variable 'howareyoulst)
+  (setq howareyoulst  '((how are you) (hows it going) (hows it going eh)
+			(how\'s it going) (how\'s it going eh) (how goes it)
+			(whats up) (whats new) (what\'s up) (what\'s new)
+			(howre you) (how\'re you) (how\'s everything)
+			(how is everything) (how do you do)
+			(how\'s it hanging) (que pasa)
+			(how are you doing) (what do you say)))
+  (make-local-variable 'whereoutp)
+  (setq whereoutp '( huh remem rthing ) )
+  (make-local-variable 'subj)
+  (setq subj nil)
+  (make-local-variable 'verb)
+  (setq verb nil)
+  (make-local-variable 'obj)
+  (setq obj nil)
+  (make-local-variable 'feared)
+  (setq feared nil)
+  (make-local-variable 'observation-list)
+  (setq observation-list nil)
+  (make-local-variable 'repetitive-shortness)
+  (setq repetitive-shortness '(0 . 0))
+  (make-local-variable '**mad**)
+  (setq **mad** nil)
+  (make-local-variable 'rms-flag)
+  (setq rms-flag nil)
+  (make-local-variable 'eliza-flag)
+  (setq eliza-flag nil)
+  (make-local-variable 'zippy-flag)
+  (setq zippy-flag nil)
+  (make-local-variable 'lover)
+  (setq lover '(your partner))
+  (make-local-variable 'bak)
+  (setq bak nil)
+  (make-local-variable 'lincount)
+  (setq lincount 0)
+  (make-local-variable '*print-upcase*)
+  (setq *print-upcase* nil)
+  (make-local-variable '*print-space*)
+  (setq *print-space* nil)
+  (make-local-variable 'howdyflag)
+  (setq howdyflag nil)
+  (make-local-variable 'object)
+  (setq object nil))
+
+;; Define equivalence classes of words that get treated alike.
+
+(defun doctor-meaning (x) (get x 'doctor-meaning))
+
+(defmacro doctor-put-meaning (symb val)
+    "Store the base meaning of a word on the property list."
+    (list 'put (list 'quote symb) ''doctor-meaning val))
+
+(doctor-put-meaning howdy 'howdy)
+(doctor-put-meaning hi 'howdy)
+(doctor-put-meaning greetings 'howdy)
+(doctor-put-meaning hello 'howdy)
+(doctor-put-meaning tops20 'mach)
+(doctor-put-meaning tops-20 'mach)
+(doctor-put-meaning tops 'mach)
+(doctor-put-meaning pdp11 'mach)
+(doctor-put-meaning computer 'mach)
+(doctor-put-meaning unix 'mach)
+(doctor-put-meaning machine 'mach)
+(doctor-put-meaning computers 'mach)
+(doctor-put-meaning machines 'mach)
+(doctor-put-meaning pdp11s 'mach)
+(doctor-put-meaning foo 'mach)
+(doctor-put-meaning foobar 'mach)
+(doctor-put-meaning multics 'mach)
+(doctor-put-meaning macsyma 'mach)
+(doctor-put-meaning teletype 'mach)
+(doctor-put-meaning la36 'mach)
+(doctor-put-meaning vt52 'mach)
+(doctor-put-meaning zork 'mach)
+(doctor-put-meaning trek 'mach)
+(doctor-put-meaning startrek 'mach)
+(doctor-put-meaning advent 'mach)
+(doctor-put-meaning pdp 'mach)
+(doctor-put-meaning dec 'mach)
+(doctor-put-meaning commodore 'mach)
+(doctor-put-meaning vic 'mach)
+(doctor-put-meaning bbs 'mach)
+(doctor-put-meaning modem 'mach)
+(doctor-put-meaning baud 'mach)
+(doctor-put-meaning macintosh 'mach)
+(doctor-put-meaning vax 'mach)
+(doctor-put-meaning vms 'mach)
+(doctor-put-meaning ibm 'mach)
+(doctor-put-meaning pc 'mach)
+(doctor-put-meaning bitching 'foul)
+(doctor-put-meaning shit 'foul)
+(doctor-put-meaning bastard 'foul)
+(doctor-put-meaning damn 'foul)
+(doctor-put-meaning damned 'foul)
+(doctor-put-meaning hell 'foul)
+(doctor-put-meaning suck 'foul)
+(doctor-put-meaning sucking 'foul)
+(doctor-put-meaning sux 'foul)
+(doctor-put-meaning ass 'foul)
+(doctor-put-meaning whore 'foul)
+(doctor-put-meaning bitch 'foul)
+(doctor-put-meaning asshole 'foul)
+(doctor-put-meaning shrink 'foul)
+(doctor-put-meaning pot 'toke)
+(doctor-put-meaning grass 'toke)
+(doctor-put-meaning weed 'toke)
+(doctor-put-meaning marijuana 'toke)
+(doctor-put-meaning acapulco 'toke)
+(doctor-put-meaning columbian 'toke)
+(doctor-put-meaning tokin 'toke)
+(doctor-put-meaning joint 'toke)
+(doctor-put-meaning toke 'toke)
+(doctor-put-meaning toking 'toke)
+(doctor-put-meaning tokin\' 'toke)
+(doctor-put-meaning toked 'toke)
+(doctor-put-meaning roach 'toke)
+(doctor-put-meaning pills 'drug)
+(doctor-put-meaning dope 'drug)
+(doctor-put-meaning acid 'drug)
+(doctor-put-meaning lsd 'drug)
+(doctor-put-meaning speed 'drug)
+(doctor-put-meaning heroin 'drug)
+(doctor-put-meaning hash 'drug)
+(doctor-put-meaning cocaine 'drug)
+(doctor-put-meaning uppers 'drug)
+(doctor-put-meaning downers 'drug)
+(doctor-put-meaning loves 'loves)
+(doctor-put-meaning love 'love)
+(doctor-put-meaning loved 'love)
+(doctor-put-meaning hates 'hates)
+(doctor-put-meaning dislikes 'hates)
+(doctor-put-meaning hate 'hate)
+(doctor-put-meaning hated 'hate)
+(doctor-put-meaning dislike 'hate)
+(doctor-put-meaning stoned 'state)
+(doctor-put-meaning drunk 'state)
+(doctor-put-meaning drunken 'state)
+(doctor-put-meaning high 'state)
+(doctor-put-meaning horny 'state)
+(doctor-put-meaning blasted 'state)
+(doctor-put-meaning happy 'state)
+(doctor-put-meaning paranoid 'state)
+(doctor-put-meaning wish 'desire)
+(doctor-put-meaning wishes 'desire)
+(doctor-put-meaning want 'desire)
+(doctor-put-meaning desire 'desire)
+(doctor-put-meaning like 'desire)
+(doctor-put-meaning hope 'desire)
+(doctor-put-meaning hopes 'desire)
+(doctor-put-meaning desires 'desire)
+(doctor-put-meaning wants 'desire)
+(doctor-put-meaning desires 'desire)
+(doctor-put-meaning likes 'desire)
+(doctor-put-meaning needs 'desire)
+(doctor-put-meaning need 'desire)
+(doctor-put-meaning frustrated 'mood)
+(doctor-put-meaning depressed 'mood)
+(doctor-put-meaning annoyed 'mood)
+(doctor-put-meaning upset 'mood)
+(doctor-put-meaning unhappy 'mood)
+(doctor-put-meaning excited 'mood)
+(doctor-put-meaning worried 'mood)
+(doctor-put-meaning lonely 'mood)
+(doctor-put-meaning angry 'mood)
+(doctor-put-meaning mad 'mood)
+(doctor-put-meaning pissed 'mood)
+(doctor-put-meaning jealous 'mood)
+(doctor-put-meaning afraid 'fear)
+(doctor-put-meaning terrified 'fear)
+(doctor-put-meaning fear 'fear)
+(doctor-put-meaning scared 'fear)
+(doctor-put-meaning frightened 'fear)
+(doctor-put-meaning virginity 'sexnoun)
+(doctor-put-meaning virgins 'sexnoun)
+(doctor-put-meaning virgin 'sexnoun)
+(doctor-put-meaning cock 'sexnoun)
+(doctor-put-meaning cocks 'sexnoun)
+(doctor-put-meaning dick 'sexnoun)
+(doctor-put-meaning dicks 'sexnoun)
+(doctor-put-meaning cunt 'sexnoun)
+(doctor-put-meaning cunts 'sexnoun)
+(doctor-put-meaning prostitute 'sexnoun)
+(doctor-put-meaning condom 'sexnoun)
+(doctor-put-meaning sex 'sexnoun)
+(doctor-put-meaning rapes 'sexnoun)
+(doctor-put-meaning wife 'family)
+(doctor-put-meaning family 'family)
+(doctor-put-meaning brothers 'family)
+(doctor-put-meaning sisters 'family)
+(doctor-put-meaning parent 'family)
+(doctor-put-meaning parents 'family)
+(doctor-put-meaning brother 'family)
+(doctor-put-meaning sister 'family)
+(doctor-put-meaning father 'family)
+(doctor-put-meaning mother 'family)
+(doctor-put-meaning husband 'family)
+(doctor-put-meaning siblings 'family)
+(doctor-put-meaning grandmother 'family)
+(doctor-put-meaning grandfather 'family)
+(doctor-put-meaning maternal 'family)
+(doctor-put-meaning paternal 'family)
+(doctor-put-meaning stab 'death)
+(doctor-put-meaning murder 'death)
+(doctor-put-meaning murders 'death)
+(doctor-put-meaning suicide 'death)
+(doctor-put-meaning suicides 'death)
+(doctor-put-meaning kill 'death)
+(doctor-put-meaning kills 'death)
+(doctor-put-meaning die 'death)
+(doctor-put-meaning dies 'death)
+(doctor-put-meaning died 'death)
+(doctor-put-meaning dead 'death)
+(doctor-put-meaning death 'death)
+(doctor-put-meaning deaths 'death)
+(doctor-put-meaning pain 'symptoms)
+(doctor-put-meaning ache 'symptoms)
+(doctor-put-meaning fever 'symptoms)
+(doctor-put-meaning sore 'symptoms)
+(doctor-put-meaning aching 'symptoms)
+(doctor-put-meaning stomachache 'symptoms)
+(doctor-put-meaning headache 'symptoms)
+(doctor-put-meaning hurts 'symptoms)
+(doctor-put-meaning disease 'symptoms)
+(doctor-put-meaning virus 'symptoms)
+(doctor-put-meaning vomit 'symptoms)
+(doctor-put-meaning vomiting 'symptoms)
+(doctor-put-meaning barf 'symptoms)
+(doctor-put-meaning toothache 'symptoms)
+(doctor-put-meaning hurt 'symptoms)
+(doctor-put-meaning rum 'alcohol)
+(doctor-put-meaning gin 'alcohol)
+(doctor-put-meaning vodka 'alcohol)
+(doctor-put-meaning alcohol 'alcohol)
+(doctor-put-meaning bourbon 'alcohol)
+(doctor-put-meaning beer 'alcohol)
+(doctor-put-meaning wine 'alcohol)
+(doctor-put-meaning whiskey 'alcohol)
+(doctor-put-meaning scotch 'alcohol)
+(doctor-put-meaning fuck 'sexverb)
+(doctor-put-meaning fucked 'sexverb)
+(doctor-put-meaning screw 'sexverb)
+(doctor-put-meaning screwing 'sexverb)
+(doctor-put-meaning fucking 'sexverb)
+(doctor-put-meaning rape 'sexverb)
+(doctor-put-meaning raped 'sexverb)
+(doctor-put-meaning kiss 'sexverb)
+(doctor-put-meaning kissing 'sexverb)
+(doctor-put-meaning kisses 'sexverb)
+(doctor-put-meaning screws 'sexverb)
+(doctor-put-meaning fucks 'sexverb)
+(doctor-put-meaning because 'conj)
+(doctor-put-meaning but 'conj)
+(doctor-put-meaning however 'conj)
+(doctor-put-meaning besides 'conj)
+(doctor-put-meaning anyway 'conj)
+(doctor-put-meaning that 'conj)
+(doctor-put-meaning except 'conj)
+(doctor-put-meaning why 'conj)
+(doctor-put-meaning how 'conj)
+(doctor-put-meaning until 'when)
+(doctor-put-meaning when 'when)
+(doctor-put-meaning whenever 'when)
+(doctor-put-meaning while 'when)
+(doctor-put-meaning since 'when)
+(doctor-put-meaning rms 'rms)
+(doctor-put-meaning stallman 'rms)
+(doctor-put-meaning school 'school)
+(doctor-put-meaning schools 'school)
+(doctor-put-meaning skool 'school)
+(doctor-put-meaning grade 'school)
+(doctor-put-meaning grades 'school)
+(doctor-put-meaning teacher 'school)
+(doctor-put-meaning teachers 'school)
+(doctor-put-meaning classes 'school)
+(doctor-put-meaning professor 'school)
+(doctor-put-meaning prof 'school)
+(doctor-put-meaning profs 'school)
+(doctor-put-meaning professors 'school)
+(doctor-put-meaning mit 'school)
+(doctor-put-meaning emacs 'eliza)
+(doctor-put-meaning eliza 'eliza)
+(doctor-put-meaning liza 'eliza)
+(doctor-put-meaning elisa 'eliza)
+(doctor-put-meaning weizenbaum 'eliza)
+(doctor-put-meaning doktor 'eliza)
+(doctor-put-meaning atheletics 'sports)
+(doctor-put-meaning baseball 'sports)
+(doctor-put-meaning basketball 'sports)
+(doctor-put-meaning football 'sports)
+(doctor-put-meaning frisbee 'sports)
+(doctor-put-meaning gym 'sports)
+(doctor-put-meaning gymnastics 'sports)
+(doctor-put-meaning hockey 'sports)
+(doctor-put-meaning lacrosse 'sports)
+(doctor-put-meaning soccer 'sports)
+(doctor-put-meaning softball 'sports)
+(doctor-put-meaning sports 'sports)
+(doctor-put-meaning swimming 'sports)
+(doctor-put-meaning swim 'sports)
+(doctor-put-meaning tennis 'sports)
+(doctor-put-meaning volleyball 'sports)
+(doctor-put-meaning math 'math)
+(doctor-put-meaning mathematics 'math)
+(doctor-put-meaning mathematical 'math)
+(doctor-put-meaning theorem 'math)
+(doctor-put-meaning axiom 'math)
+(doctor-put-meaning lemma 'math)
+(doctor-put-meaning algebra 'math)
+(doctor-put-meaning algebraic 'math)
+(doctor-put-meaning trig 'math)
+(doctor-put-meaning trigonometry 'math)
+(doctor-put-meaning trigonometric 'math)
+(doctor-put-meaning geometry 'math)
+(doctor-put-meaning geometric 'math)
+(doctor-put-meaning calculus 'math)
+(doctor-put-meaning arithmetic 'math)
+(doctor-put-meaning zippy 'zippy)
+(doctor-put-meaning zippy 'zippy)
+(doctor-put-meaning pinhead 'zippy)
+(doctor-put-meaning chat 'chat)
+
+;;;###autoload
+(defun doctor ()
+  "Switch to *doctor* buffer and start giving psychotherapy."
+  (interactive)
+  (switch-to-buffer "*doctor*")
+  (doctor-mode))
+
+(defun doctor-ret-or-read (arg)
+  "Insert a newline if preceding character is not a newline.
+Otherwise call the Doctor to parse preceding sentence."
+  (interactive "*p")
+  (if (= (preceding-char) ?\n)
+      (doctor-read-print)
+    (newline arg)))
+
+(defun doctor-read-print nil
+  "top level loop"
+  (interactive)
+  (let ((sent (doctor-readin)))
+    (insert "\n")
+    (setq lincount (1+ lincount))
+    (doctor-doc sent)
+    (insert "\n")
+    (setq bak sent)))
+
+(defun doctor-readin nil
+  "Read a sentence.  Return it as a list of words."
+  (let (sentence)
+    (backward-sentence 1)
+    (while (not (eobp))
+      (setq sentence (append sentence (list (doctor-read-token)))))
+    sentence))
+
+(defun doctor-read-token ()
+  "read one word from buffer"
+  (prog1 (intern (downcase (buffer-substring (point)
+					     (progn
+					       (forward-word 1)
+					       (point)))))
+    (re-search-forward "\\Sw*")))
+
+;; Main processing function for sentences that have been read.
+
+(defun doctor-doc (sent)
+  (cond
+   ((equal sent '(foo))
+    (doctor-type '(bar! ($ please)($ continue))))
+   ((member sent howareyoulst)
+    (doctor-type '(i\'m ok \.  ($ describe) yourself \.)))
+   ((or (member sent '((good bye) (see you later) (i quit) (so long)
+		       (go away) (get lost)))
+	(memq (car sent)
+	      '(bye halt break quit done exit goodbye 
+		    bye\, stop pause goodbye\, stop pause)))
+    (doctor-type ($ bye)))
+   ((and (eq (car sent) 'you)
+	 (memq (doctor-cadr sent) abusewords))
+    (setq found (doctor-cadr sent))
+    (doctor-type ($ abuselst)))
+   ((eq (car sent) 'whatmeans)
+    (doctor-def (doctor-cadr sent)))
+   ((equal sent '(parse))
+    (doctor-type (list  'subj '= subj ",  "
+			'verb '= verb "\n"
+			'object 'phrase '= obj ","
+			'noun 'form '=  object "\n"
+			'current 'keyword 'is found
+			", "
+			'most 'recent 'possessive
+			'is owner "\n"
+			'sentence 'used 'was
+			"..."
+			'(// bak))))
+   ;;   ((eq (car sent) 'forget)
+   ;;    (set (doctor-cadr sent) nil)
+   ;;    (doctor-type '(($ isee)($ please)
+   ;;     ($ continue)\.)))
+   (t
+    (if (doctor-defq sent) (doctor-define sent found))
+    (if (> (length sent) 12)(doctor-shorten sent))
+    (setq sent (doctor-correct-spelling (doctor-replace sent replist)))
+    (cond ((and (not (memq 'me sent))(not (memq 'i sent))
+		(memq 'am sent))
+	   (setq sent (doctor-replace sent '((am . (are)))))))
+    (cond ((equal (car sent) 'yow) (doctor-zippy))
+	  ((< (length sent) 2)
+	   (cond ((eq (doctor-meaning (car sent)) 'howdy)
+		  (doctor-howdy))
+		 (t (doctor-short))))
+	  (t
+	   (if (memq 'am sent)
+	       (setq sent (doctor-replace sent '((me . (i))))))
+	   (setq sent (doctor-fixup sent))
+	   (if (and (eq (car sent) 'do) (eq (doctor-cadr sent) 'not))
+	       (cond ((zerop (random 3))
+		      (doctor-type '(are you ($ afraidof) that \?)))
+		     ((zerop (random 2))
+		      (doctor-type '(don\'t tell me what to do \. i am the
+					    psychiatrist here!))
+		      (doctor-rthing))
+		     (t
+		      (doctor-type '(($ whysay) that i shouldn\'t
+				     (doctor-cddr sent)
+				     \?))))
+	     (doctor-go (doctor-wherego sent))))))))
+
+;; Things done to process sentences once read.
+
+(defun doctor-correct-spelling (sent)
+  "Correct the spelling and expand each word in sentence."
+  (if sent
+      (apply 'append (mapcar '(lambda (word)
+				(if (memq word typos)
+				    (get (get word 'doctor-correction) 'doctor-expansion)
+				  (list word)))
+			     sent))))
+
+(defun doctor-shorten (sent)
+  "Make a sentence managably short using a few hacks."
+  (let (foo
+	retval
+	(temp '(because but however besides anyway until
+		    while that except why how)))
+    (while temp
+	   (setq foo (memq (car temp) sent))
+	   (if (and foo
+		    (> (length foo) 3))
+	       (setq sent foo
+		     sent (doctor-fixup sent)
+		     temp nil
+		     retval t)
+	       (setq temp (cdr temp))))
+    retval))
+
+(defun doctor-define (sent found)
+  (doctor-svo sent found 1 nil)
+  (and
+   (doctor-nounp subj)
+   (not (doctor-pronounp subj))
+   subj
+   (doctor-meaning object)
+   (put subj 'doctor-meaning (doctor-meaning object))
+   t))
+
+(defun doctor-defq (sent)
+  "Set global var FOUND to first keyword found in sentence SENT."
+  (setq found nil)
+  (let ((temp '(means applies mean refers refer related
+		      similar defined associated linked like same)))
+    (while temp
+	   (if (memq (car temp) sent)
+	       (setq found (car temp)
+		     temp nil)
+	       (setq temp (cdr temp)))))
+  found)
+
+(defun doctor-def (x)
+  (progn
+   (doctor-type (list 'the 'word x 'means (doctor-meaning x) 'to 'me)) 
+   nil))
+
+(defun doctor-forget ()
+  "Delete the last element of the history list."
+  (setq history (reverse (cdr (reverse history)))))
+
+(defun doctor-query (x)
+  "Prompt for a line of input from the minibuffer until a noun or verb is seen.
+Put dialogue in buffer."
+  (let (a
+	(prompt (concat (doctor-make-string x)
+			" what \?  "))
+	retval)
+    (while (not retval)
+	   (while (not a)
+	     (insert ?\n
+		     prompt
+		     (read-string prompt)
+		     ?\n)
+	     (setq a (doctor-readin)))
+	   (while (and a (not retval))
+		  (cond ((doctor-nounp (car a))
+			 (setq retval (car a)))
+			((doctor-verbp (car a))
+			 (setq retval (doctor-build
+				       (doctor-build x " ")
+				       (car a))))
+			((setq a (cdr a))))))
+    retval))
+
+(defun doctor-subjsearch (sent key type)
+  "Search for the subject of a sentence SENT, looking for the noun closest
+to and preceding KEY by at least TYPE words.  Set global variable subj to
+the subject noun, and return the portion of the sentence following it."
+  (let ((i (- (length sent) (length (memq key sent)) type)))
+    (while (and (> i -1) (not (doctor-nounp (nth i sent))))
+      (setq i (1- i)))
+    (cond ((> i -1)
+	   (setq subj (nth i sent))
+	   (nthcdr (1+ i) sent))
+	  (t
+	   (setq subj 'you)
+	   nil))))
+
+(defun doctor-nounp (x)
+  "Returns t if the symbol argument is a noun."
+	(or (doctor-pronounp x)
+	    (not (or (doctor-verbp x)
+		     (equal x 'not)
+		     (doctor-prepp x)
+		     (doctor-modifierp x) )) ))
+
+(defun doctor-pronounp (x)
+  "Returns t if the symbol argument is a pronoun."
+  (memq x '(
+	i me mine myself
+	we us ours ourselves ourself
+	you yours yourself yourselves
+	he him himself she hers herself
+	it that those this these things thing
+	they them themselves theirs
+	anybody everybody somebody
+	anyone everyone someone
+	anything something everything)))
+
+(mapcar (function (lambda (x) (put x 'doctor-sentence-type 'verb)))
+	'(abort aborted aborts ask asked asks am
+		applied applies apply are associate
+		associated ate
+		be became become becomes becoming
+		been being believe belived believes
+		bit bite bites bore bored bores boring bought buy buys buying
+		call called calling calls came can caught catch come
+		contract contracted contracts control controlled controls
+		could croak croaks croaked cut cuts
+		dare dared define defines dial dialed dials did die died dies
+		dislike disliked
+		dislikes do does drank drink drinks drinking
+		drive drives driving drove dying
+		eat eating eats expand expanded expands
+		expect expected expects expel expels expeled expelled
+		explain explained explains
+		fart farts feel feels felt fight fights find finds finding
+		forget forgets forgot fought found fuck fucked
+		fucking fucks
+		gave get gets getting give gives go goes going gone got gotten
+		had harm harms has hate hated hates have having
+		hear heard hears hearing help helped helping helps
+		hit hits hope hoped hopes hurt hurts
+		implies imply is
+		join joined joins jump jumped jumps
+		keep keeping keeps kept
+		kill killed killing kills kiss kissed kisses kissing
+		knew know knows
+		laid lay lays let lets lie lied lies like liked likes
+		liking listen listens
+		login look looked looking looks
+		lose losing lost
+		love loved loves loving
+		luse lusing lust lusts
+		made make makes making may mean means meant might
+		move moved moves moving must
+		need needed needs 
+		order ordered orders ought
+		paid pay pays pick picked picking picks 
+		placed placing prefer prefers put puts
+		ran rape raped rapes
+		read reading reads recall receive received receives
+		refer refered referred refers
+		relate related relates remember remembered remembers
+		romp romped romps run running runs
+		said sang sat saw say says
+		screw screwed screwing screws scrod see sees seem seemed
+		seems seen sell selling sells
+		send sendind sends sent shall shoot shot should
+		sing sings sit sits sitting sold studied study
+		take takes taking talk talked talking talks tell tells telling
+		think thinks
+		thought told took tooled touch touched touches touching
+		transfer transfered transfers transmit transmits transmitted
+		type types types typing
+		walk walked walking walks want wanted wants was watch
+		watched watching went were will wish would work worked works
+		write writes writing wrote use used uses using))
+
+(defun doctor-verbp (x) (if (symbolp x)
+			    (eq (get x 'doctor-sentence-type) 'verb)))
+
+(defun doctor-plural (x)
+  "Form the plural of the word argument."
+  (let ((foo (doctor-make-string x)))
+    (cond ((string-equal (substring foo -1) "s")
+	   (cond ((string-equal (substring foo -2 -1) "s")
+		  (intern (concat foo "es")))
+		 (t x)))
+	   ((string-equal (substring foo -1) "y")
+	    (intern (concat (substring foo 0 -1)
+			    "ies")))
+	   (t (intern (concat foo "s"))))))
+
+(defun doctor-setprep (sent key)
+  (let ((val)
+	(foo (memq key sent)))
+    (cond ((doctor-prepp (doctor-cadr foo))
+	   (setq val (doctor-getnoun (doctor-cddr foo)))
+	   (cond (val val)
+		 (t 'something)))
+	  ((doctor-articlep (doctor-cadr foo))
+	   (setq val (doctor-getnoun (doctor-cddr foo)))
+	   (cond (val (doctor-build (doctor-build (doctor-cadr foo) " ") val))
+		 (t 'something)))
+	  (t 'something))))
+
+(defun doctor-getnoun (x)
+  (cond ((null x)(setq object 'something))
+	((atom x)(setq object x))
+	((eq (length x) 1)
+	 (setq object (cond
+		       ((doctor-nounp (setq object (car x))) object)
+		       (t (doctor-query object)))))
+	((eq (car x) 'to)
+	 (doctor-build 'to\  (doctor-getnoun (cdr x))))
+	((doctor-prepp (car x))
+	 (doctor-getnoun (cdr x)))
+	((not (doctor-nounp (car x)))
+	 (doctor-build (doctor-build (cdr (assq (car x)
+						(append
+						 '((a . this)
+						   (some . this)
+						   (one . that))
+						 (list
+						  (cons
+						   (car x) (car x))))))
+				     " ")
+		       (doctor-getnoun (cdr x))))
+	(t (setq object (car x))) ))
+
+(defun doctor-modifierp (x)
+  (or (doctor-adjectivep x)
+      (doctor-adverbp x)
+      (doctor-othermodifierp x)))
+
+(defun doctor-adjectivep (x)
+  (or (numberp x)
+      (doctor-nmbrp x)
+      (doctor-articlep x)
+      (doctor-colorp x)
+      (doctor-sizep x)
+      (doctor-possessivepronounp x)))
+
+(defun doctor-adverbp (xx)
+  (string-equal (substring (doctor-make-string xx) -2) "ly"))
+
+(defun doctor-articlep (x)
+  (memq x '(the a an)))
+
+(defun doctor-nmbrp (x)
+  (memq x '(one two three four five six seven eight nine ten
+		eleven twelve thirteen fourteen fifteen
+		sixteen seventeen eighteen nineteen
+		twenty thirty forty fifty sixty seventy eighty ninety
+		hundred thousand million billion
+		half quarter
+		first second third fourth fifth
+		sixth seventh eighth nineth tenth)))
+		 
+(defun doctor-colorp (x)
+  (memq x '(beige black blue brown crimson
+		  gray grey green
+		  orange pink purple red tan tawny
+		  violet white yellow)))
+
+(defun doctor-sizep (x)
+  (memq x '(big large tall fat wide thick
+		small petite short thin skinny)))
+
+(defun doctor-possessivepronounp (x)
+  (memq x '(my your his her our their)))
+
+(defun doctor-othermodifierp (x)
+  (memq x '(all also always amusing any anyway associated awesome
+		bad beautiful best better but certain clear
+		ever every fantastic fun funny
+		good great gross growdy however if ignorant
+		less linked losing lusing many more much
+		never nice obnoxious often poor pretty real related rich
+		similar some stupid super superb
+		terrible terrific too total tubular ugly very)))
+
+(defun doctor-prepp (x)
+  (memq x '(about above after around as at
+		  before beneath behind beside between by
+		  for from in inside into
+		  like near next of on onto over
+		  same through thru to toward towards
+		  under underneath with without)))
+
+(defun doctor-remember (thing)
+  (cond ((null history)
+	 (setq history (list thing)))
+	(t (setq history (append history (list thing))))))
+
+(defun doctor-type (x)
+  (setq x (doctor-fix-2 x))
+  (doctor-txtype (doctor-assm x)))
+
+(defun doctor-fixup (sent)
+  (setq sent (append
+	      (cdr
+	       (assq (car sent)
+		     (append
+		      '((me  i)
+			(him  he)
+			(her  she)
+			(them  they)
+			(okay)
+			(well)
+			(sigh)
+			(hmm)
+			(hmmm)
+			(hmmmm)
+			(hmmmmm)
+			(gee)
+			(sure)
+			(great)
+			(oh)
+			(fine)
+			(ok)
+			(no))
+		      (list (list (car sent)
+				  (car sent))))))
+	      (cdr sent)))
+  (doctor-fix-2 sent))
+
+(defun doctor-fix-2 (sent)
+  (let ((foo sent))
+    (while foo
+      (if (and (eq (car foo) 'me)
+	       (doctor-verbp (doctor-cadr foo)))
+	  (rplaca foo 'i)
+	(cond ((eq (car foo) 'you)
+	       (cond ((memq (doctor-cadr foo) '(am be been is))
+		      (rplaca (cdr foo) 'are))
+		     ((memq (doctor-cadr foo) '(has))
+		      (rplaca (cdr foo) 'have))
+		     ((memq (doctor-cadr foo) '(was))
+		      (rplaca (cdr foo) 'were))))
+	      ((equal (car foo) 'i)
+	       (cond ((memq (doctor-cadr foo) '(are is be been))
+		      (rplaca (cdr foo) 'am))
+		     ((memq (doctor-cadr foo) '(were))
+		      (rplaca (cdr foo) 'was))
+		     ((memq (doctor-cadr foo) '(has))
+		      (rplaca (cdr foo) 'have))))
+	      ((and (doctor-verbp (car foo))
+		    (eq (doctor-cadr foo) 'i)
+		    (not (doctor-verbp (car (doctor-cddr foo)))))
+	       (rplaca (cdr foo) 'me))
+	      ((and (eq (car foo) 'a)
+		    (doctor-vowelp (string-to-char
+				    (doctor-make-string (doctor-cadr foo)))))
+	       (rplaca foo 'an))
+	      ((and (eq (car foo) 'an)
+		    (not (doctor-vowelp (string-to-char
+					 (doctor-make-string (doctor-cadr foo))))))
+	       (rplaca foo 'a)))
+	(setq foo (cdr foo))))
+    sent))
+
+(defun doctor-vowelp (x)
+  (memq x '(?a ?e ?i ?o ?u)))
+
+(defun doctor-replace (sent rlist)
+  "Replace any element of SENT that is the car of a replacement
+element pair in RLIST."
+  (apply 'append
+	 (mapcar
+	  (function
+	   (lambda (x)
+	     (cdr (or (assq x rlist)   ; either find a replacement
+		      (list x x)))))   ; or fake an identity mapping
+	  sent)))
+
+(defun doctor-wherego (sent)
+  (cond ((null sent)($ whereoutp))
+	((null (doctor-meaning (car sent)))
+	 (doctor-wherego (cond ((zerop (random 2))
+				(reverse (cdr sent)))
+			       (t (cdr sent)))))
+	(t
+	 (setq found (car sent))
+	 (doctor-meaning (car sent)))))
+
+(defun doctor-svo (sent key type mem)
+  "Find subject, verb and object in sentence SENT with focus on word KEY.
+TYPE is number of words preceding KEY to start looking for subject.
+MEM is t if results are to be put on Doctor's memory stack.
+Return in the global variables SUBJ, VERB and OBJECT."
+  (let ((foo (doctor-subjsearch sent key type) sent))
+    (or foo
+	(setq foo sent
+	      mem nil))
+    (while (and (null (doctor-verbp (car foo))) (cdr foo))
+      (setq foo (cdr foo)))
+    (setq verb (car foo))
+    (setq obj (doctor-getnoun (cdr foo)))
+    (cond ((eq object 'i)(setq object 'me))
+	  ((eq subj 'me)(setq subj 'i)))
+    (cond (mem (doctor-remember (list subj verb obj))))))
+
+(defun doctor-possess (sent key)
+  "Set possessive in SENT for keyword KEY.
+Hack on previous word, setting global variable OWNER to correct result."
+  (let* ((i (- (length sent) (length (memq key sent)) 1))
+	 (prev (if (< i 0) 'your
+		 (nth i sent))))
+    (setq owner (if (or (doctor-possessivepronounp prev)
+			(string-equal "s"
+				      (substring (doctor-make-string prev)
+						 -1)))
+		    prev
+		  'your))))
+
+;; Output of replies.
+
+(defun doctor-txtype (ans)
+  "Output to buffer a list of symbols or strings as a sentence."
+  (setq *print-upcase* t *print-space* nil)
+  (mapcar 'doctor-type-symbol ans)
+  (insert "\n"))
+
+(defun doctor-type-symbol (word)
+  "Output a symbol to the buffer with some fancy case and spacing hacks."
+  (setq word (doctor-make-string word))
+  (if (string-equal word "i") (setq word "I"))
+  (if *print-upcase*
+      (progn
+	(setq word (capitalize word))
+	(if *print-space*
+	    (insert " "))))
+  (cond ((or (string-match "^[.,;:?! ]" word)
+	     (not *print-space*))
+	 (insert word))
+	(t (insert ?\  word)))
+  (if (> (current-column) fill-column)
+      (apply auto-fill-function nil))
+  (setq *print-upcase* (string-match "[.?!]$" word)
+	*print-space* t))
+
+(defun doctor-build (str1 str2)
+  "Make a symbol out of the concatenation of the two non-list arguments."
+  (cond ((null str1) str2)
+	((null str2) str1)
+	((and (atom str1)
+	      (atom str2))
+	 (intern (concat (doctor-make-string str1)
+			 (doctor-make-string str2))))
+	(t nil)))
+
+(defun doctor-make-string (obj)
+  (cond ((stringp obj) obj)
+	((symbolp obj) (symbol-name obj))
+	((numberp obj) (int-to-string obj))
+	(t "")))
+
+(defun doctor-concat (x y)
+  "Like append, but force atomic arguments to be lists."
+  (append
+   (if (and x (atom x)) (list x) x)
+   (if (and y (atom y)) (list y) y)))
+
+(defun doctor-assm (proto)
+  (cond ((null proto) nil)
+	((atom proto) (list proto))
+	((atom (car proto))
+	 (cons (car proto) (doctor-assm (cdr proto))))
+	(t (doctor-concat (doctor-assm (eval (car proto))) (doctor-assm (cdr proto))))))
+
+;; Functions that handle specific words or meanings when found.
+
+(defun doctor-go (destination)
+  "Call a `doctor-*' function."
+  (funcall (intern (concat "doctor-" (doctor-make-string destination)))))
+
+(defun doctor-desire1 ()
+  (doctor-go ($ whereoutp)))
+
+(defun doctor-huh ()
+  (cond ((< (length sent) 9) (doctor-type ($ huhlst)))
+	(t (doctor-type ($ longhuhlst)))))
+
+(defun doctor-rthing () (doctor-type ($ thlst)))
+
+(defun doctor-remem () (cond ((null history)(doctor-huh))
+			     ((doctor-type ($ remlst)))))
+
+(defun doctor-howdy ()
+  (cond ((not howdyflag)
+	 (doctor-type '(($ hello) what brings you to see me \?))
+	 (setq howdyflag t))
+	(t
+	 (doctor-type '(($ ibelieve) we\'ve introduced ourselves already \.))
+	 (doctor-type '(($ please) ($ describe) ($ things) \.)))))
+
+(defun doctor-when ()
+  (cond ((< (length (memq found sent)) 3)(doctor-short))
+	(t
+	 (setq sent (cdr (memq found sent)))
+	 (setq sent (doctor-fixup sent))
+	 (doctor-type '(($ whatwhen)(// sent) \?)))))
+
+(defun doctor-conj ()
+  (cond ((< (length (memq found sent)) 4)(doctor-short))
+	(t
+	 (setq sent (cdr (memq found sent)))
+	 (setq sent (doctor-fixup sent))
+	 (cond ((eq (car sent) 'of)
+		(doctor-type '(are you ($ sure) that is the real reason \?))
+		(setq things (cons (cdr sent) things)))
+	       (t
+		(doctor-remember sent)
+		(doctor-type ($ beclst)))))))
+
+(defun doctor-short ()
+  (cond ((= (car repetitive-shortness) (1- lincount))
+	 (rplacd repetitive-shortness
+		 (1+ (cdr repetitive-shortness))))
+	(t
+	 (rplacd repetitive-shortness 1)))
+  (rplaca repetitive-shortness lincount)
+  (cond ((> (cdr repetitive-shortness) 6)
+	 (cond ((not **mad**)
+		(doctor-type '(($ areyou)
+			       just trying to see what kind of things
+			       i have in my vocabulary \? please try to
+			       carry on a reasonable conversation!))
+		(setq **mad** t))
+	       (t
+		(doctor-type '(i give up \. you need a lesson in creative
+				 writing \.\.\.))
+		;;(push monosyllables observation-list)
+		)))
+	(t
+	 (cond ((equal sent (doctor-assm '(yes)))
+		(doctor-type '(($ isee) ($ inter) ($ whysay) this is so \?)))
+	       ((equal sent (doctor-assm '(because)))
+		(doctor-type ($ shortbeclst)))
+	       ((equal sent (doctor-assm '(no)))
+		(doctor-type ($ neglst)))
+	       (t (doctor-type ($ shortlst)))))))
+	   
+(defun doctor-alcohol () (doctor-type ($ drnk)))
+
+(defun doctor-desire ()
+  (let ((foo (memq found sent)))
+    (cond ((< (length foo) 2)
+	   (doctor-go (doctor-build (doctor-meaning found) 1)))
+	  ((memq (doctor-cadr foo) '(a an))
+	   (rplacd foo (append '(to have) (cdr foo)))
+	   (doctor-svo sent found 1 nil)
+	   (doctor-remember (list subj 'would 'like obj))
+	   (doctor-type ($ whywant)))
+	  ((not (eq (doctor-cadr foo) 'to))
+	   (doctor-go (doctor-build (doctor-meaning found) 1)))
+	  (t
+	   (doctor-svo sent found 1 nil)
+	   (doctor-remember (list subj 'would 'like obj))
+	   (doctor-type ($ whywant))))))
+
+(defun doctor-drug ()
+  (doctor-type ($ drugs))
+  (doctor-remember (list 'you 'used found)))
+
+(defun doctor-toke ()
+  (doctor-type ($ toklst)))
+
+(defun doctor-state ()
+  (doctor-type ($ states))(doctor-remember (list 'you 'were found)))
+
+(defun doctor-mood ()
+  (doctor-type ($ moods))(doctor-remember (list 'you 'felt found)))
+
+(defun doctor-fear ()
+  (setq feared (doctor-setprep sent found))
+  (doctor-type ($ fears))
+  (doctor-remember (list 'you 'were 'afraid 'of feared)))
+
+(defun doctor-hate ()
+  (doctor-svo sent found 1 t)
+  (cond ((memq 'not sent) (doctor-forget) (doctor-huh))
+	((equal subj 'you)
+	 (doctor-type '(why do you (// verb)(// obj) \?)))
+	(t (doctor-type '(($ whysay)(list subj verb obj))))))
+
+(defun doctor-symptoms ()
+  (doctor-type '(($ maybe) you should consult a doctor of medicine\,
+		 i am a psychiatrist \.)))
+
+(defun doctor-hates ()
+  (doctor-svo sent found 1 t)
+  (doctor-hates1))
+
+(defun doctor-hates1 ()
+  (doctor-type '(($ whysay)(list subj verb obj))))
+
+(defun doctor-loves ()
+  (doctor-svo sent found 1 t)
+  (doctor-qloves))
+
+(defun doctor-qloves ()
+  (doctor-type '(($ bother)(list subj verb obj) \?)))
+
+(defun doctor-love ()
+  (doctor-svo sent found 1 t)
+  (cond ((memq 'not sent) (doctor-forget) (doctor-huh))
+	((memq 'to sent) (doctor-hates1))
+	(t
+	 (cond ((equal object 'something)
+		(setq object '(this person you love))))
+	 (cond ((equal subj 'you)
+		(setq lover obj)
+		(cond ((equal lover '(this person you love))
+		       (setq lover '(your partner))
+		       (doctor-forget)
+		       (doctor-type '(with whom are you in love \?)))
+		      ((doctor-type '(($ please)
+				      ($ describe)
+				      ($ relation)
+				      (// lover)
+				      \.)))))
+	       ((equal subj 'i)
+		(doctor-txtype '(we were discussing you!)))
+	       (t (doctor-forget)
+		  (setq obj 'someone)
+		  (setq verb (doctor-build verb 's))
+		  (doctor-qloves))))))
+
+(defun doctor-mach ()
+  (setq found (doctor-plural found))
+  (doctor-type ($ machlst)))
+
+(defun doctor-sexnoun () (doctor-sexverb))
+
+(defun doctor-sexverb ()
+  (if (or (memq 'me sent)(memq 'myself sent)(memq 'i sent))
+      (doctor-foul)
+    (doctor-type ($ sexlst))))
+
+(defun doctor-death () (doctor-type ($ deathlst)))
+
+(defun doctor-foul ()
+  (doctor-type ($ foullst)))
+
+(defun doctor-family ()
+  (doctor-possess sent found)
+  (doctor-type ($ famlst)))
+
+;; I did not add this -- rms.
+;; But he might have removed it.  I put it back.  --roland
+(defun doctor-rms ()
+  (cond (rms-flag (doctor-type ($ stallmanlst)))
+	(t (setq rms-flag t) (doctor-type '(do you know Stallman \?)))))
+
+(defun doctor-school nil (doctor-type ($ schoollst)))
+
+(defun doctor-eliza ()
+  (cond (eliza-flag (doctor-type ($ elizalst)))
+	(t (setq eliza-flag t)
+	   (doctor-type '((// found) \? hah !
+			  ($ please) ($ continue) \.)))))
+	   
+(defun doctor-sports ()  (doctor-type ($ sportslst)))
+
+(defun doctor-math () (doctor-type ($ mathlst)))
+
+(defun doctor-zippy ()
+  (cond (zippy-flag (doctor-type ($ zippylst)))
+	(t (setq zippy-flag t)
+	   (doctor-type '(yow! are we interactive yet \?)))))
+
+
+(defun doctor-chat () (doctor-type ($ chatlst)))
+
+(defun doctor-strangelove ()
+  (interactive)
+  (insert "Mein fuhrer!!\n")
+  (doctor-read-print))