Mercurial > hg > xemacs-beta

comparison lisp/games/doctor.el @ 4:b82b59fe008d r19-15b3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b3
author cvs
date Mon, 13 Aug 2007 08:46:56 +0200
parents 376386a54a3c
children 131b0175ea99
comparison
equal deleted inserted replaced
3:30df88044ec6 4:b82b59fe008d
1 ;;; doctor.el --- psychological help for frustrated users. 1 ;;; doctor.el --- psychological help for frustrated users.
2 2 ;;; (uncensored version--see below)
3 ;; Copyright (C) 1985, 1987, 1994 Free Software Foundation, Inc. 3
4 ;; Copyright (C) 1985, 1987, 1994, 1996 Free Software Foundation, Inc.
4 5
5 ;; Maintainer: FSF 6 ;; Maintainer: FSF
6 ;; Keywords: games 7 ;; Keywords: games
7 8
8 ;; This file is part of XEmacs. 9 ;; This file is part of XEmacs.
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 ;; General Public License for more details. 19 ;; General Public License for more details.
19 20
20 ;; You should have received a copy of the GNU General Public License 21 ;; You should have received a copy of the GNU General Public License
21 ;; along with XEmacs; see the file COPYING. If not, write to the Free 22 ;; along with XEmacs; see the file COPYING. If not, write to the Free
22 ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 23 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
23 24 ;; 02111-1307, USA.
24 ;;; Synched up with: FSF 19.28. 25
26 ;;; Synched up with: FSF 19.34.
25 27
26 ;;; Commentary: 28 ;;; Commentary:
27 29
28 ;; The single entry point `doctor', simulates a Rogerian analyst using 30 ;; The single entry point `doctor', simulates a Rogerian analyst using
29 ;; phrase-production techniques similar to the classic ELIZA demonstration 31 ;; phrase-production techniques similar to the classic ELIZA demonstration
30 ;; of pseudo-AI. 32 ;; of pseudo-AI.
33
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/
31 44
32 ;;; Code: 45 ;;; Code:
33 46
34 (defun doctor-cadr (x) (car (cdr x))) 47 (defun doctor-cadr (x) (car (cdr x)))
35 (defun doctor-caddr (x) (car (cdr (cdr x)))) 48 (defun doctor-caddr (x) (car (cdr (cdr x))))
223 (($ thlst)) 236 (($ thlst))
224 (($ areyou) ($ afraidof) that \?))) 237 (($ areyou) ($ afraidof) that \?)))
225 (make-local-variable 'feelings-about) 238 (make-local-variable 'feelings-about)
226 (setq feelings-about 239 (setq feelings-about
227 '((feelings about) 240 '((feelings about)
228 (aprehensions toward) 241 (apprehensions toward)
229 (thoughts on) 242 (thoughts on)
230 (emotions toward))) 243 (emotions toward)))
231 (make-local-variable 'random-adjective) 244 (make-local-variable 'random-adjective)
232 (setq random-adjective 245 (setq random-adjective
233 '((vivid) 246 '((vivid)
602 (doctor-put-meaning vax 'mach) 615 (doctor-put-meaning vax 'mach)
603 (doctor-put-meaning vms 'mach) 616 (doctor-put-meaning vms 'mach)
604 (doctor-put-meaning ibm 'mach) 617 (doctor-put-meaning ibm 'mach)
605 (doctor-put-meaning pc 'mach) 618 (doctor-put-meaning pc 'mach)
606 (doctor-put-meaning bitching 'foul) 619 (doctor-put-meaning bitching 'foul)
607 (doctor-put-meaning shit 'foul) 620 (doctor-put-meaning shit 'foul) ; Censored
608 (doctor-put-meaning bastard 'foul) 621 (doctor-put-meaning bastard 'foul)
609 (doctor-put-meaning damn 'foul) 622 (doctor-put-meaning damn 'foul)
610 (doctor-put-meaning damned 'foul) 623 (doctor-put-meaning damned 'foul)
611 (doctor-put-meaning hell 'foul) 624 (doctor-put-meaning hell 'foul)
612 (doctor-put-meaning suck 'foul) 625 (doctor-put-meaning suck 'foul)
677 (doctor-put-meaning excited 'mood) 690 (doctor-put-meaning excited 'mood)
678 (doctor-put-meaning worried 'mood) 691 (doctor-put-meaning worried 'mood)
679 (doctor-put-meaning lonely 'mood) 692 (doctor-put-meaning lonely 'mood)
680 (doctor-put-meaning angry 'mood) 693 (doctor-put-meaning angry 'mood)
681 (doctor-put-meaning mad 'mood) 694 (doctor-put-meaning mad 'mood)
682 (doctor-put-meaning pissed 'mood) 695 (doctor-put-meaning pissed 'mood) ; censored
683 (doctor-put-meaning jealous 'mood) 696 (doctor-put-meaning jealous 'mood)
684 (doctor-put-meaning afraid 'fear) 697 (doctor-put-meaning afraid 'fear)
685 (doctor-put-meaning terrified 'fear) 698 (doctor-put-meaning terrified 'fear)
686 (doctor-put-meaning fear 'fear) 699 (doctor-put-meaning fear 'fear)
687 (doctor-put-meaning scared 'fear) 700 (doctor-put-meaning scared 'fear)
691 (doctor-put-meaning virgin 'sexnoun) 704 (doctor-put-meaning virgin 'sexnoun)
692 (doctor-put-meaning cock 'sexnoun) 705 (doctor-put-meaning cock 'sexnoun)
693 (doctor-put-meaning cocks 'sexnoun) 706 (doctor-put-meaning cocks 'sexnoun)
694 (doctor-put-meaning dick 'sexnoun) 707 (doctor-put-meaning dick 'sexnoun)
695 (doctor-put-meaning dicks 'sexnoun) 708 (doctor-put-meaning dicks 'sexnoun)
696 (doctor-put-meaning cunt 'sexnoun) 709 (doctor-put-meaning cunt 'sexnoun) ; censored
697 (doctor-put-meaning cunts 'sexnoun) 710 (doctor-put-meaning cunts 'sexnoun) ; censored
698 (doctor-put-meaning prostitute 'sexnoun) 711 (doctor-put-meaning prostitute 'sexnoun)
699 (doctor-put-meaning condom 'sexnoun) 712 (doctor-put-meaning condom 'sexnoun)
700 (doctor-put-meaning sex 'sexnoun) 713 (doctor-put-meaning sex 'sexnoun)
701 (doctor-put-meaning rapes 'sexnoun) 714 (doctor-put-meaning rapes 'sexnoun)
702 (doctor-put-meaning wife 'family) 715 (doctor-put-meaning wife 'family)
750 (doctor-put-meaning bourbon 'alcohol) 763 (doctor-put-meaning bourbon 'alcohol)
751 (doctor-put-meaning beer 'alcohol) 764 (doctor-put-meaning beer 'alcohol)
752 (doctor-put-meaning wine 'alcohol) 765 (doctor-put-meaning wine 'alcohol)
753 (doctor-put-meaning whiskey 'alcohol) 766 (doctor-put-meaning whiskey 'alcohol)
754 (doctor-put-meaning scotch 'alcohol) 767 (doctor-put-meaning scotch 'alcohol)
755 (doctor-put-meaning fuck 'sexverb) 768 (doctor-put-meaning fuck 'sexverb) ; censored
756 (doctor-put-meaning fucked 'sexverb) 769 (doctor-put-meaning fucked 'sexverb) ; censored
757 (doctor-put-meaning screw 'sexverb) 770 (doctor-put-meaning screw 'sexverb)
758 (doctor-put-meaning screwing 'sexverb) 771 (doctor-put-meaning screwing 'sexverb)
759 (doctor-put-meaning fucking 'sexverb) 772 (doctor-put-meaning fucking 'sexverb) ; censored
760 (doctor-put-meaning rape 'sexverb) 773 (doctor-put-meaning rape 'sexverb)
761 (doctor-put-meaning raped 'sexverb) 774 (doctor-put-meaning raped 'sexverb)
762 (doctor-put-meaning kiss 'sexverb) 775 (doctor-put-meaning kiss 'sexverb)
763 (doctor-put-meaning kissing 'sexverb) 776 (doctor-put-meaning kissing 'sexverb)
764 (doctor-put-meaning kisses 'sexverb) 777 (doctor-put-meaning kisses 'sexverb)
765 (doctor-put-meaning screws 'sexverb) 778 (doctor-put-meaning screws 'sexverb)
766 (doctor-put-meaning fucks 'sexverb) 779 (doctor-put-meaning fucks 'sexverb) ; censored
767 (doctor-put-meaning because 'conj) 780 (doctor-put-meaning because 'conj)
768 (doctor-put-meaning but 'conj) 781 (doctor-put-meaning but 'conj)
769 (doctor-put-meaning however 'conj) 782 (doctor-put-meaning however 'conj)
770 (doctor-put-meaning besides 'conj) 783 (doctor-put-meaning besides 'conj)
771 (doctor-put-meaning anyway 'conj) 784 (doctor-put-meaning anyway 'conj)
859 (doctor-doc sent) 872 (doctor-doc sent)
860 (insert "\n") 873 (insert "\n")
861 (setq bak sent))) 874 (setq bak sent)))
862 875
863 (defun doctor-readin nil 876 (defun doctor-readin nil
864 "Read a sentence. Return it as a list of words." 877 "Read a sentence. Return it as a list of words."
865 (let (sentence) 878 (let (sentence)
866 (backward-sentence 1) 879 (backward-sentence 1)
867 (while (not (eobp)) 880 (while (not (eobp))
868 (setq sentence (append sentence (list (doctor-read-token))))) 881 (setq sentence (append sentence (list (doctor-read-token)))))
869 sentence)) 882 sentence))
879 ;; Main processing function for sentences that have been read. 892 ;; Main processing function for sentences that have been read.
880 893
881 (defun doctor-doc (sent) 894 (defun doctor-doc (sent)
882 (cond 895 (cond
883 ((equal sent '(foo)) 896 ((equal sent '(foo))
884 (doctor-type '(bar! ($ please)($ continue)))) 897 (doctor-type '(bar! ($ please)($ continue) \.)))
885 ((member sent howareyoulst) 898 ((member sent howareyoulst)
886 (doctor-type '(i\'m ok \. ($ describe) yourself \.))) 899 (doctor-type '(i\'m ok \. ($ describe) yourself \.)))
887 ((or (member sent '((good bye) (see you later) (i quit) (so long) 900 ((or (member sent '((good bye) (see you later) (i quit) (so long)
888 (go away) (get lost))) 901 (go away) (get lost)))
889 (memq (car sent) 902 (memq (car sent)
890 '(bye halt break quit done exit goodbye 903 '(bye halt break quit done exit goodbye
891 bye\, stop pause goodbye\, stop pause))) 904 bye\, stop pause goodbye\, stop pause)))
892 (doctor-type ($ bye))) 905 (doctor-type ($ bye)))
893 ((and (eq (car sent) 'you) 906 ((and (eq (car sent) 'you)
999 (defun doctor-forget () 1012 (defun doctor-forget ()
1000 "Delete the last element of the history list." 1013 "Delete the last element of the history list."
1001 (setq history (reverse (cdr (reverse history))))) 1014 (setq history (reverse (cdr (reverse history)))))
1002 1015
1003 (defun doctor-query (x) 1016 (defun doctor-query (x)
1004 "Prompt for a line of input from the minibuffer until a noun or 1017 "Prompt for a line of input from the minibuffer until a noun or verb is seen.
1005 verb is seen. Put dialogue in buffer." 1018 Put dialogue in buffer."
1006 (let (a 1019 (let (a
1007 (prompt (concat (doctor-make-string x) 1020 (prompt (concat (doctor-make-string x)
1008 " what \? ")) 1021 " what \? "))
1009 retval) 1022 retval)
1010 (while (not retval) 1023 (while (not retval)
1023 (car a)))) 1036 (car a))))
1024 ((setq a (cdr a)))))) 1037 ((setq a (cdr a))))))
1025 retval)) 1038 retval))
1026 1039
1027 (defun doctor-subjsearch (sent key type) 1040 (defun doctor-subjsearch (sent key type)
1028 "Search for the subject of a sentence SENT, looking for the noun closest to 1041 "Search for the subject of a sentence SENT, looking for the noun closest
1029 and preceding KEY by at least TYPE words. Set global variable subj to the 1042 to and preceding KEY by at least TYPE words. Set global variable subj to
1030 subject noun, and return the portion of the sentence following it." 1043 the subject noun, and return the portion of the sentence following it."
1031 (let ((i (- (length sent) (length (memq key sent)) type))) 1044 (let ((i (- (length sent) (length (memq key sent)) type)))
1032 (while (and (> i -1) (not (doctor-nounp (nth i sent)))) 1045 (while (and (> i -1) (not (doctor-nounp (nth i sent))))
1033 (setq i (1- i))) 1046 (setq i (1- i)))
1034 (cond ((> i -1) 1047 (cond ((> i -1)
1035 (setq subj (nth i sent)) 1048 (setq subj (nth i sent))
1075 drive drives driving drove dying 1088 drive drives driving drove dying
1076 eat eating eats expand expanded expands 1089 eat eating eats expand expanded expands
1077 expect expected expects expel expels expelled 1090 expect expected expects expel expels expelled
1078 explain explained explains 1091 explain explained explains
1079 fart farts feel feels felt fight fights find finds finding 1092 fart farts feel feels felt fight fights find finds finding
1080 forget forgets forgot fought found fuck fucked 1093 forget forgets forgot fought found fuck fucked ; censored
1081 fucking fucks 1094 fucking fucks ; censored
1082 gave get gets getting give gives go goes going gone got gotten 1095 gave get gets getting give gives go goes going gone got gotten
1083 had harm harms has hate hated hates have having 1096 had harm harms has hate hated hates have having
1084 hear heard hears hearing help helped helping helps 1097 hear heard hears hearing help helped helping helps
1085 hit hits hope hoped hopes hurt hurts 1098 hit hits hope hoped hopes hurt hurts
1086 implies imply is 1099 implies imply is
1217 1230
1218 (defun doctor-othermodifierp (x) 1231 (defun doctor-othermodifierp (x)
1219 (memq x '(all also always amusing any anyway associated awesome 1232 (memq x '(all also always amusing any anyway associated awesome
1220 bad beautiful best better but certain clear 1233 bad beautiful best better but certain clear
1221 ever every fantastic fun funny 1234 ever every fantastic fun funny
1222 good great gross growdy however if ignorant 1235 good great grody gross however if ignorant
1223 less linked losing lusing many more much 1236 less linked losing lusing many more much
1224 never nice obnoxious often poor pretty real related rich 1237 never nice obnoxious often poor pretty real related rich
1225 similar some stupid super superb 1238 similar some stupid super superb
1226 terrible terrific too total tubular ugly very))) 1239 terrible terrific too total tubular ugly very)))
1227 1240
1307 1320
1308 (defun doctor-vowelp (x) 1321 (defun doctor-vowelp (x)
1309 (memq x '(?a ?e ?i ?o ?u))) 1322 (memq x '(?a ?e ?i ?o ?u)))
1310 1323
1311 (defun doctor-replace (sent rlist) 1324 (defun doctor-replace (sent rlist)
1312 "Replace any element of SENT that is the car of a replacement element 1325 "Replace any element of SENT that is the car of a replacement
1313 pair in RLIST." 1326 element pair in RLIST."
1314 (apply 'append 1327 (apply 'append
1315 (mapcar 1328 (mapcar
1316 (function 1329 (function
1317 (lambda (x) 1330 (lambda (x)
1318 (cdr (or (assq x rlist) ; either find a replacement 1331 (cdr (or (assq x rlist) ; either find a replacement
1329 (setq found (car sent)) 1342 (setq found (car sent))
1330 (doctor-meaning (car sent))))) 1343 (doctor-meaning (car sent)))))
1331 1344
1332 (defun doctor-svo (sent key type mem) 1345 (defun doctor-svo (sent key type mem)
1333 "Find subject, verb and object in sentence SENT with focus on word KEY. 1346 "Find subject, verb and object in sentence SENT with focus on word KEY.
1334 TYPE is number of words preceding KEY to start looking for subject. MEM is 1347 TYPE is number of words preceding KEY to start looking for subject.
1335 t if results are to be put on Doctor's memory stack. 1348 MEM is t if results are to be put on Doctor's memory stack.
1336 Return is in global variables `subj', `verb' and `object'." 1349 Return in the global variables SUBJ, VERB and OBJECT."
1337 (let ((foo (doctor-subjsearch sent key type))) 1350 (let ((foo (doctor-subjsearch sent key type)))
1338 (or foo 1351 (or foo
1339 (setq foo sent 1352 (setq foo sent
1340 mem nil)) 1353 mem nil))
1341 (while (and (null (doctor-verbp (car foo))) (cdr foo)) 1354 (while (and (null (doctor-verbp (car foo))) (cdr foo))
1345 (cond ((eq object 'i)(setq object 'me)) 1358 (cond ((eq object 'i)(setq object 'me))
1346 ((eq subj 'me)(setq subj 'i))) 1359 ((eq subj 'me)(setq subj 'i)))
1347 (cond (mem (doctor-remember (list subj verb obj)))))) 1360 (cond (mem (doctor-remember (list subj verb obj))))))
1348 1361
1349 (defun doctor-possess (sent key) 1362 (defun doctor-possess (sent key)
1350 "Set possessive in SENT for keyword KEY. Hack on previous word, setting 1363 "Set possessive in SENT for keyword KEY.
1351 global variable `owner' to possibly correct result." 1364 Hack on previous word, setting global variable OWNER to correct result."
1352 (let* ((i (- (length sent) (length (memq key sent)) 1)) 1365 (let* ((i (- (length sent) (length (memq key sent)) 1))
1353 (prev (if (< i 0) 'your 1366 (prev (if (< i 0) 'your
1354 (nth i sent)))) 1367 (nth i sent))))
1355 (setq owner (if (or (doctor-possessivepronounp prev) 1368 (setq owner (if (or (doctor-possessivepronounp prev)
1356 (string-equal "s" 1369 (string-equal "s"
1620 1633
1621 (defun doctor-chat () (doctor-type ($ chatlst))) 1634 (defun doctor-chat () (doctor-type ($ chatlst)))
1622 1635
1623 (defun doctor-strangelove () 1636 (defun doctor-strangelove ()
1624 (interactive) 1637 (interactive)
1625 (insert "Mein fuhrer!!\n") 1638 (insert "Mein fuehrer!!\n")
1626 (doctor-read-print)) 1639 (doctor-read-print))
1627 1640
1628 ;;; doctor.el ends here 1641 ;;; doctor.el ends here