doctor.el 53.5 KB
Newer Older
1
;;; doctor.el --- psychological help for frustrated users
Eric S. Raymond's avatar
Eric S. Raymond committed
2

Glenn Morris's avatar
Glenn Morris committed
3
;; Copyright (C) 1985, 1987, 1994, 1996, 2000, 2001, 2002, 2003, 2004,
Glenn Morris's avatar
Glenn Morris committed
4
;;   2005, 2006, 2007  Free Software Foundation, Inc.
Eric S. Raymond's avatar
Eric S. Raymond committed
5

Eric S. Raymond's avatar
Eric S. Raymond committed
6 7 8
;; Maintainer: FSF
;; Keywords: games

Jim Blandy's avatar
Jim Blandy committed
9 10 11 12
;; 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
Eric S. Raymond's avatar
Eric S. Raymond committed
13
;; the Free Software Foundation; either version 2, or (at your option)
Jim Blandy's avatar
Jim Blandy committed
14 15 16 17 18 19 20 21
;; 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
Erik Naggum's avatar
Erik Naggum committed
22
;; along with GNU Emacs; see the file COPYING.  If not, write to the
Lute Kamstra's avatar
Lute Kamstra committed
23 24
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
Jim Blandy's avatar
Jim Blandy committed
25

26 27 28 29 30 31
;;; Commentary:

