Mercurial > hg > xemacs-beta

comparison lisp/games/doctor.el @ 70:131b0175ea99 r20-0b30

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