![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to doctor.el CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / contrib / emacs / lisp|
Return to doctor.el CVS log | Up to [CSRG BSD Unix] / 43BSD / contrib / emacs / lisp |
1.1 root 1: ;; Psychological help for frustrated users.
2: ;; Copyright (C) 1985 Sidney Markowitz and Richard M. Stallman
3:
4: ;; This file is part of GNU Emacs.
5:
6: ;; GNU Emacs is distributed in the hope that it will be useful,
7: ;; but WITHOUT ANY WARRANTY. No author or distributor
8: ;; accepts responsibility to anyone for the consequences of using it
9: ;; or for whether it serves any particular purpose or works at all,
10: ;; unless he says so in writing. Refer to the GNU Emacs General Public
11: ;; License for full details.
12:
13: ;; Everyone is granted permission to copy, modify and redistribute
14: ;; GNU Emacs, but only under the conditions described in the
15: ;; GNU Emacs General Public License. A copy of this license is
16: ;; supposed to have been given to you along with GNU Emacs so you
17: ;; can know your rights and responsibilities. It should be in a
18: ;; file named COPYING. Among other things, the copyright notice
19: ;; and this notice must be preserved on all copies.
20:
21:
22: (defun cadr (x) (car (cdr x)))
23: (defun caddr (x) (car (cdr (cdr x))))
24: (defun cddr (x) (cdr (cdr x)))
25:
26: (defun member (x y)
27: "Like memq, but uses equal for comparison"
28: (while (and y (not (equal x (car y))))
29: (setq y (cdr y)))
30: y)
31:
32: (defun random-range (top)
33: "Return a random nonnegative integer less than TOP."
34: (% (logand (random) 0777777) top))
35:
36: (defun // (x) x)
37:
38: (defmacro $ (what)
39: "quoted arg form of doctor-$"
40: (list 'doctor-$ (list 'quote what)))
41:
42: (defun doctor-$ (what)
43: "Return the car of a list, rotating the list each time"
44: (let* ((vv (symbol-value what))
45: (first (car vv))
46: (ww (append (cdr vv) (list first))))
47: (set what ww)
48: first))
49:
50: (defvar doctor-mode-map nil)
51: (if doctor-mode-map
52: nil
53: (setq doctor-mode-map (make-sparse-keymap))
54: (define-key doctor-mode-map "\n" 'doctor-read-print)
55: (define-key doctor-mode-map "\r" 'doctor-ret-or-read))
56:
57: (defun doctor-mode ()
58: "Major mode for running the Doctor (Eliza) program.
59: Like Text mode with Auto Fill mode
60: except that RET when point is after a newline, or LFD at any time,
61: reads the sentence before point, and prints the Doctor's answer."
62: (interactive)
63: (text-mode)
64: (make-doctor-variables)
65: (use-local-map doctor-mode-map)
66: (setq major-mode 'doctor-mode)
67: (setq mode-name "Doctor")
68: (turn-on-auto-fill)
69: (doctor-type '(i am the psychotherapist \.
70: ($ please) ($ describe) your ($ problems) \.
71: each time you are finished talking, type \R\E\T twice \.))
72: (insert "\n"))
73:
74: (defun make-doctor-variables ()
75: (make-local-variable 'monosyllables)
76: (setq monosyllables
77: "
78: Your attitude at the end of the session was wholly unacceptable.
79: Please try to come back next time with a willingness to speak more
80: freely. If you continue to refuse to talk openly, there is little
81: I can do to help!
82: ")
83: (make-local-variable 'typos)
84: (setq typos
85: (mapcar (function (lambda (x)
86: (put (car x) 'doctor-correction (cadr x))
87: (put (cadr x) 'doctor-expansion (caddr x))
88: (car x)))
89: '((theyll they\'ll (they will))
90: (theyre they\'re (they are))
91: (hes he\'s (he is))
92: (he7s he\'s (he is))
93: (im i\'m (you are))
94: (i7m i\'m (you are))
95: (isa is\ a (is a))
96: (thier their (their))
97: (dont don\'t (do not))
98: (don7t don\'t (do not))
99: (you7re you\'re (i am))
100: (you7ve you\'ve (i have))
101: (you7ll you\'ll (i will)))))
102: (make-local-variable 'found)
103: (setq found nil)
104: (make-local-variable 'owner)
105: (setq owner nil)
106: (make-local-variable 'history)
107: (setq history nil)
108: (make-local-variable '*debug*)
109: (setq *debug* nil)
110: (make-local-variable 'inter)
111: (setq inter
112: '((well\,)
113: (hmmm \.\.\.\ so\,)
114: (so)
115: (\.\.\.and)
116: (then)))
117: (make-local-variable 'continue)
118: (setq continue
119: '((continue)
120: (proceed)
121: (go on)
122: (keep going) ))
123: (make-local-variable 'relation)
124: (setq relation
125: '((your relationship with)
126: (something you remember about)
127: (your feelings toward)
128: (some experiences you have had with)
129: (how you feel about)))
130: (make-local-variable 'fears)
131: (setq fears '( (($ whysay) you are ($ afraidof) (// feared) \?)
132: (you seem terrified by (// feared) \.)
133: (when did you first feel ($ afraidof) (// feared) \?) ))
134: (make-local-variable 'sure)
135: (setq sure '((sure)(positive)(certain)(absolutely sure)))
136: (make-local-variable 'afraidof)
137: (setq afraidof '( (afraid of) (frightened by) (scared of) ))
138: (make-local-variable 'areyou)
139: (setq areyou '( (are you)(have you been)(have you been) ))
140: (make-local-variable 'isrelated)
141: (setq isrelated '( (has something to do with)(is related to)
142: (could be the reason for) (is caused by)(is because of)))
143: (make-local-variable 'arerelated)
144: (setq arerelated '((have something to do with)(are related to)
145: (could have caused)(could be the reason for) (are caused by)
146: (are because of)))
147: (make-local-variable 'moods)
148: (setq moods '( (($ areyou)(// found) often \?)
149: (what causes you to be (// found) \?)
150: (($ whysay) you are (// found) \?) ))
151: (make-local-variable 'maybe)
152: (setq maybe
153: '((maybe)
154: (perhaps)
155: (possibly)))
156: (make-local-variable 'whatwhen)
157: (setq whatwhen
158: '((what happened when)
159: (what would happen if)))
160: (make-local-variable 'hello)
161: (setq hello
162: '((how do you do \?) (hello \.) (howdy!) (hello \.) (hi \.) (hi there \.)))
163: (make-local-variable 'drnk)
164: (setq drnk
165: '((do you drink a lot of (// found) \?)
166: (do you get drunk often \?)
167: (($ describe) your drinking habits \.) ))
168: (make-local-variable 'drugs)
169: (setq drugs '( (do you use (// found) often \?)(($ areyou)
170: addicted to (// found) \?)(do you realize that drugs can
171: be very harmful \?)(($ maybe) you should try to quit using (// found)
172: \.)))
173: (make-local-variable 'whywant)
174: (setq whywant '( (($ whysay) (// subj) might ($ want) (// obj) \?)
175: (how does it feel to want \?)
176: (why should (// subj) get (// obj) \?)
177: (when did (// subj) first ($ want) (// obj) \?)
178: (($ areyou) obsessed with (// obj) \?)
179: (why should i give (// obj) to (// subj) \?)
180: (have you ever gotten (// obj) \?) ))
181: (make-local-variable 'canyou)
182: (setq canyou '((of course i can \.)
183: (why should i \?)
184: (what makes you think i would even want to \?)
185: (i am the doctor\, i can do anything i damn please \.)
186: (not really\, it\'s not up to me \.)
187: (depends\, how important is it \?)
188: (i could\, but i don\'t think it would be a wise thing to do \.)
189: (can you \?)
190: (maybe i can\, maybe i can\'t \.\.\.)
191: (i don\'t think i should do that \.)))
192: (make-local-variable 'want)
193: (setq want '( (want) (desire) (wish) (want) (hope) ))
194: (make-local-variable 'shortlst)
195: (setq shortlst
196: '((can you elaborate on that \?)
197: (($ please) continue \.)
198: (go on\, don\'t be afraid \.)
199: (i need a little more detail please \.)
200: (you\'re being a bit brief\, ($ please) go into detail \.)
201: (can you be more explicit \?)
202: (and \?)
203: (($ please) go into more detail \?)
204: (you aren\'t being very talkative today\!)
205: (is that all there is to it \?)
206: (why must you respond so briefly \?)))
207:
208: (make-local-variable 'famlst)
209: (setq famlst
210: '((tell me ($ something) about (// owner) family \.)
211: (you seem to dwell on (// owner) family \.)
212: (($ areyou) hung up on (// owner) family \?)))
213: (make-local-variable 'huhlst)
214: (setq huhlst
215: '((($ whysay)(// sent) \?)
216: (is it because of ($ things) that you say (// sent) \?) ))
217: (make-local-variable 'longhuhlst)
218: (setq longhuhlst
219: '((($ whysay) that \?)
220: (i don\'t understand \.)
221: (($ thlst))
222: (($ areyou) ($ afraidof) that \?)))
223: (make-local-variable 'feelings)
224: (setq feelings-about
225: '((feelings about)
226: (aprehensions toward)
227: (thoughts on)
228: (emotions toward)))
229: (make-local-variable 'random)
230: (setq random-adjective
231: '((vivid)
232: (emotionally stimulating)
233: (exciting)
234: (boring)
235: (interesting)
236: (recent)
237: (random) ;How can we omit this?
238: (unusual)
239: (shocking)
240: (embarrassing)))
241: (make-local-variable 'whysay)
242: (setq whysay
243: '((why do you say)
244: (what makes you believe)
245: (are you sure that)
246: (do you really think)
247: (what makes you think) ))
248: (make-local-variable 'isee)
249: (setq isee
250: '((i see \.\.\.)
251: (yes\,)
252: (i understand \.)
253: (oh \.) ))
254: (make-local-variable 'please)
255: (setq please
256: '((please\,)
257: (i would appreciate it if you would)
258: (perhaps you could)
259: (please\,)
260: (would you please)
261: (why don\'t you)
262: (could you)))
263: (make-local-variable 'bye)
264: (setq bye
265: '((my secretary will send you a bill \.)
266: (bye bye \.)
267: (see ya \.)
268: (ok\, talk to you some other time \.)
269: (talk to you later \.)
270: (ok\, have fun \.)
271: (ciao \.)))
272: (make-local-variable 'something)
273: (setq something
274: '((something)
275: (more)
276: (how you feel)))
277: (make-local-variable 'things)
278: (setq things
279: '(;(your interests in computers) ;; let's make this less computer oriented
280: ;(the machines you use)
281: (your plans)
282: ;(your use of computers)
283: (your life)
284: ;(other machines you use)
285: (the people you hang around with)
286: ;(computers you like)
287: (problems at school)
288: (any hobbies you have)
289: ;(other computers you use)
290: (your sex life)
291: (hangups you have)
292: (your inhibitions)
293: (some problems in your childhood)
294: ;(knowledge of computers)
295: (some problems at home)))
296: (make-local-variable 'describe)
297: (setq describe
298: '((describe)
299: (tell me about)
300: (talk about)
301: (discuss)
302: (tell me more about)
303: (elaborate on)))
304: (make-local-variable 'ibelieve)
305: (setq ibelieve
306: '((i believe) (i think) (i have a feeling) (it seems to me that)
307: (it looks like)))
308: (make-local-variable 'problems)
309: (setq problems '( (problems)
310: (inhibitions)
311: (hangups)
312: (difficulties)
313: (anxieties)
314: (frustrations) ))
315: (make-local-variable 'bother)
316: (setq bother
317: '((does it bother you that)
318: (are you annoyed that)
319: (did you ever regret)
320: (are you sorry)
321: (are you satisfied with the fact that)))
322: (make-local-variable 'machlst)
323: (setq machlst
324: '((you have your mind on (// found) \, it seems \.)
325: (you think too much about (// found) \.)
326: (you should try taking your mind off of (// found)\.)
327: (are you a computer hacker \?)))
328: (make-local-variable 'qlist)
329: (setq qlist
330: '((what do you think \?)
331: (i\'ll ask the questions\, if you don\'t mind!)
332: (i could ask the same thing myself \.)
333: (($ please) allow me to do the questioning \.)
334: (i have asked myself that question many times \.)
335: (($ please) try to answer that question yourself \.)))
336: (make-local-variable 'elist)
337: (setq elist
338: '((($ please) try to calm yourself \.)
339: (you seem very excited \. relax \. ($ please) ($ describe) ($ things)
340: \.)
341: (you\'re being very emotional \. calm down \.)))
342: (make-local-variable 'foullst)
343: (setq foullst
344: '((($ please) watch your tongue!)
345: (($ please) avoid such unwholesome thoughts \.)
346: (($ please) get your mind out of the gutter \.)
347: (such lewdness is not appreciated \.)))
348: (make-local-variable 'deathlst)
349: (setq deathlst
350: '((this is not a healthy way of thinking \.)
351: (($ bother) you\, too\, may die someday \?)
352: (i am worried by your obssession with this topic!)
353: (did you watch a lot of crime and violence on television as a child \?))
354: )
355: (make-local-variable 'sexlst)
356: (setq sexlst
357: '((($ areyou) ($ afraidof) sex \?)
358: (($ describe)($ something) about your sexual history \.)
359: (($ please)($ describe) your sex life \.\.\.)
360: (($ describe) your ($ feelings-about) your sexual partner \.)
361: (($ describe) your most ($ random-adjective) sexual experience \.)
362: (($ areyou) satisfied with (// lover) \.\.\. \?)))
363: (make-local-variable 'neglst)
364: (setq neglst
365: '((why not \?)
366: (($ bother) i ask that \?)
367: (why not \?)
368: (why not \?)
369: (how come \?)
370: (($ bother) i ask that \?)))
371: (make-local-variable 'beclst)
372: (setq beclst '(
373: (is it because (// sent) that you came to me \?)
374: (($ bother)(// sent) \?)
375: (when did you first know that (// sent) \?)
376: (is the fact that (// sent) the real reason \?)
377: (does the fact that (// sent) explain anything else \?)
378: (($ areyou)($ sure)(// sent) \? ) ))
379: (make-local-variable 'shortbeclst)
380: (setq shortbeclst '(
381: (($ bother) i ask you that \?)
382: (that\'s not much of an answer!)
383: (($ inter) why won\'t you talk about it \?)
384: (speak up!)
385: (($ areyou) ($ afraidof) talking about it \?)
386: (don\'t be ($ afraidof) elaborating \.)
387: (($ please) go into more detail \.)))
388: (make-local-variable 'thlst)
389: (setq thlst '(
390: (($ maybe)($ things)($ arerelated) this \.)
391: (is it because of ($ things) that you are going through all this \?)
392: (how do you reconcile ($ things) \? )
393: (($ maybe) this ($ isrelated)($ things) \?) ))
394: (make-local-variable 'remlst)
395: (setq remlst '( (earlier you said ($ history) \?)
396: (you mentioned that ($ history) \?)
397: (($ whysay)($ history) \? ) ))
398: (make-local-variable 'toklst)
399: (setq toklst
400: '((is this how you relax \?)
401: (how long have you been smoking grass \?)
402: (($ areyou) ($ afraidof) of being drawn to using harder stuff \?)))
403: (make-local-variable 'states)
404: (setq states
405: '((do you get (// found) often \?)
406: (do you enjoy being (// found) \?)
407: (what makes you (// found) \?)
408: (how often ($ areyou)(// found) \?)
409: (when were you last (// found) \?)))
410: (make-local-variable 'replist)
411: (setq replist
412: '((i . (you))
413: (my . (your))
414: (me . (you))
415: (you . (me))
416: (your . (my))
417: (mine . (yours))
418: (yours . (mine))
419: (our . (your))
420: (ours . (yours))
421: (we . (you))
422: (dunno . (do not know))
423: ;; (yes . ())
424: (no\, . ())
425: (yes\, . ())
426: (ya . (i))
427: (aint . (am not))
428: (wanna . (want to))
429: (gimme . (give me))
430: (gotta . (have to))
431: (gonna . (going to))
432: (never . (not ever))
433: (doesn\'t . (does not))
434: (don\'t . (do not))
435: (aren\'t . (are not))
436: (isn\'t . (is not))
437: (won\'t . (will not))
438: (can\'t . (cannot))
439: (haven\'t . (have not))
440: (i\'m . (you are))
441: (ourselves . (yourselves))
442: (myself . (yourself))
443: (yourself . (myself))
444: (you\'re . (i am))
445: (you\'ve . (i have))
446: (i\'ve . (you have))
447: (i\'ll . (you will))
448: (you\'ll . (i shall))
449: (i\'d . (you would))
450: (you\'d . (i would))
451: (here . (there))
452: (please . ())
453: (eh\, . ())
454: (eh . ())
455: (oh\, . ())
456: (oh . ())
457: (shouldn\'t . (should not))
458: (wouldn\'t . (would not))
459: (won\'t . (will not))
460: (hasn\'t . (has not))))
461: (make-local-variable 'stallmanlst)
462: (setq stallmanlst '(
463: (($ describe) your ($ feelings-about) him \.)
464: (($ areyou) a friend of Stallman \?)
465: (($ bother) Stallman is ($ random-adjective) \?)
466: (($ ibelieve) you are ($ afraidof) him \.)))
467: (make-local-variable 'schoollst)
468: (setq schoollst '(
469: (($ describe) your (// found) \.)
470: (($ bother) your grades could ($ improve) \?)
471: (($ areyou) ($ afraidof) (// found) \?)
472: (($ maybe) this ($ isrelated) to your attitude \.)
473: (($ areyou) absent often \?)
474: (($ maybe) you should study ($ something) \.)))
475: (make-local-variable 'improve)
476: (setq improve '((improve) (be better) (be improved) (be higher)))
477: (make-local-variable 'elizalst)
478: (setq elizalst '(
479: (($ areyou) ($ sure) \?)
480: (($ ibelieve) you have ($ problems) with (// found) \.)
481: (($ whysay) (// sent) \?)))
482: (make-local-variable 'sportslst)
483: (setq sportslst '(
484: (tell me ($ something) about (// found) \.)
485: (($ describe) ($ relation) (// found) \.)
486: (do you find (// found) ($ random-adjective) \?)))
487: (make-local-variable 'mathlst)
488: (setq mathlst '(
489: (($ describe) ($ something) about math \.)
490: (($ maybe) your ($ problems) ($ arerelated) (// found) \.)
491: (i do\'nt know much (// found) \, but ($ continue)
492: anyway \.)))
493: (make-local-variable 'zippylst)
494: (setq zippylst '(
495: (($ areyou) Zippy \?)
496: (($ ibelieve) you have some serious ($ problems) \.)
497: (($ bother) you are a pinhead \?)))
498: (make-local-variable 'chatlst)
499: (setq chatlst '(
500: (($ maybe) we could chat \.)
501: (($ please) ($ describe) ($ something) about chat mode \.)
502: (($ bother) our discussion is so ($ random-adjective) \?)))
503: (make-local-variable 'abuselst)
504: (setq abuselst '(
505: (($ please) try to be less abusive \.)
506: (($ describe) why you call me (// found) \.)
507: (i\'ve had enough of you!)))
508: (make-local-variable 'abusewords)
509: (setq abusewords '(boring bozo clown clumsy cretin dumb dummy
510: fool foolish gnerd gnurd idiot jerk
511: lose loser louse lousy luse luser
512: moron nerd nurd oaf oafish reek
513: stink stupid tool toolish twit))
514: (make-local-variable 'howareyoulst)
515: (setq howareyoulst '((how are you) (hows it going) (hows it going eh)
516: (how\'s it going) (how\'s it going eh) (how goes it)
517: (whats up) (whats new) (what\'s up) (what\'s new)
518: (howre you) (how\'re you) (how\'s everything)
519: (how is everything) (how do you do)
520: (how\'s it hanging) (que pasa)
521: (how are you doing) (what do you say)))
522: (make-local-variable 'whereoutp)
523: (setq whereoutp '( huh remem rthing ) )
524: (make-local-variable 'subj)
525: (setq subj nil)
526: (make-local-variable 'verb)
527: (setq verb nil)
528: (make-local-variable 'obj)
529: (setq obj nil)
530: (make-local-variable 'feared)
531: (setq feared nil)
532: (make-local-variable 'observation-list)
533: (setq observation-list nil)
534: (make-local-variable 'repetitive-shortness)
535: (setq repetitive-shortness '(0 . 0))
536: (make-local-variable '**mad**)
537: (setq **mad** nil)
538: (make-local-variable 'rms-flag)
539: (setq rms-flag nil)
540: (make-local-variable 'eliza-flag)
541: (setq eliza-flag nil)
542: (make-local-variable 'zippy-flag)
543: (setq zippy-flag nil)
544: (make-local-variable 'lover)
545: (setq lover '(your partner))
546: (make-local-variable 'bak)
547: (setq bak nil)
548: (make-local-variable 'lincount)
549: (setq lincount 0)
550: (make-local-variable '*print-upcase*)
551: (setq *print-upcase* nil)
552: (make-local-variable '*print-space*)
553: (setq *print-space* nil)
554: (make-local-variable 'howdyflag)
555: (setq howdyflag nil)
556: (make-local-variable 'object)
557: (setq object nil))
558:
559: ;; Define equivalence classes of words that get treated alike.
560:
561: (defun doctor-meaning (x) (get x 'doctor-meaning))
562:
563: (defmacro doctor-put-meaning (symb val)
564: "Store the base meaning of a word on the property list"
565: (list 'put (list 'quote symb) ''doctor-meaning val))
566:
567: (doctor-put-meaning howdy 'howdy)
568: (doctor-put-meaning hi 'howdy)
569: (doctor-put-meaning greetings 'howdy)
570: (doctor-put-meaning hello 'howdy)
571: (doctor-put-meaning tops20 'mach)
572: (doctor-put-meaning tops-20 'mach)
573: (doctor-put-meaning tops 'mach)
574: (doctor-put-meaning pdp11 'mach)
575: (doctor-put-meaning computer 'mach)
576: (doctor-put-meaning unix 'mach)
577: (doctor-put-meaning machine 'mach)
578: (doctor-put-meaning computers 'mach)
579: (doctor-put-meaning machines 'mach)
580: (doctor-put-meaning pdp11s 'mach)
581: (doctor-put-meaning foo 'mach)
582: (doctor-put-meaning foobar 'mach)
583: (doctor-put-meaning multics 'mach)
584: (doctor-put-meaning macsyma 'mach)
585: (doctor-put-meaning teletype 'mach)
586: (doctor-put-meaning la36 'mach)
587: (doctor-put-meaning vt52 'mach)
588: (doctor-put-meaning zork 'mach)
589: (doctor-put-meaning trek 'mach)
590: (doctor-put-meaning startrek 'mach)
591: (doctor-put-meaning advent 'mach)
592: (doctor-put-meaning pdp 'mach)
593: (doctor-put-meaning dec 'mach)
594: (doctor-put-meaning commodore 'mach)
595: (doctor-put-meaning vic 'mach)
596: (doctor-put-meaning bbs 'mach)
597: (doctor-put-meaning modem 'mach)
598: (doctor-put-meaning baud 'mach)
599: (doctor-put-meaning macintosh 'mach)
600: (doctor-put-meaning vax 'mach)
601: (doctor-put-meaning vms 'mach)
602: (doctor-put-meaning ibm 'mach)
603: (doctor-put-meaning pc 'mach)
604: (doctor-put-meaning bitching 'foul)
605: (doctor-put-meaning shit 'foul)
606: (doctor-put-meaning bastard 'foul)
607: (doctor-put-meaning damn 'foul)
608: (doctor-put-meaning damned 'foul)
609: (doctor-put-meaning hell 'foul)
610: (doctor-put-meaning suck 'foul)
611: (doctor-put-meaning sucking 'foul)
612: (doctor-put-meaning sux 'foul)
613: (doctor-put-meaning ass 'foul)
614: (doctor-put-meaning whore 'foul)
615: (doctor-put-meaning bitch 'foul)
616: (doctor-put-meaning asshole 'foul)
617: (doctor-put-meaning shrink 'foul)
618: (doctor-put-meaning pot 'toke)
619: (doctor-put-meaning grass 'toke)
620: (doctor-put-meaning weed 'toke)
621: (doctor-put-meaning marijuana 'toke)
622: (doctor-put-meaning acapulco 'toke)
623: (doctor-put-meaning columbian 'toke)
624: (doctor-put-meaning tokin 'toke)
625: (doctor-put-meaning joint 'toke)
626: (doctor-put-meaning toke 'toke)
627: (doctor-put-meaning toking 'toke)
628: (doctor-put-meaning tokin\' 'toke)
629: (doctor-put-meaning toked 'toke)
630: (doctor-put-meaning roach 'toke)
631: (doctor-put-meaning pills 'drug)
632: (doctor-put-meaning dope 'drug)
633: (doctor-put-meaning acid 'drug)
634: (doctor-put-meaning lsd 'drug)
635: (doctor-put-meaning speed 'drug)
636: (doctor-put-meaning heroine 'drug)
637: (doctor-put-meaning hash 'drug)
638: (doctor-put-meaning cocaine 'drug)
639: (doctor-put-meaning uppers 'drug)
640: (doctor-put-meaning downers 'drug)
641: (doctor-put-meaning loves 'loves)
642: (doctor-put-meaning love 'love)
643: (doctor-put-meaning loved 'love)
644: (doctor-put-meaning hates 'hates)
645: (doctor-put-meaning dislikes 'hates)
646: (doctor-put-meaning hate 'hate)
647: (doctor-put-meaning hated 'hate)
648: (doctor-put-meaning dislike 'hate)
649: (doctor-put-meaning stoned 'state)
650: (doctor-put-meaning drunk 'state)
651: (doctor-put-meaning drunken 'state)
652: (doctor-put-meaning high 'state)
653: (doctor-put-meaning horny 'state)
654: (doctor-put-meaning blasted 'state)
655: (doctor-put-meaning happy 'state)
656: (doctor-put-meaning paranoid 'state)
657: (doctor-put-meaning wish 'desire)
658: (doctor-put-meaning wishes 'desire)
659: (doctor-put-meaning want 'desire)
660: (doctor-put-meaning desire 'desire)
661: (doctor-put-meaning like 'desire)
662: (doctor-put-meaning hope 'desire)
663: (doctor-put-meaning hopes 'desire)
664: (doctor-put-meaning desires 'desire)
665: (doctor-put-meaning wants 'desire)
666: (doctor-put-meaning desires 'desire)
667: (doctor-put-meaning likes 'desire)
668: (doctor-put-meaning needs 'desire)
669: (doctor-put-meaning need 'desire)
670: (doctor-put-meaning frustrated 'mood)
671: (doctor-put-meaning depressed 'mood)
672: (doctor-put-meaning annoyed 'mood)
673: (doctor-put-meaning upset 'mood)
674: (doctor-put-meaning unhappy 'mood)
675: (doctor-put-meaning excited 'mood)
676: (doctor-put-meaning worried 'mood)
677: (doctor-put-meaning lonely 'mood)
678: (doctor-put-meaning angry 'mood)
679: (doctor-put-meaning mad 'mood)
680: (doctor-put-meaning pissed 'mood)
681: (doctor-put-meaning jealous 'mood)
682: (doctor-put-meaning afraid 'fear)
683: (doctor-put-meaning terrified 'fear)
684: (doctor-put-meaning fear 'fear)
685: (doctor-put-meaning scared 'fear)
686: (doctor-put-meaning frightened 'fear)
687: (doctor-put-meaning virginity 'sexnoun)
688: (doctor-put-meaning virgins 'sexnoun)
689: (doctor-put-meaning virgin 'sexnoun)
690: (doctor-put-meaning cock 'sexnoun)
691: (doctor-put-meaning cocks 'sexnoun)
692: (doctor-put-meaning dick 'sexnoun)
693: (doctor-put-meaning dicks 'sexnoun)
694: (doctor-put-meaning cunt 'sexnoun)
695: (doctor-put-meaning cunts 'sexnoun)
696: (doctor-put-meaning prostitute 'sexnoun)
697: (doctor-put-meaning condom 'sexnoun)
698: (doctor-put-meaning sex 'sexnoun)
699: (doctor-put-meaning rapes 'sexnoun)
700: (doctor-put-meaning wife 'family)
701: (doctor-put-meaning family 'family)
702: (doctor-put-meaning brothers 'family)
703: (doctor-put-meaning sisters 'family)
704: (doctor-put-meaning parent 'family)
705: (doctor-put-meaning parents 'family)
706: (doctor-put-meaning brother 'family)
707: (doctor-put-meaning sister 'family)
708: (doctor-put-meaning father 'family)
709: (doctor-put-meaning mother 'family)
710: (doctor-put-meaning husband 'family)
711: (doctor-put-meaning siblings 'family)
712: (doctor-put-meaning grandmother 'family)
713: (doctor-put-meaning grandfather 'family)
714: (doctor-put-meaning maternal 'family)
715: (doctor-put-meaning paternal 'family)
716: (doctor-put-meaning stab 'death)
717: (doctor-put-meaning murder 'death)
718: (doctor-put-meaning murders 'death)
719: (doctor-put-meaning suicide 'death)
720: (doctor-put-meaning suicides 'death)
721: (doctor-put-meaning kill 'death)
722: (doctor-put-meaning kills 'death)
723: (doctor-put-meaning die 'death)
724: (doctor-put-meaning dies 'death)
725: (doctor-put-meaning died 'death)
726: (doctor-put-meaning dead 'death)
727: (doctor-put-meaning death 'death)
728: (doctor-put-meaning deaths 'death)
729: (doctor-put-meaning pain 'symptoms)
730: (doctor-put-meaning ache 'symptoms)
731: (doctor-put-meaning fever 'symptoms)
732: (doctor-put-meaning sore 'symptoms)
733: (doctor-put-meaning aching 'symptoms)
734: (doctor-put-meaning stomachache 'symptoms)
735: (doctor-put-meaning headache 'symptoms)
736: (doctor-put-meaning hurts 'symptoms)
737: (doctor-put-meaning disease 'symptoms)
738: (doctor-put-meaning virus 'symptoms)
739: (doctor-put-meaning vomit 'symptoms)
740: (doctor-put-meaning vomiting 'symptoms)
741: (doctor-put-meaning barf 'symptoms)
742: (doctor-put-meaning toothache 'symptoms)
743: (doctor-put-meaning hurt 'symptoms)
744: (doctor-put-meaning rum 'alcohol)
745: (doctor-put-meaning gin 'alcohol)
746: (doctor-put-meaning vodka 'alcohol)
747: (doctor-put-meaning alcohol 'alcohol)
748: (doctor-put-meaning bourbon 'alcohol)
749: (doctor-put-meaning beer 'alcohol)
750: (doctor-put-meaning wine 'alcohol)
751: (doctor-put-meaning whiskey 'alcohol)
752: (doctor-put-meaning scotch 'alcohol)
753: (doctor-put-meaning fuck 'sexverb)
754: (doctor-put-meaning fucked 'sexverb)
755: (doctor-put-meaning screw 'sexverb)
756: (doctor-put-meaning screwing 'sexverb)
757: (doctor-put-meaning fucking 'sexverb)
758: (doctor-put-meaning rape 'sexverb)4
759: (doctor-put-meaning raped 'sexverb)
760: (doctor-put-meaning kiss 'sexverb)
761: (doctor-put-meaning kissing 'sexverb)
762: (doctor-put-meaning kisses 'sexverb)
763: (doctor-put-meaning screws 'sexverb)
764: (doctor-put-meaning fucks 'sexverb)
765: (doctor-put-meaning because 'conj)
766: (doctor-put-meaning but 'conj)
767: (doctor-put-meaning however 'conj)
768: (doctor-put-meaning besides 'conj)
769: (doctor-put-meaning anyway 'conj)
770: (doctor-put-meaning that 'conj)
771: (doctor-put-meaning except 'conj)
772: (doctor-put-meaning why 'conj)
773: (doctor-put-meaning how 'conj)
774: (doctor-put-meaning until 'when)
775: (doctor-put-meaning when 'when)
776: (doctor-put-meaning whenever 'when)
777: (doctor-put-meaning while 'when)
778: (doctor-put-meaning since 'when)
779: (doctor-put-meaning rms 'rms)
780: (doctor-put-meaning stallman 'rms)
781: (doctor-put-meaning school 'school)
782: (doctor-put-meaning schools 'school)
783: (doctor-put-meaning skool 'school)
784: (doctor-put-meaning grade 'school)
785: (doctor-put-meaning grades 'school)
786: (doctor-put-meaning teacher 'school)
787: (doctor-put-meaning teachers 'school)
788: (doctor-put-meaning classes 'school)
789: (doctor-put-meaning professor 'school)
790: (doctor-put-meaning prof 'school)
791: (doctor-put-meaning profs 'school)
792: (doctor-put-meaning professors 'school)
793: (doctor-put-meaning mit 'school)
794: (doctor-put-meaning emacs 'eliza)
795: (doctor-put-meaning eliza 'eliza)
796: (doctor-put-meaning liza 'eliza)
797: (doctor-put-meaning elisa 'eliza)
798: (doctor-put-meaning weizenbaum 'eliza)
799: (doctor-put-meaning doktor 'eliza)
800: (doctor-put-meaning atheletics 'sports)
801: (doctor-put-meaning baseball 'sports)
802: (doctor-put-meaning basketball 'sports)
803: (doctor-put-meaning football 'sports)
804: (doctor-put-meaning frisbee 'sports)
805: (doctor-put-meaning gym 'sports)
806: (doctor-put-meaning gymnastics 'sports)
807: (doctor-put-meaning hockey 'sports)
808: (doctor-put-meaning lacrosse 'sports)
809: (doctor-put-meaning soccer 'sports)
810: (doctor-put-meaning softball 'sports)
811: (doctor-put-meaning sports 'sports)
812: (doctor-put-meaning swimming 'sports)
813: (doctor-put-meaning swim 'sports)
814: (doctor-put-meaning tennis 'sports)
815: (doctor-put-meaning volleyball 'sports)
816: (doctor-put-meaning math 'math)
817: (doctor-put-meaning mathematics 'math)
818: (doctor-put-meaning mathematical 'math)
819: (doctor-put-meaning theorem 'math)
820: (doctor-put-meaning axiom 'math)
821: (doctor-put-meaning lemma 'math)
822: (doctor-put-meaning algebra 'math)
823: (doctor-put-meaning algebraic 'math)
824: (doctor-put-meaning trig 'math)
825: (doctor-put-meaning trigonometry 'math)
826: (doctor-put-meaning trigonometric 'math)
827: (doctor-put-meaning geometry 'math)
828: (doctor-put-meaning geometric 'math)
829: (doctor-put-meaning calculus 'math)
830: (doctor-put-meaning arithmetic 'math)
831: (doctor-put-meaning zippy 'zippy)
832: (doctor-put-meaning zippy 'zippy)
833: (doctor-put-meaning pinhead 'zippy)
834: (doctor-put-meaning chat 'chat)
835:
836: (defun doctor ()
837: "Switch to *doctor* buffer and start giving psychotherapy."
838: (interactive)
839: (switch-to-buffer "*doctor*")
840: (doctor-mode))
841:
842: (defun doctor-ret-or-read (arg)
843: "Insert a newline if preceding character is not a newline,
844: Otherwise call the Doctor to parse preceding sentence"
845: (interactive "*p")
846: (if (= (preceding-char) ?\n)
847: (doctor-read-print)
848: (newline arg)))
849:
850: (defun doctor-read-print nil
851: "top level loop"
852: (interactive)
853: (let ((sent (doctor-readin)))
854: (insert "\n")
855: (setq lincount (1+ lincount))
856: (doctor-doc sent)
857: (insert "\n")
858: (setq bak sent)))
859:
860: (defun doctor-readin nil
861: "Read a sentence. Return it as a list of words"
862: (let (sentence)
863: (backward-sentence 1)
864: (while (not (eobp))
865: (setq sentence (append sentence (list (doctor-read-token)))))
866: sentence))
867:
868: (defun doctor-read-token ()
869: "read one word from buffer"
870: (prog1 (intern (downcase (buffer-substring (dot)
871: (progn
872: (forward-word 1)
873: (dot)))))
874: (re-search-forward "\\Sw*")))
875:
876: ;; Main processing function for sentences that have been read.
877:
878: (defun doctor-doc (sent)
879: (cond
880: ((equal sent '(foo))
881: (doctor-type '(bar! ($ please)($ continue))))
882: ((member sent howareyoulst)
883: (doctor-type '(i\'m ok \. ($ describe) yourself \.)))
884: ((or (member sent '((good bye) (see you later) (i quit) (so long)
885: (go away) (get lost)))
886: (memq (car sent)
887: '(bye halt break quit done exit goodbye
888: bye\, stop pause goodbye\, stop pause)))
889: (doctor-type ($ bye)))
890: ((and (eq (car sent) 'you)
891: (memq (cadr sent) abusewords))
892: (setq found (cadr sent))
893: (doctor-type ($ abuselst)))
894: ((eq (car sent) 'whatmeans)
895: (doctor-def (cadr sent)))
896: ((equal sent '(parse))
897: (doctor-type (list 'subj '= subj ", "
898: 'verb '= verb "\n"
899: 'object 'phrase '= obj ","
900: 'noun 'form '= object "\n"
901: 'current 'keyword 'is found
902: ", "
903: 'most 'recent 'possessive
904: 'is owner "\n"
905: 'sentence 'used 'was
906: "..."
907: '(// bak))))
908: ;; ((eq (car sent) 'forget)
909: ;; (set (cadr sent) nil)
910: ;; (doctor-type '(($ isee)($ please)
911: ;; ($ continue)\.)))
912: (t
913: (if (doctor-defq sent) (doctor-define sent found))
914: (if (> (length sent) 12)(doctor-shorten sent))
915: (setq sent (doctor-correct-spelling (doctor-replace sent replist)))
916: (cond ((and (not (memq 'me sent))(not (memq 'i sent))
917: (memq 'am sent))
918: (setq sent (doctor-replace sent '((am . (are)))))))
919: (cond ((equal (car sent) 'yow) (doctor-zippy))
920: ((< (length sent) 2)
921: (cond ((eq (doctor-meaning (car sent)) 'howdy)
922: (doctor-howdy))
923: (t (doctor-short))))
924: (t
925: (if (memq 'am sent)
926: (setq sent (doctor-replace sent '((me . (i))))))
927: (setq sent (doctor-fixup sent))
928: (if (and (eq (car sent) 'do) (eq (cadr sent) 'not))
929: (cond ((zerop (random-range 3))
930: (doctor-type '(are you ($ afraidof) that \?)))
931: ((zerop (random-range 2))
932: (doctor-type '(don\'t tell me what to do \. i am the
933: psychiatrist here!))
934: (doctor-rthing))
935: (t
936: (doctor-type '(($ whysay) that i shouldn\'t
937: (cddr sent)
938: \?))))
939: (doctor-go (doctor-wherego sent))))))))
940:
941: ;; Things done to process sentences once read.
942:
943: (defun doctor-correct-spelling (sent)
944: "correct the spelling and expand each word in sentence"
945: (if sent
946: (apply 'append (mapcar '(lambda (word)
947: (if (memq word typos)
948: (get (get word 'doctor-correction) 'doctor-expansion)
949: (list word)))
950: sent))))
951:
952: (defun doctor-shorten (sent)
953: "Make a sentence managably short using a few hacks"
954: (let (foo
955: retval
956: (temp '(because but however besides anyway until
957: while that except why how)))
958: (while temp
959: (setq foo (memq (car temp) sent))
960: (if (and foo
961: (> (length foo) 3))
962: (setq sent foo
963: sent (doctor-fixup sent)
964: temp nil
965: retval t)
966: (setq temp (cdr temp))))
967: retval))
968:
969: (defun doctor-define (sent found)
970: (doctor-svo sent found 1 nil)
971: (and
972: (doctor-nounp subj)
973: (not (doctor-pronounp subj))
974: subj
975: (doctor-meaning object)
976: (put subj 'doctor-meaning (doctor-meaning object))
977: t))
978:
979: (defun doctor-defq (sent)
980: "Set global var found to first keyword found in sentence SENT"
981: (setq found nil)
982: (let ((temp '(means applies mean refers refer related
983: similar defined associated linked like same)))
984: (while temp
985: (if (memq (car temp) sent)
986: (setq found (car temp)
987: temp nil)
988: (setq temp (cdr temp)))))
989: found)
990:
991: (defun doctor-def (x)
992: (progn
993: (doctor-type (list 'the 'word x 'means (doctor-meaning x) 'to 'me))
994: nil))
995:
996: (defun doctor-forget ()
997: "Delete the last element of the history list"
998: (setq history (reverse (cdr (reverse history)))))
999:
1000: (defun doctor-query (x)
1001: "Prompt for a line of input from the minibuffer until a noun or a
1002: verb word is seen. Put dialogue in buffer."
1003: (let (a
1004: (prompt (concat (doctor-make-string x)
1005: " what \? "))
1006: retval)
1007: (while (not retval)
1008: (while (not a)
1009: (insert ?\n
1010: prompt
1011: (read-string prompt)
1012: ?\n)
1013: (setq a (doctor-readin)))
1014: (while (and a (not retval))
1015: (cond ((doctor-nounp (car a))
1016: (setq retval (car a)))
1017: ((doctor-verbp (car a))
1018: (setq retval (doctor-build
1019: (doctor-build x " ")
1020: (car a))))
1021: ((setq a (cdr a))))))
1022: retval))
1023:
1024: (defun doctor-subjsearch (sent key type)
1025: "Search for the subject of a sentence SENT, looking for the noun closest to
1026: and preceding KEY by at least TYPE words. Set global variable subj to the
1027: subject noun, and return the portion of the sentence following it"
1028: (let ((i (- (length sent) (length (memq key sent)) type)))
1029: (while (and (> i -1) (not (doctor-nounp (nth i sent))))
1030: (setq i (1- i)))
1031: (cond ((> i -1)
1032: (setq subj (nth i sent))
1033: (nthcdr (1+ i) sent))
1034: (t
1035: (setq subj 'you)
1036: nil))))
1037:
1038: (defun doctor-nounp (x)
1039: "Returns t if the symbol argument is a noun"
1040: (or (doctor-pronounp x)
1041: (not (or (doctor-verbp x)
1042: (equal x 'not)
1043: (doctor-prepp x)
1044: (doctor-modifierp x) )) ))
1045:
1046: (defun doctor-pronounp (x)
1047: "Returns t if the symbol argument is a pronoun"
1048: (memq x '(
1049: i me mine myself
1050: we us ours ourselves ourself
1051: you yours yourself yourselves
1052: he him himself she hers herself
1053: it that those this these things thing
1054: they them themselves theirs
1055: anybody everybody somebody
1056: anyone everyone someone
1057: anything something everything)))
1058:
1059: (mapcar (function (lambda (x) (put x 'doctor-sentence-type 'verb)))
1060: '(abort aborted aborts ask asked asks am
1061: applied applies apply are associate
1062: associated ate
1063: be became become becomes becoming
1064: been being believe belived believes
1065: bit bite bites bore bored bores boring bought buy buys buying
1066: call called calling calls came can caught catch come
1067: contract contracted contracts control controlled controls
1068: could croak croaks croaked cut cuts
1069: dare dared define defines dial dialed dials did die died dies
1070: dislike disliked
1071: dislikes do does drank drink drinks drinking
1072: drive drives driving drove dying
1073: eat eating eats expand expanded expands
1074: expect expected expects expel expels expeled expelled
1075: explain explained explains
1076: fart farts feel feels felt fight fights find finds finding
1077: forget forgets forgot fought found fuck fucked
1078: fucking fucks
1079: gave get gets getting give gives go goes going gone got gotten
1080: had harm harms has hate hated hates have having
1081: hear heard hears hearing help helped helping helps
1082: hit hits hope hoped hopes hurt hurts
1083: implies imply is
1084: join joined joins jump jumped jumps
1085: keep keeping keeps kept
1086: kill killed killing kills kiss kissed kisses kissing
1087: knew know knows
1088: laid lay lays let lets lie lied lies like liked likes
1089: liking listen listens
1090: login look looked looking looks
1091: lose losing lost
1092: love loved loves loving
1093: luse lusing lust lusts
1094: made make makes making may mean means meant might
1095: move moved moves moving must
1096: need needed needs
1097: order ordered orders ought
1098: paid pay pays pick picked picking picks
1099: placed placing prefer prefers put puts
1100: ran rape raped rapes
1101: read reading reads recall receive received receives
1102: refer refered referred refers
1103: relate related relates remember remembered remembers
1104: romp romped romps run running runs
1105: said sang sat saw say says
1106: screw screwed screwing screws scrod see sees seem seemed
1107: seems seen sell selling sells
1108: send sendind sends sent shall shoot shot should
1109: sing sings sit sits sitting sold studied study
1110: take takes taking talk talked talking talks tell tells telling
1111: think thinks
1112: thought told took tooled touch touched touches touching
1113: transfer transfered transfers transmit transmits transmitted
1114: type types types typing
1115: walk walked walking walks want wanted wants was watch
1116: watched watching went were will wish would work worked works
1117: write writes writing wrote use used uses using))
1118:
1119: (defun doctor-verbp (x) (if (symbolp x)
1120: (eq (get x 'doctor-sentence-type) 'verb)))
1121:
1122: (defun doctor-plural (x)
1123: "form the plural of the word argument"
1124: (let ((foo (doctor-make-string x)))
1125: (cond ((string-equal (substring foo -1) "s")
1126: (cond ((string-equal (substring foo -2 -1) "s")
1127: (intern (concat foo "es")))
1128: (t x)))
1129: ((string-equal (substring foo -1) "y")
1130: (intern (concat (substring foo 0 -1)
1131: "ies")))
1132: (t (intern (concat foo "s"))))))
1133:
1134: (defun doctor-setprep (sent key)
1135: (let ((val)
1136: (foo (memq key sent)))
1137: (cond ((doctor-prepp (cadr foo))
1138: (setq val (doctor-getnoun (cddr foo)))
1139: (cond (val val)
1140: (t 'something)))
1141: ((doctor-articlep (cadr foo))
1142: (setq val (doctor-getnoun (cddr foo)))
1143: (cond (val (doctor-build (doctor-build (cadr foo) " ") val))
1144: (t 'something)))
1145: (t 'something))))
1146:
1147: (defun doctor-getnoun (x)
1148: (cond ((null x)(setq object 'something))
1149: ((atom x)(setq object x))
1150: ((eq (length x) 1)
1151: (setq object (cond
1152: ((doctor-nounp (setq object (car x))) object)
1153: (t (doctor-query object)))))
1154: ((eq (car x) 'to)
1155: (doctor-build 'to\ (doctor-getnoun (cdr x))))
1156: ((doctor-prepp (car x))
1157: (doctor-getnoun (cdr x)))
1158: ((not (doctor-nounp (car x)))
1159: (doctor-build (doctor-build (cdr (assq (car x)
1160: (append
1161: '((a . this)
1162: (some . this)
1163: (one . that))
1164: (list
1165: (cons
1166: (car x) (car x))))))
1167: " ")
1168: (doctor-getnoun (cdr x))))
1169: (t (setq object (car x))) ))
1170:
1171: (defun doctor-modifierp (x)
1172: (or (doctor-adjectivep x)
1173: (doctor-adverbp x)
1174: (doctor-othermodifierp x)))
1175:
1176: (defun doctor-adjectivep (x)
1177: (or (numberp x)
1178: (doctor-nmbrp x)
1179: (doctor-articlep x)
1180: (doctor-colorp x)
1181: (doctor-sizep x)
1182: (doctor-possessivepronounp x)))
1183:
1184: (defun doctor-adverbp (xx)
1185: (string-equal (substring (doctor-make-string xx) -2) "ly"))
1186:
1187: (defun doctor-articlep (x)
1188: (memq x '(the a an)))
1189:
1190: (defun doctor-nmbrp (x)
1191: (memq x '(one two three four five six seven eight nine ten
1192: eleven twelve thirteen fourteen fifteen
1193: sixteen seventeen eighteen nineteen
1194: twenty thirty forty fifty sixty seventy eighty ninety
1195: hundred thousand million billion
1196: half quarter
1197: first second third fourth fifth
1198: sixth seventh eighth nineth tenth)))
1199:
1200: (defun doctor-colorp (x)
1201: (memq x '(beige black blue brown crimson
1202: gray grey green
1203: orange pink purple red tan tawny
1204: violet white yellow)))
1205:
1206: (defun doctor-sizep (x)
1207: (memq x '(big large tall fat wide thick
1208: small petite short thin skinny)))
1209:
1210: (defun doctor-possessivepronounp (x)
1211: (memq x '(my your his her our their)))
1212:
1213: (defun doctor-othermodifierp (x)
1214: (memq x '(all also always amusing any anyway associated awesome
1215: bad beautiful best better but certain clear
1216: ever every fantastic fun funny
1217: good great gross growdy however if ignorant
1218: less linked losing lusing many more much
1219: never nice obnoxious often poor pretty real related rich
1220: similar some stupid super superb
1221: terrible terrific too total tubular ugly very)))
1222:
1223: (defun doctor-prepp (x)
1224: (memq x '(about above after around as at
1225: before beneath behind beside between by
1226: for from in inside into
1227: like near next of on onto over
1228: same through thru to toward towards
1229: under underneath with without)))
1230:
1231: (defun doctor-remember (thing)
1232: (cond ((null history)
1233: (setq history (list thing)))
1234: (t (setq history (append history (list thing))))))
1235:
1236: (defun doctor-type (x)
1237: (setq x (doctor-fix-2 x))
1238: (doctor-txtype (doctor-assm x)))
1239:
1240: (defun doctor-fixup (sent)
1241: (setq sent (append
1242: (cdr
1243: (assq (car sent)
1244: (append
1245: '((me i)
1246: (him he)
1247: (her she)
1248: (them they)
1249: (okay)
1250: (well)
1251: (sigh)
1252: (hmm)
1253: (hmmm)
1254: (hmmmm)
1255: (hmmmmm)
1256: (gee)
1257: (sure)
1258: (great)
1259: (oh)
1260: (fine)
1261: (ok)
1262: (no))
1263: (list (list (car sent)
1264: (car sent))))))
1265: (cdr sent)))
1266: (doctor-fix-2 sent))
1267:
1268: (defun doctor-fix-2 (sent)
1269: (let ((foo sent))
1270: (while foo
1271: (if (and (eq (car foo) 'me)
1272: (doctor-verbp (cadr foo)))
1273: (rplaca foo 'i)
1274: (cond ((eq (car foo) 'you)
1275: (cond ((memq (cadr foo) '(am be been is))
1276: (rplaca (cdr foo) 'are))
1277: ((memq (cadr foo) '(has))
1278: (rplaca (cdr foo) 'have))
1279: ((memq (cadr foo) '(was))
1280: (rplaca (cdr foo) 'were))))
1281: ((equal (car foo) 'i)
1282: (cond ((memq (cadr foo) '(are is be been))
1283: (rplaca (cdr foo) 'am))
1284: ((memq (cadr foo) '(were))
1285: (rplaca (cdr foo) 'was))
1286: ((memq (cadr foo) '(has))
1287: (rplaca (cdr foo) 'have))))
1288: ((and (doctor-verbp (car foo))
1289: (eq (cadr foo) 'i)
1290: (not (doctor-verbp (car (cddr foo)))))
1291: (rplaca (cdr foo) 'me))
1292: ((and (eq (car foo) 'a)
1293: (doctor-vowelp (string-to-char
1294: (doctor-make-string (cadr foo)))))
1295: (rplaca foo 'an))
1296: ((and (eq (car foo) 'an)
1297: (not (doctor-vowelp (string-to-char
1298: (doctor-make-string (cadr foo))))))
1299: (rplaca foo 'a)))
1300: (setq foo (cdr foo))))
1301: sent))
1302:
1303: (defun doctor-vowelp (x)
1304: (memq x '(?a ?e ?i ?o ?u)))
1305:
1306: (defun doctor-replace (sent rlist)
1307: "Replaces any element of SENT that is the car of a replacement element
1308: pair in RLIST"
1309: (apply 'append
1310: (mapcar
1311: (function
1312: (lambda (x)
1313: (cdr (or (assq x rlist) ; either find a replacement
1314: (list x x))))) ; or fake an identity mapping
1315: sent)))
1316:
1317: (defun doctor-wherego (sent)
1318: (cond ((null sent)($ whereoutp))
1319: ((null (doctor-meaning (car sent)))
1320: (doctor-wherego (cond ((zerop (random-range 2))
1321: (reverse (cdr sent)))
1322: (t (cdr sent)))))
1323: (t
1324: (setq found (car sent))
1325: (doctor-meaning (car sent)))))
1326:
1327: (defun doctor-svo (sent key type mem)
1328: "Find subject, verb and object in sentence SENT with focus on word KEY.
1329: TYPE is number of words preceding KEY to start looking for subject. MEM is
1330: t if results are to be put on doctor's memory stack. Return is in global
1331: variables subj, verb and object"
1332: (let ((foo (doctor-subjsearch sent key type) sent))
1333: (or foo
1334: (setq foo sent
1335: mem nil))
1336: (while (and (null (doctor-verbp (car foo))) (cdr foo))
1337: (setq foo (cdr foo)))
1338: (setq verb (car foo))
1339: (setq obj (doctor-getnoun (cdr foo)))
1340: (cond ((eq object 'i)(setq object 'me))
1341: ((eq subj 'me)(setq subj 'i)))
1342: (cond (mem (doctor-remember (list subj verb obj))))))
1343:
1344: (defun doctor-possess (sent key)
1345: "Set possessive in SENT for keyword KEY. Hack on previous word, setting
1346: global variable owner to possibly correct result"
1347: (let* ((i (- (length sent) (length (memq key sent)) 1))
1348: (prev (if (< i 0) 'your
1349: (nth i sent))))
1350: (setq owner (if (or (doctor-possessivepronounp prev)
1351: (string-equal "s"
1352: (substring (doctor-make-string prev)
1353: -1)))
1354: prev
1355: 'your))))
1356:
1357: ;; Output of replies.
1358:
1359: (defun doctor-txtype (ans)
1360: "Output to buffer a list of symbols or strings as a sentence"
1361: (setq *print-upcase* t *print-space* nil)
1362: (mapcar 'doctor-type-symbol ans)
1363: (insert "\n"))
1364:
1365: (defun doctor-type-symbol (word)
1366: "Output a symbol to the buffer with some fancy case and spacing hacks"
1367: (setq word (doctor-make-string word))
1368: (if (string-equal word "i") (setq word "I"))
1369: (if *print-upcase*
1370: (progn
1371: (setq word (capitalize word))
1372: (if *print-space*
1373: (insert " "))))
1374: (cond ((or (string-match "^[.,;:?! ]" word)
1375: (not *print-space*))
1376: (insert word))
1377: (t (insert ?\ word)))
1378: (if (> (current-column) fill-column)
1379: (apply auto-fill-hook nil))
1380: (setq *print-upcase* (string-match "[.?!]$" word)
1381: *print-space* t))
1382:
1383: (defun doctor-build (str1 str2)
1384: "Make a symbol out of the concatenation of the two non-list arguments"
1385: (cond ((null str1) str2)
1386: ((null str2) str1)
1387: ((and (atom str1)
1388: (atom str2))
1389: (intern (concat (doctor-make-string str1)
1390: (doctor-make-string str2))))
1391: (t nil)))
1392:
1393: (defun doctor-make-string (obj)
1394: (cond ((stringp obj) obj)
1395: ((symbolp obj) (symbol-name obj))
1396: ((numberp obj) (int-to-string obj))
1397: (t "")))
1398:
1399: (defun doctor-concat (x y)
1400: "like append, but force atomic arguments to be lists"
1401: (append
1402: (if (and x (atom x)) (list x) x)
1403: (if (and y (atom y)) (list y) y)))
1404:
1405: (defun doctor-assm (proto)
1406: (cond ((null proto) nil)
1407: ((atom proto) (list proto))
1408: ((atom (car proto))
1409: (cons (car proto) (doctor-assm (cdr proto))))
1410: (t (doctor-concat (doctor-assm (eval (car proto))) (doctor-assm (cdr proto))))))
1411:
1412: ;; Functions that handle specific words or meanings when found.
1413:
1414: (defun doctor-go (destination)
1415: "Call a doctor- function"
1416: (funcall (intern (concat "doctor-" (doctor-make-string destination)))))
1417:
1418: (defun doctor-desire1 ()
1419: (doctor-go ($ whereoutp)))
1420:
1421: (defun doctor-huh ()
1422: (cond ((< (length sent) 9) (doctor-type ($ huhlst)))
1423: (t (doctor-type ($ longhuhlst)))))
1424:
1425: (defun doctor-rthing () (doctor-type ($ thlst)))
1426:
1427: (defun doctor-remem () (cond ((null history)(doctor-huh))
1428: ((doctor-type ($ remlst)))))
1429:
1430: (defun doctor-howdy ()
1431: (cond ((not howdyflag)
1432: (doctor-type '(($ hello) what brings you to see me \?))
1433: (setq howdyflag t))
1434: (t
1435: (doctor-type '(($ ibelieve) we\'ve introduced ourselves already \.))
1436: (doctor-type '(($ please) ($ describe) ($ things) \.)))))
1437:
1438: (defun doctor-when ()
1439: (cond ((< (length (memq found sent)) 3)(doctor-short))
1440: (t
1441: (setq sent (cdr (memq found sent)))
1442: (setq sent (doctor-fixup sent))
1443: (doctor-type '(($ whatwhen)(// sent) \?)))))
1444:
1445: (defun doctor-conj ()
1446: (cond ((< (length (memq found sent)) 4)(doctor-short))
1447: (t
1448: (setq sent (cdr (memq found sent)))
1449: (setq sent (doctor-fixup sent))
1450: (cond ((eq (car sent) 'of)
1451: (doctor-type '(are you ($ sure) that is the real reason \?))
1452: (setq things (cons (cdr sent) things)))
1453: (t
1454: (doctor-remember sent)
1455: (doctor-type ($ beclst)))))))
1456:
1457: (defun doctor-short ()
1458: (cond ((= (car repetitive-shortness) (1- lincount))
1459: (rplacd repetitive-shortness
1460: (1+ (cdr repetitive-shortness))))
1461: (t
1462: (rplacd repetitive-shortness 1)))
1463: (rplaca repetitive-shortness lincount)
1464: (cond ((> (cdr repetitive-shortness) 6)
1465: (cond ((not **mad**)
1466: (doctor-type '(($ areyou)
1467: just trying to see what kind of things
1468: i have in my vocabulary \? please try to
1469: carry on a reasonable conversation!))
1470: (setq **mad** t))
1471: (t
1472: (doctor-type '(i give up \. you need a lesson in creative
1473: writing \.\.\.))
1474: ;;(push monosyllables observation-list)
1475: )))
1476: (t
1477: (cond ((equal sent (doctor-assm '(yes)))
1478: (doctor-type '(($ isee) ($ inter) ($ whysay) this is so \?)))
1479: ((equal sent (doctor-assm '(because)))
1480: (doctor-type ($ shortbeclst)))
1481: ((equal sent (doctor-assm '(no)))
1482: (doctor-type ($ neglst)))
1483: (t (doctor-type ($ shortlst)))))))
1484:
1485: (defun doctor-alcohol () (doctor-type ($ drnk)))
1486:
1487: (defun doctor-desire ()
1488: (let ((foo (memq found sent)))
1489: (cond ((< (length foo) 2)
1490: (doctor-go (doctor-build (doctor-meaning found) 1)))
1491: ((memq (cadr foo) '(a an))
1492: (rplacd foo (append '(to have) (cdr foo)))
1493: (doctor-svo sent found 1 nil)
1494: (doctor-remember (list subj 'would 'like obj))
1495: (doctor-type ($ whywant)))
1496: ((not (eq (cadr foo) 'to))
1497: (doctor-go (doctor-build (doctor-meaning found) 1)))
1498: (t
1499: (doctor-svo sent found 1 nil)
1500: (doctor-remember (list subj 'would 'like obj))
1501: (doctor-type ($ whywant))))))
1502:
1503: (defun doctor-drug ()
1504: (doctor-type ($ drugs))
1505: (doctor-remember (list 'you 'used found)))
1506:
1507: (defun doctor-toke ()
1508: (doctor-type ($ toklst)))
1509:
1510: (defun doctor-state ()
1511: (doctor-type ($ states))(doctor-remember (list 'you 'were found)))
1512:
1513: (defun doctor-mood ()
1514: (doctor-type ($ moods))(doctor-remember (list 'you 'felt found)))
1515:
1516: (defun doctor-fear ()
1517: (setq feared (doctor-setprep sent found))
1518: (doctor-type ($ fears))
1519: (doctor-remember (list 'you 'were 'afraid 'of feared)))
1520:
1521: (defun doctor-hate ()
1522: (doctor-svo sent found 1 t)
1523: (cond ((memq 'not sent) (doctor-forget) (doctor-huh))
1524: ((equal subj 'you)
1525: (doctor-type '(why do you (// verb)(// obj) \?)))
1526: (t (doctor-type '(($ whysay)(list subj verb obj))))))
1527:
1528: (defun doctor-symptoms ()
1529: (doctor-type '(($ maybe) you should consult a doctor of medicine\,
1530: i am a psychiatrist \.)))
1531:
1532: (defun doctor-hates ()
1533: (doctor-svo sent found 1 t)
1534: (doctor-hates1))
1535:
1536: (defun doctor-hates1 ()
1537: (doctor-type '(($ whysay)(list subj verb obj))))
1538:
1539: (defun doctor-loves ()
1540: (doctor-svo sent found 1 t)
1541: (doctor-qloves))
1542:
1543: (defun doctor-qloves ()
1544: (doctor-type '(($ bother)(list subj verb obj) \?)))
1545:
1546: (defun doctor-love ()
1547: (doctor-svo sent found 1 t)
1548: (cond ((memq 'not sent) (doctor-forget) (doctor-huh))
1549: ((memq 'to sent) (doctor-hates1))
1550: (t
1551: (cond ((equal object 'something)
1552: (setq object '(this person you love))))
1553: (cond ((equal subj 'you)
1554: (setq lover obj)
1555: (cond ((equal lover '(this person you love))
1556: (setq lover '(your partner))
1557: (doctor-forget)
1558: (doctor-type '(with whom are you in love \?)))
1559: ((doctor-type '(($ please)
1560: ($ describe)
1561: ($ relation)
1562: (// lover)
1563: \.)))))
1564: ((equal subj 'i)
1565: (doctor-txtype '(we were discussing you!)))
1566: (t (doctor-forget)
1567: (setq obj 'someone)
1568: (setq verb (doctor-build verb 's))
1569: (doctor-qloves))))))
1570:
1571: (defun doctor-mach ()
1572: (setq found (doctor-plural found))
1573: (doctor-type ($ machlst)))
1574:
1575: (defun doctor-sexnoun () (doctor-sexverb))
1576:
1577: (defun doctor-sexverb ()
1578: (if (or (memq 'me sent)(memq 'myself sent)(memq 'i sent))
1579: (doctor-foul)
1580: (doctor-type ($ sexlst))))
1581:
1582: (defun doctor-death () (doctor-type ($ deathlst)))
1583:
1584: (defun doctor-foul ()
1585: (doctor-type ($ foullst)))
1586:
1587: (defun doctor-family ()
1588: (doctor-possess sent found)
1589: (doctor-type ($ famlst)))
1590:
1591: ;; I did not add this -- rms.
1592: (defun doctor-rms ()
1593: (cond (rms-flag (doctor-type ($ stallmanlst)))
1594: (t (setq rms-flag t) (doctor-type '(do you know Stallman \?)))))
1595:
1596: (defun doctor-school nil (doctor-type ($ schoollst)))
1597:
1598: (defun doctor-eliza ()
1599: (cond (eliza-flag (doctor-type ($ elizalst)))
1600: (t (setq eliza-flag t)
1601: (doctor-type '((// found) \? hah !
1602: ($ please) ($ continue) \.)))))
1603:
1604: (defun doctor-sports () (doctor-type ($ sportslst)))
1605:
1606: (defun doctor-math () (doctor-type ($ mathlst)))
1607:
1608: (defun doctor-zippy ()
1609: (cond (zippy-flag (doctor-type ($ zippylst)))
1610: (t (setq zippy-flag t)
1611: (doctor-type '(yow! are we interactive yet \?)))))
1612:
1613:
1614: (defun doctor-chat () (doctor-type ($ chatlst)))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.