;; The single entry point `doctor', simulates a Rogerian analyst using
;; phrase-production techniques similar to the classic ELIZA demonstration
;; of pseudo-AI.

32
;; This file was for a while censored by the Communications Decency Act.
33 34
;; Some of its features were removed.  The law was promoted as a ban
;; on pornography, but it bans far more than that.  The doctor program
Richard M. Stallman's avatar
Richard M. Stallman committed
35
;; did not contain pornography, but part of it was prohibited
36 37
;; nonetheless.

38 39
;; The Supreme Court overturned the Communications Decency Act, but
;; Congress is sure to look for some other way to try to end free speech.
40
;; For information on US government censorship of the Internet, and
41
;; what you can do to protect freedom of the press, see the web
42
;; site http://www.vtw.org/
Richard M. Stallman's avatar
Richard M. Stallman committed
43 44 45
;; See also the file etc/CENSORSHIP in the Emacs distribution
;; for a discussion of why and how this file was censored, and the
;; political implications of the issue.
46

Eric S. Raymond's avatar
Eric S. Raymond committed
47
;;; Code:
Jim Blandy's avatar
Jim Blandy committed
48

49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76
(defvar **mad**)        (defvar *debug*)      (defvar *print-space*)
(defvar *print-upcase*) (defvar abuselst)     (defvar abusewords)
(defvar account)        (defvar afraidof)     (defvar arerelated)
(defvar areyou)         (defvar bak)          (defvar beclst)
(defvar bother)         (defvar bye)          (defvar canyou)
(defvar chatlst)        (defvar continue)     (defvar deathlst)
(defvar describe)       (defvar drnk)         (defvar drugs)
(defvar eliza-flag)     (defvar elizalst)     (defvar famlst)
(defvar feared)         (defvar fears)        (defvar feelings-about)
(defvar foullst)        (defvar found)        (defvar hello)
(defvar history)        (defvar howareyoulst) (defvar howdyflag)
(defvar huhlst)         (defvar ibelieve)     (defvar improve)
(defvar inter)          (defvar isee)         (defvar isrelated)
(defvar lincount)       (defvar longhuhlst)   (defvar lover)
(defvar machlst)        (defvar mathlst)      (defvar maybe)
(defvar moods)          (defvar neglst)       (defvar obj)
(defvar object)         (defvar owner)        (defvar please)
(defvar problems)       (defvar qlist)        (defvar random-adjective)
(defvar relation)       (defvar remlst)       (defvar repetitive-shortness)
(defvar replist)        (defvar rms-flag)     (defvar schoollst)
(defvar sent)           (defvar sexlst)       (defvar shortbeclst)
(defvar shortlst)       (defvar something)    (defvar sportslst)
(defvar stallmanlst)    (defvar states)       (defvar subj)
(defvar suicide-flag)   (defvar sure)         (defvar things)
(defvar thlst)          (defvar toklst)       (defvar typos)
(defvar verb)           (defvar want)         (defvar whatwhen)
(defvar whereoutp)      (defvar whysay)       (defvar whywant)
(defvar zippy-flag)     (defvar zippylst)
77

78
(defun doc// (x) x)
Jim Blandy's avatar
Jim Blandy committed
79

80
(defmacro doc$ (what)
Jim Blandy's avatar
Jim Blandy committed
81 82 83 84 85 86 87 88 89 90 91
  "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))

92
(defvar doctor-mode-map
93 94 95 96 97
  (let ((map (make-sparse-keymap)))
    (define-key map "\n" 'doctor-read-print)
    (define-key map "\r" 'doctor-ret-or-read)
    map))

98
(define-derived-mode doctor-mode text-mode "Doctor"
Jim Blandy's avatar
Jim Blandy committed
99 100 101 102 103 104 105
  "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."
  (make-doctor-variables)
  (turn-on-auto-fill)
  (doctor-type '(i am the psychotherapist \.
106
		 (doc$ please) (doc$ describe) your (doc$ problems) \.
Jim Blandy's avatar
Jim Blandy committed
107 108 109 110 111 112 113
		 each time you are finished talking, type \R\E\T twice \.))
  (insert "\n"))

(defun make-doctor-variables ()
  (make-local-variable 'typos)
  (setq typos
	(mapcar (function (lambda (x)
114 115
			    (put (car x) 'doctor-correction  (cadr x))
			    (put (cadr x) 'doctor-expansion (car (cddr x)))
Jim Blandy's avatar
Jim Blandy committed
116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158
			    (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)
159 160 161
  (setq fears '( ((doc$ whysay) you are (doc$ afraidof) (doc// feared) \?)
		 (you seem terrified by (doc// feared) \.)
		 (when did you first feel (doc$ afraidof) (doc// feared) \?) ))
Jim Blandy's avatar
Jim Blandy committed
162 163 164 165 166 167 168 169 170 171 172 173 174 175
  (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)
176 177 178
  (setq moods '( ((doc$ areyou)(doc// found) often \?)
		 (what causes you to be (doc// found) \?)
		 ((doc$ whysay) you are (doc// found) \?) ))
Jim Blandy's avatar
Jim Blandy committed
179 180 181 182 183 184 185 186 187 188 189 190 191 192
  (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
193
	'((do you drink a lot of (doc// found) \?)
Jim Blandy's avatar
Jim Blandy committed
194
	  (do you get drunk often \?)
195
	  ((doc$ describe) your drinking habits \.) ))
Jim Blandy's avatar
Jim Blandy committed
196
  (make-local-variable 'drugs)
197 198 199
  (setq drugs '( (do you use (doc// found) often \?)((doc$ areyou)
						 addicted to (doc// found) \?)(do you realize that drugs can
						 be very harmful \?)((doc$ maybe) you should try to quit using (doc// found)
Jim Blandy's avatar
Jim Blandy committed
200 201
						 \.)))
  (make-local-variable 'whywant)
202
  (setq whywant '( ((doc$ whysay) (doc// subj) might (doc$ want) (doc// obj) \?)
Jim Blandy's avatar
Jim Blandy committed
203
		   (how does it feel to want \?)
204 205 206 207 208
		   (why should (doc// subj) get (doc// obj) \?)
		   (when did (doc// subj) first (doc$ want) (doc// obj) \?)
		   ((doc$ areyou) obsessed with (doc// obj) \?)
		   (why should i give (doc// obj) to (doc// subj) \?)
		   (have you ever gotten (doc// obj) \?) ))
Jim Blandy's avatar
Jim Blandy committed
209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224
  (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 \?)
225
	  ((doc$ please) continue \.)
Jim Blandy's avatar
Jim Blandy committed
226 227
	  (go on\, don\'t be afraid \.)
	  (i need a little more detail please \.)
228
	  (you\'re being a bit brief\, (doc$ please) go into detail \.)
229
	  (can you be more explicit \?)
Jim Blandy's avatar
Jim Blandy committed
230
	  (and \?)
231
	  ((doc$ please) go into more detail \?)
Jim Blandy's avatar
Jim Blandy committed
232 233 234 235 236 237
	  (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
238 239 240
	'((tell me (doc$ something) about (doc// owner) family \.)
	  (you seem to dwell on (doc// owner) family \.)
	  ((doc$ areyou) hung up on (doc// owner) family \?)))
Jim Blandy's avatar
Jim Blandy committed
241 242
  (make-local-variable 'huhlst)
  (setq huhlst
243 244
	'(((doc$ whysay)(doc// sent) \?)
	  (is it because of (doc$ things) that you say (doc// sent) \?) ))
Jim Blandy's avatar
Jim Blandy committed
245 246
  (make-local-variable 'longhuhlst)
  (setq longhuhlst
247
	'(((doc$ whysay) that \?)
Jim Blandy's avatar
Jim Blandy committed
248
	  (i don\'t understand \.)
249 250
	  ((doc$ thlst))
	  ((doc$ areyou) (doc$ afraidof) that \?)))
251
  (make-local-variable 'feelings-about)
Jim Blandy's avatar
Jim Blandy committed
252 253
  (setq feelings-about
	'((feelings about)
254
	  (apprehensions toward)
Jim Blandy's avatar
Jim Blandy committed
255 256
	  (thoughts on)
	  (emotions toward)))
257
  (make-local-variable 'random-adjective)
Jim Blandy's avatar
Jim Blandy committed
258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282
  (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)
283
  (setq please
Jim Blandy's avatar
Jim Blandy committed
284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305
	'((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)
306
  (setq things
Jim Blandy's avatar
Jim Blandy committed
307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332
	'(;(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)
333
  (setq ibelieve
Jim Blandy's avatar
Jim Blandy committed
334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350
	'((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)
351
  (setq machlst
352 353 354
	'((you have your mind on (doc// found) \, it seems \.)
	  (you think too much about  (doc// found) \.)
	  (you should try taking your mind off of (doc// found)\.)
Jim Blandy's avatar
Jim Blandy committed
355 356 357 358 359 360
	  (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 \.)
361
	  ((doc$ please) allow me to do the questioning \.)
Jim Blandy's avatar
Jim Blandy committed
362
	  (i have asked myself that question many times \.)
363
	  ((doc$ please) try to answer that question yourself \.)))
Jim Blandy's avatar
Jim Blandy committed
364 365
  (make-local-variable 'foullst)
  (setq foullst
366 367 368
	'(((doc$ please) watch your tongue!)
	  ((doc$ please) avoid such unwholesome thoughts \.)
	  ((doc$ please) get your mind out of the gutter \.)
Jim Blandy's avatar
Jim Blandy committed
369 370 371 372
	  (such lewdness is not appreciated \.)))
  (make-local-variable 'deathlst)
  (setq deathlst
	'((this is not a healthy way of thinking \.)
373
	  ((doc$ bother) you\, too\, may die someday \?)
374
	  (i am worried by your obsession with this topic!)
Jim Blandy's avatar
Jim Blandy committed
375 376 377
	  (did you watch a lot of crime and violence on television as a child \?))
	)
  (make-local-variable 'sexlst)
378
  (setq sexlst
379 380 381 382 383 384
	'(((doc$ areyou) (doc$ afraidof) sex \?)
	  ((doc$ describe)(doc$ something) about your sexual history \.)
	  ((doc$ please)(doc$ describe) your sex life \.\.\.)
	  ((doc$ describe) your (doc$ feelings-about) your sexual partner \.)
	  ((doc$ describe) your most (doc$ random-adjective) sexual experience \.)
	  ((doc$ areyou) satisfied with (doc// lover) \.\.\. \?)))
Jim Blandy's avatar
Jim Blandy committed
385 386 387
  (make-local-variable 'neglst)
  (setq neglst
	'((why not \?)
388
	  ((doc$ bother) i ask that \?)
Jim Blandy's avatar
Jim Blandy committed
389 390 391
	  (why not \?)
	  (why not \?)
	  (how come \?)
392
	  ((doc$ bother) i ask that \?)))
Jim Blandy's avatar
Jim Blandy committed
393 394
  (make-local-variable 'beclst)
  (setq beclst '(
395 396 397 398 399 400
		 (is it because (doc// sent) that you came to me \?)
		 ((doc$ bother)(doc// sent) \?)
		 (when did you first know that (doc// sent) \?)
		 (is the fact that (doc// sent) the real reason \?)
		 (does the fact that (doc// sent) explain anything else \?)
		 ((doc$ areyou)(doc$ sure)(doc// sent) \? ) ))
Jim Blandy's avatar
Jim Blandy committed
401 402
  (make-local-variable 'shortbeclst)
  (setq shortbeclst '(
403
		      ((doc$ bother) i ask you that \?)
Jim Blandy's avatar
Jim Blandy committed
404
		      (that\'s not much of an answer!)
405
		      ((doc$ inter) why won\'t you talk about it \?)
Jim Blandy's avatar
Jim Blandy committed
406
		      (speak up!)
407 408 409
		      ((doc$ areyou) (doc$ afraidof) talking about it \?)
		      (don\'t be (doc$ afraidof) elaborating \.)
		      ((doc$ please) go into more detail \.)))
Jim Blandy's avatar
Jim Blandy committed
410 411
  (make-local-variable 'thlst)
  (setq thlst '(
412 413 414 415
		((doc$ maybe)(doc$ things)(doc$ arerelated) this \.)
		(is it because of (doc$ things) that you are going through all this \?)
		(how do you reconcile (doc$ things) \? )
		((doc$ maybe) this (doc$ isrelated)(doc$ things) \?) ))
Jim Blandy's avatar
Jim Blandy committed
416
  (make-local-variable 'remlst)
417 418 419
  (setq remlst '( (earlier you said (doc$ history) \?)
		  (you mentioned that (doc$ history) \?)
		  ((doc$ whysay)(doc$ history) \? ) ))
Jim Blandy's avatar
Jim Blandy committed
420 421 422 423
  (make-local-variable 'toklst)
  (setq toklst
	'((is this how you relax \?)
	  (how long have you been smoking	grass \?)
424
	  ((doc$ areyou) (doc$ afraidof) of being drawn to using harder stuff \?)))
Jim Blandy's avatar
Jim Blandy committed
425 426
  (make-local-variable 'states)
  (setq states
427 428 429 430 431
	'((do you get (doc// found) often \?)
	  (do you enjoy being (doc// found) \?)
	  (what makes you (doc// found) \?)
	  (how often (doc$ areyou)(doc// found) \?)
	  (when were you last (doc// found) \?)))
Jim Blandy's avatar
Jim Blandy committed
432
  (make-local-variable 'replist)
433
  (setq replist
Jim Blandy's avatar
Jim Blandy committed
434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484
	'((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 '(
485 486 487 488
		      ((doc$ describe) your (doc$ feelings-about) him \.)
		      ((doc$ areyou) a friend of Stallman \?)
		      ((doc$ bother) Stallman is (doc$ random-adjective) \?)
		      ((doc$ ibelieve) you are (doc$ afraidof) him \.)))
Jim Blandy's avatar
Jim Blandy committed
489 490
  (make-local-variable 'schoollst)
  (setq schoollst '(
491 492 493 494 495 496
		    ((doc$ describe) your (doc// found) \.)
		    ((doc$ bother) your grades could (doc$ improve) \?)
		    ((doc$ areyou) (doc$ afraidof) (doc// found) \?)
		    ((doc$ maybe) this (doc$ isrelated) to your attitude \.)
		    ((doc$ areyou) absent often \?)
		    ((doc$ maybe) you should study (doc$ something) \.)))
Jim Blandy's avatar
Jim Blandy committed
497 498 499 500
  (make-local-variable 'improve)
  (setq improve '((improve) (be better) (be improved) (be higher)))
  (make-local-variable 'elizalst)
  (setq elizalst '(
501 502 503
		   ((doc$ areyou) (doc$ sure) \?)
		   ((doc$ ibelieve) you have (doc$ problems) with (doc// found) \.)
		   ((doc$ whysay) (doc// sent) \?)))
Jim Blandy's avatar
Jim Blandy committed
504 505
  (make-local-variable 'sportslst)
  (setq sportslst '(
506 507 508
		    (tell me (doc$ something) about (doc// found) \.)
		    ((doc$ describe) (doc$ relation) (doc// found) \.)
		    (do you find (doc// found) (doc$ random-adjective) \?)))
Jim Blandy's avatar
Jim Blandy committed
509 510
  (make-local-variable 'mathlst)
  (setq mathlst '(
511 512 513
		  ((doc$ describe) (doc$ something) about math \.)
		  ((doc$ maybe) your (doc$ problems) (doc$ arerelated) (doc// found) \.)
		  (i don\'t know much (doc// found) \, but (doc$ continue)
Jim Blandy's avatar
Jim Blandy committed
514 515 516
		     anyway \.)))
  (make-local-variable 'zippylst)
  (setq zippylst '(
517 518 519
		   ((doc$ areyou) Zippy \?)
		   ((doc$ ibelieve) you have some serious (doc$ problems) \.)
		   ((doc$ bother) you are a pinhead \?)))
Jim Blandy's avatar
Jim Blandy committed
520 521
  (make-local-variable 'chatlst)
  (setq chatlst '(
522 523 524
		  ((doc$ maybe) we could chat \.)
		  ((doc$ please) (doc$ describe) (doc$ something) about chat mode \.)
		  ((doc$ bother) our discussion is so (doc$ random-adjective) \?)))
Jim Blandy's avatar
Jim Blandy committed
525 526
  (make-local-variable 'abuselst)
  (setq abuselst '(
527 528
		   ((doc$ please) try to be less abusive \.)
		   ((doc$ describe) why you call me (doc// found) \.)
Jim Blandy's avatar
Jim Blandy committed
529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563
		   (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 '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)
564 565
  (make-local-variable 'suicide-flag)
  (setq suicide-flag nil)
Jim Blandy's avatar
Jim Blandy committed
566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626
  (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)
627
(doctor-put-meaning shit 'foul)
Jim Blandy's avatar
Jim Blandy committed
628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701
(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)
702
(doctor-put-meaning pissed 'mood)
Jim Blandy's avatar
Jim Blandy committed
703 704 705 706 707 708 709 710 711 712 713 714 715
(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)
716 717
(doctor-put-meaning cunt 'sexnoun)
(doctor-put-meaning cunts 'sexnoun)
Jim Blandy's avatar
Jim Blandy committed
718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744
(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)
745
(doctor-put-meaning killing 'death)
Jim Blandy's avatar
Jim Blandy committed
746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775
(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)
776 777
(doctor-put-meaning fuck 'sexverb)
(doctor-put-meaning fucked 'sexverb)
Jim Blandy's avatar
Jim Blandy committed
778 779
(doctor-put-meaning screw 'sexverb)
(doctor-put-meaning screwing 'sexverb)
780
(doctor-put-meaning fucking 'sexverb)
Jim Blandy's avatar
Jim Blandy committed
781 782 783 784 785 786
(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)
787
(doctor-put-meaning fucks 'sexverb)
Jim Blandy's avatar
Jim Blandy committed
788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822
(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)
823
(doctor-put-meaning athletics 'sports)
Jim Blandy's avatar
Jim Blandy committed
824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904
(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))
905
    (doctor-type '(bar! (doc$ please)(doc$ continue) \.)))
Jim Blandy's avatar
Jim Blandy committed
906
   ((member sent howareyoulst)
907
    (doctor-type '(i\'m ok \.  (doc$ describe) yourself \.)))
Jim Blandy's avatar
Jim Blandy committed
908 909 910
   ((or (member sent '((good bye) (see you later) (i quit) (so long)
		       (go away) (get lost)))
	(memq (car sent)
911
	      '(bye halt break quit done exit goodbye
Jim Blandy's avatar
Jim Blandy committed
912
		    bye\, stop pause goodbye\, stop pause)))
913
    (doctor-type (doc$ bye)))
Jim Blandy's avatar
Jim Blandy committed
914
   ((and (eq (car sent) 'you)
915 916
	 (memq (cadr sent) abusewords))
    (setq found (cadr sent))
917
    (doctor-type (doc$ abuselst)))
Jim Blandy's avatar
Jim Blandy committed
918
   ((eq (car sent) 'whatmeans)
919
    (doctor-def (cadr sent)))
Jim Blandy's avatar
Jim Blandy committed
920 921 922 923 924 925 926 927 928 929 930
   ((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
			"..."
931
			'(doc// bak))))
932
   ((memq (car sent) '(are is do has have how when where who why))
933
    (doctor-type (doc$ qlist)))
Jim Blandy's avatar
Jim Blandy committed
934
   ;;   ((eq (car sent) 'forget)
935
   ;;    (set (cadr sent) nil)
936 937
   ;;    (doctor-type '((doc$ isee)(doc$ please)
   ;;     (doc$ continue)\.)))
Jim Blandy's avatar
Jim Blandy committed
938 939
   (t
    (if (doctor-defq sent) (doctor-define sent found))
940
    (if (> (length sent) 12)(setq sent (doctor-shorten sent)))
Jim Blandy's avatar
Jim Blandy committed
941 942 943 944 945 946 947 948 949 950 951 952 953
    (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))
954
	   (if (and (eq (car sent) 'do) (eq (cadr sent) 'not))
Jim Blandy's avatar
Jim Blandy committed
955
	       (cond ((zerop (random 3))
956
		      (doctor-type '(are you (doc$ afraidof) that \?)))
Jim Blandy's avatar
Jim Blandy committed
957 958
		     ((zerop (random 2))
		      (doctor-type '(don\'t tell me what to do \. i am the
959
					    doctor here!))
Jim Blandy's avatar
Jim Blandy committed
960 961
		      (doctor-rthing))
		     (t
962
		      (doctor-type '((doc$ whysay) that i shouldn\'t
963
				     (cddr sent)
Jim Blandy's avatar
Jim Blandy committed
964 965 966 967 968 969 970 971
				     \?))))
	     (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
Stefan Monnier's avatar
Stefan Monnier committed
972
      (apply 'append (mapcar (lambda (word)
Jim Blandy's avatar
Jim Blandy committed
973 974 975 976 977 978
				(if (memq word typos)
				    (get (get word 'doctor-correction) 'doctor-expansion)
				  (list word)))
			     sent))))

(defun doctor-shorten (sent)
979
  "Make a sentence manageably short using a few hacks."
Jim Blandy's avatar
Jim Blandy committed
980
  (let (foo
981
	(retval sent)
Jim Blandy's avatar
Jim Blandy committed
982 983 984 985 986 987
	(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))
988 989
	       (setq retval (doctor-fixup foo)
		     temp nil)
Jim Blandy's avatar
Jim Blandy committed
990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016
	       (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
1017
   (doctor-type (list 'the 'word x 'means (doctor-meaning x) 'to 'me))
Jim Blandy's avatar
Jim Blandy committed
1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082
   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)))

1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142
(dolist (x
         '(abort aborted aborts ask asked asks am
           applied applies apply are associate
           associated ate
           be became become becomes becoming
           been being believe believed 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 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 transferred 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))
  (put x 'doctor-sentence-type 'verb))
Jim Blandy's avatar
Jim Blandy committed
1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161

(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)))
1162 1163
    (cond ((doctor-prepp (cadr foo))
	   (setq val (doctor-getnoun (cddr foo)))
Jim Blandy's avatar
Jim Blandy committed
1164 1165
	   (cond (val val)
		 (t 'something)))
1166 1167 1168
	  ((doctor-articlep (cadr foo))
	   (setq val (doctor-getnoun (cddr foo)))
	   (cond (val (doctor-build (doctor-build (cadr foo) " ") val))
Jim Blandy's avatar
Jim Blandy committed
1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193
		 (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))))
1194 1195 1196
	(t (setq object (car x))
	   (doctor-build (doctor-build (car x) " ") (doctor-getnoun (cdr x))))
	))
Jim Blandy's avatar
Jim Blandy committed
1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211

(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)
1212 1213 1214
  (let ((xxstr (doctor-make-string xx)))
    (and (>= (length xxstr) 2)
	 (string-equal (substring (doctor-make-string xx) -2) "ly"))))
Jim Blandy's avatar
Jim Blandy committed
1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226

(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
1227
		sixth seventh eighth ninth tenth)))
1228

Jim Blandy's avatar
Jim Blandy committed
1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245
(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
1246
		good great grody gross however if ignorant
Jim Blandy's avatar
Jim Blandy committed
1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300
		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)
1301
	       (doctor-verbp (cadr foo)))
Jim Blandy's avatar
Jim Blandy committed
1302 1303
	  (rplaca foo 'i)
	(cond ((eq (car foo) 'you)
1304
	       (cond ((memq (cadr foo) '(am be been is))
Jim Blandy's avatar
Jim Blandy committed
1305
		      (rplaca (cdr foo) 'are))
1306
		     ((memq (cadr foo) '(has))
Jim Blandy's avatar
Jim Blandy committed
1307
		      (rplaca (cdr foo) 'have))
1308
		     ((memq (cadr foo) '(was))
Jim Blandy's avatar
Jim Blandy committed
1309 1310
		      (rplaca (cdr foo) 'were))))
	      ((equal (car foo) 'i)
1311
	       (cond ((memq (cadr foo) '(are is be been))
Jim Blandy's avatar
Jim Blandy committed
1312
		      (rplaca (cdr foo) 'am))
1313
		     ((memq (cadr foo) '(were))
Jim Blandy's avatar
Jim Blandy committed
1314
		      (rplaca (cdr foo) 'was))
1315
		     ((memq (cadr foo) '(has))
Jim Blandy's avatar
Jim Blandy committed
1316 1317
		      (rplaca (cdr foo) 'have))))
	      ((and (doctor-verbp (car foo))
1318 1319
		    (eq (cadr foo) 'i)
		    (not (doctor-verbp (car (cddr foo)))))
Jim Blandy's avatar
Jim Blandy committed
1320 1321 1322
	       (rplaca (cdr foo) 'me))
	      ((and (eq (car foo) 'a)
		    (doctor-vowelp (string-to-char
1323
				    (doctor-make-string (cadr foo)))))
Jim Blandy's avatar
Jim Blandy committed
1324 1325 1326
	       (rplaca foo 'an))
	      ((and (eq (car foo) 'an)
		    (not (doctor-vowelp (string-to-char
1327
					 (doctor-make-string (cadr foo))))))
Jim Blandy's avatar
Jim Blandy committed
1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346
	       (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)
1347
  (cond ((null sent)(doc$ whereoutp))
Jim Blandy's avatar
Jim Blandy committed
1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360
	((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."
Jim Blandy's avatar
Jim Blandy committed
1361
  (let ((foo (doctor-subjsearch sent key type)))
Jim Blandy's avatar
Jim Blandy committed
1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390
    (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)
1391
  (mapc 'doctor-type-symbol ans)
Jim Blandy's avatar
Jim Blandy committed
1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405
  (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))
1406
	(t (insert ?\s word)))
1407 1408 1409
  (and auto-fill-function
       (> (current-column) fill-column)
       (apply auto-fill-function nil))
Jim Blandy's avatar
Jim Blandy committed
1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448
  (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 ()
1449
  (doctor-go (doc$ whereoutp)))
Jim Blandy's avatar
Jim Blandy committed
1450 1451

(defun doctor-huh ()
1452 1453
  (cond ((< (length sent) 9) (doctor-type (doc$ huhlst)))
	(t (doctor-type (doc$ longhuhlst)))))
Jim Blandy's avatar
Jim Blandy committed
1454

1455
(defun doctor-rthing () (doctor-type (doc$ thlst)))
Jim Blandy's avatar
Jim Blandy committed
1456 1457

(defun doctor-remem () (cond ((null history)(doctor-huh))
1458
			     ((doctor-type (doc$ remlst)))))
Jim Blandy's avatar
Jim Blandy committed
1459 1460 1461

(defun doctor-howdy ()
  (cond ((not howdyflag)
1462
	 (doctor-type '((doc$ hello) what brings you to see me \?))
Jim Blandy's avatar
Jim Blandy committed
1463 1464
	 (setq howdyflag t))
	(t
1465 1466
	 (doctor-type '((doc$ ibelieve) we\'ve introduced ourselves already \.))
	 (doctor-type '((doc$ please) (doc$ describe) (doc$ things) \.)))))
Jim Blandy's avatar
Jim Blandy committed
1467 1468 1469 1470 1471 1472

(defun doctor-when ()
  (cond ((< (length (memq found sent)) 3)(doctor-short))
	(t
	 (setq sent (cdr (memq found sent)))
	 (setq sent (doctor-fixup sent))
1473
	 (doctor-type '((doc$ whatwhen)(doc// sent) \?)))))
Jim Blandy's avatar
Jim Blandy committed
1474 1475 1476 1477 1478 1479 1480

(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)
1481
		(doctor-type '(are you (doc$ sure) that is the real reason \?))
Jim Blandy's avatar
Jim Blandy committed
1482 1483 1484
		(setq things (cons (cdr sent) things)))
	       (t
		(doctor-remember sent)
1485
		(doctor-type (doc$ beclst)))))))
Jim Blandy's avatar
Jim Blandy committed
1486 1487 1488 1489 1490 1491 1492 1493 1494 1495

(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**)
1496
		(doctor-type '((doc$ areyou)
Jim Blandy's avatar
Jim Blandy committed
1497 1498 1499 1500 1501 1502 1503 1504 1505 1506
			       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 \.\.\.))
		)))
	(t
	 (cond ((equal sent (doctor-assm '(yes)))
1507
		(doctor-type '((doc$ isee) (doc$ inter) (doc$ whysay) this is so \?)))
Jim Blandy's avatar
Jim Blandy committed
1508
	       ((equal sent (doctor-assm '(because)))
1509
		(doctor-type (doc$ shortbeclst)))
Jim Blandy's avatar
Jim Blandy committed
1510
	       ((equal sent (doctor-assm '(no)))
1511 1512
		(doctor-type (doc$ neglst)))
	       (t (doctor-type (doc$ shortlst)))))))
1513

1514
(defun doctor-alcohol () (doctor-type (doc$ drnk)))
Jim Blandy's avatar
Jim Blandy committed
1515 1516 1517 1518 1519

(defun doctor-desire ()
  (let ((foo (memq found sent)))
    (cond ((< (length foo) 2)
	   (doctor-go (doctor-build (doctor-meaning found) 1)))
1520
	  ((memq (cadr foo) '(a an))
Jim Blandy's avatar
Jim Blandy committed
1521 1522 1523
	   (rplacd foo (append '(to have) (cdr foo)))
	   (doctor-svo sent found 1 nil)
	   (doctor-remember (list subj 'would 'like obj))
1524
	   (doctor-type (doc$ whywant)))
1525
	  ((not (eq (cadr foo) 'to))
Jim Blandy's avatar
Jim Blandy committed
1526 1527 1528 1529
	   (doctor-go (doctor-build (doctor-meaning found) 1)))
	  (t
	   (doctor-svo sent found 1 nil)
	   (doctor-remember (list subj 'would 'like obj))
1530
	   (doctor-type (doc$ whywant))))))
Jim Blandy's avatar
Jim Blandy committed
1531 1532

(defun doctor-drug ()
1533
  (doctor-type (doc$ drugs))
Jim Blandy's avatar
Jim Blandy committed
1534 1535 1536
  (doctor-remember (list 'you 'used found)))

(defun doctor-toke ()
1537
  (doctor-type (doc$ toklst)))
Jim Blandy's avatar
Jim Blandy committed
1538 1539

(defun doctor-state ()
1540
  (doctor-type (doc$ states))(doctor-remember (list 'you 'were found)))
Jim Blandy's avatar
Jim Blandy committed
1541 1542

(defun doctor-mood ()
1543
  (doctor-type (doc$ moods))(doctor-remember (list 'you 'felt found)))
Jim Blandy's avatar
Jim Blandy committed
1544 1545 1546

(defun doctor-fear ()
  (setq feared (doctor-setprep sent found))
1547
  (doctor-type (doc$ fears))
Jim Blandy's avatar
Jim Blandy committed
1548 1549 1550 1551 1552 1553
  (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)
1554 1555
	 (doctor-type '(why do you (doc// verb)(doc// obj) \?)))
	(t (doctor-type '((doc$ whysay)(list subj verb obj))))))
Jim Blandy's avatar
Jim Blandy committed
1556 1557

(defun doctor-symptoms ()
1558 1559
  (doctor-type '((doc$ maybe) you should consult a medical doctor\;
		 i am a psychotherapist. \.)))
Jim Blandy's avatar
Jim Blandy committed
1560 1561