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