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