github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-05-25 06:40:45 +00:00
Code Issues Releases Wiki Activity
Files
ejs/hakmem
PDP-10.its/src/games/animal.133
Eric Swenson 088ec2d6d9 Added NGAME and games invoked by it.
2018-05-20 12:49:09 -07:00

2114 lines
60 KiB
Common Lisp
Raw Permalink Blame History

This file contains invisible Unicode characters
This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
;;; -*- Mode:LISP; Base:10 -*-
;;;
(COMMENT Initialize Environment)
;; Allocate storage
(ALLOC '(LIST 130000.))
(ALLOC '(SYMBOL 60000.))
(ALLOC '(FIXNUM 30000.))
;; Turn off autoload messages
(SSTATUS FEATURE NOLDMSG)
;; Init interesting lisp variables
(EVAL-WHEN (EVAL LOAD COMPILE)
(SETQ BASE 10. IBASE 10. *NOPOINT NIL)) ; I/O Base 10 anytime
(NOUUO T) (*RSET T) (SETQ PURE 1.) ; Debugging enabled at runtime
;; Declare imported things ...
(DECLARE (*EXPR INTERJECTION? PREPOSITION? PRONOUN? NOUN? PERSON-NAME?
VERB? ADJECTIVE? ADVERB? MODIFIER?
PART-OF-SPEECH PART-OF-SPEECH? IS-A? FEMALE-NAME? MALE-NAME?
VERB-SING? VERB-PLURAL? VERB-PP?
MATCH
LOWERCASIFY CAPITALIZE UPPERCASIFY DIGIT?
PARSE$MAKE-WORDS EXPAND-CONTRACTIONS EXPAND-ABBREVS))
;; Declare special types of functions...
(DECLARE (*LEXPR DISPLAY))
;; Load supporting packages
(EVAL-WHEN (EVAL LOAD COMPILE) ; Always
(LOAD '|GAMES;PARSE FASL|) ; Load lexical parser
(LOAD '|GAMES;WORDS FASL|) ; Load dictionary stuff
(LOAD '|GAMES;PATTRN FASL|) ; Load pattern matcher
(DEFUN CONCAT X ; Pname concatenation
(IMPLODE (MAPCAN 'EXPLODEN (LISTIFY X))))
(DEFUN PARSE-INPUT (X) ; Parser -- assembles
(EXPAND-ABBREVS ; hacks from several
(EXPAND-CONTRACTIONS ; packages
(PARSE$MAKE-WORDS
(COND ((FIXP (CAR X)) (MAPCAR 'ASCII X))
(T X))))))
(DEFUN PARSE-/" () ; Define our very sophisticated
(DO ((C (TYI) (TYI)) ; doublequote macro
(L () (CONS C L)))
((= C 34.) (PARSE-INPUT (NREVERSE L)))))
(SSTATUS MACRO /" 'PARSE-/")) ; Enable doublequote macro
(EVAL-WHEN (EVAL COMPILE) ; Setup
(LOAD '|LIBLSP;IOTA FASL|)
(SETQ ANIMAL-VERSION (CADDR (TRUENAME INFILE))))
(INCLUDE ((DSK GAMES) LSRRTN INSERT)) ; Include support for the
; LOOKUP-INQUIR-INFO macro
; and GET-USER-NAME subr
(DEFUN *VERSION MACRO (()) `',ANIMAL-VERSION)
(DEFUN VERSION () (*VERSION))
(EVAL-WHEN (EVAL LOAD) ; Runtime
(LOAD '|GAMES;WORD FASL|)) ; Load string hacks
(COMMENT Useful Macros)
;;; (DO-FOREVER <bvl> . <body>)
;;; Like a DO with no termination condition. Clearer to read.
(DEFMACRO DO-FOREVER (BVL &REST BODY) `(DO ,BVL (NIL) ,@BODY))
(COMMENT Data Structure)
;;; Database structure
;;;
;;; <Node> is a <Question-Node> or a <Terminal-Node>
;;;
;;; <Question-Node> has components QUESTION, NO-BRANCH, YES-BRANCH, AUTHOR
;;; <Terminal-Node> has components TERMINAL, AUTHOR
;;;
;;; There are EXTRACT-<component> operators for all components.
;;;
;;; The predicates QUESTION-NODE? and TERMINAL-NODE? may be applied to any
;;; node to find its type.
;;;
(DEFMACRO CONSTRUCT-QUESTION (QUES NO YES &OPTIONAL (AUTHOR '(STATUS USERID)))
`(LIST ,QUES ,AUTHOR ,NO ,YES))
(DEFMACRO CONSTRUCT-TERMINAL (TERM &OPTIONAL (AUTHOR '(STATUS USERID)))
`(LIST ,TERM ,AUTHOR))
(DEFMACRO COPY-NODE (NODE) `(SUBST NIL NIL ,NODE))
(DEFMACRO EXTRACT-QUESTION (NODE) `(CAR ,NODE))
(DEFMACRO EXTRACT-TERMINAL (NODE) `(CAR ,NODE))
(DEFMACRO EXTRACT-AUTHOR (NODE) `(CADR ,NODE))
(DEFMACRO EXTRACT-NO-BRANCH (NODE) `(CADDR ,NODE))
(DEFMACRO EXTRACT-YES-BRANCH (NODE) `(CADDDR ,NODE))
(DEFMACRO TERMINAL-NODE? (NODE) `(ATOM (CAR ,NODE)))
(DEFMACRO QUESTION-NODE? (NODE) `(NOT (ATOM (CAR ,NODE))))
(COMMENT Variable Initializations)
;;; (INITIALIZE <descriptor1> <value1> <descriptor2> <value2> ...)
;;;
;;; <descriptor> ::= <symbol> ! (<symbol> <attribute1> <attribute2> ...)
;;;
;;; Expands to:
;;;
;;; (PROGN 'COMPILE
;;; (DECLARE (<attribute1> ... things with that attribute ... )
;;; (<attribute2> ... things with that attribute ... ) ...)
;;; (SETQ <var1> <value1>)
;;; (SETQ <var2> <value2>) ...)
;;;
(DEFMACRO INITIALIZE (&REST INFO)
(DO ((L INFO (CDDR L))
(INITS ())
(NAME ())
(ATTRIBUTES (NCONS NIL)))
((NULL L)
`(PROGN 'COMPILE
(DECLARE ,@(DO ((A (CDR ATTRIBUTES) (CDDR A))
(L () (CONS (CONS (CAR A) (CADR A)) L)))
((NULL A) L)))
,@(NREVERSE INITS)))
(COND ((ATOM (CAR L)) (SETQ NAME (CAR L)))
(T (SETQ NAME (CAAR L))
(MAPCAR #'(LAMBDA (X)
(PUTPROP ATTRIBUTES
(CONS NAME
(GET ATTRIBUTES X))
X))
(CDAR L))))
(PUSH `(SETQ ,NAME ,(CADR L)) INITS)))
(INITIALIZE
;; Random ...
(*PLAYER-NAME* SPECIAL) (STATUS USERID)
(*PLAYER-OBJECT-PRONOUN* SPECIAL) '||
(*PLAYER-SUBJECT-PRONOUN* SPECIAL)'||
(*FULL-NAME* SPECIAL) '||
(*LAST-NAME* SPECIAL) '||
(*NICK-NAME* SPECIAL) '||
(*FIRST-NAME* SPECIAL) '||
;; Data-structure stuff
(*NEW* SPECIAL) (NCONS (GENSYM)) ; For debugging
(*OLD* SPECIAL) (NCONS (GENSYM)) ; For debugging
(*MEMORY* SPECIAL) (CONSTRUCT-TERMINAL 'DOG '|No one|)
(*CURRENT-NODE* SPECIAL) *MEMORY*
;; Display Features
(*DISPLAY* SPECIAL) '|** Tell KMP I have a display bug **|
(*FILL-COLUMN* SPECIAL FIXNUM) (- (LINEL TYO) 15.)
;; Filenames
(*SAVE-FILE* SPECIAL) '((DSK games) ANIMAL SAVE)
(*NOTES-FILE* SPECIAL) '((DSK games) ANIMAL NOTES)
(*NEWS-FILE* SPECIAL) '((DSK games) ANIMAL NEWS)
(*INSTRUCTION-FILE* SPECIAL) '((DSK games) ANIMAL RULES)
(*MEMORY-AREA* SPECIAL) '((ARC games) * *)
;; Debug options
(*DEBUG* SPECIAL) NIL
;; Random flags
(*WATER-FLAG* SPECIAL) NIL
(*FOUL-FLAG* SPECIAL) NIL
(*FOUL-COUNT* SPECIAL) 0.
(*FOUL-COUNT-MAX* SPECIAL) 3.
(*APOLOGY-FLAG* SPECIAL) NIL
(*FORGIVE-FLAG* SPECIAL) NIL
(*DOT-WARN* SPECIAL) NIL
)
(COMMENT Utility Routines)
;;; (PRINTF <input-file-name> <output-file-object>)
;;; Prints out <input-file-name> to the already-open <output-file-object>.
;;; Expects that <input-file-name> will end in a carriage return.
(DEFUN PRINTF (IFILE OSTREAM)
(IOTA ((ISTREAM IFILE '(IN ASCII SINGLE)))
(DO ((C (READLINE ISTREAM 0.) (READLINE ISTREAM 0.)))
((NUMBERP C) (TERPRI OSTREAM))
(TERPRI OSTREAM)
(PRINC C OSTREAM))))
;;; (CREATEF <filename>)
;;; Creates a file named <filename> clobbering <filename> if it already
;;; exists.
(DEFUN CREATEF (X) (IOTA ((STREAM X 'OUT)) T))
;;; (ADDPROP <sym> <val> <lab>)
;;;
;;; CONS's <val> onto the head of <sym>'s <lab> property.
(DEFUN ADDPROP (SYM VAL LAB)
(PUTPROP SYM (CONS VAL (GET SYM LAB)) LAB))
;;; (SWAP <object1> <object2>)
;;;
;;; Swaps object1 and object2
(DEFUN SWAP (X Y)
(RPLACA Y (PROG1 (CAR X) (RPLACA X (CAR Y))))
(RPLACD Y (PROG1 (CDR X) (RPLACD X (CDR Y))))
T)
(DEFUN CLOCK-TIME ()
(LET ((BASE 10.)
(*NOPOINT T)
((HOURS MINS) (STATUS DAYTIME))
(A/P)
(DIG))
(SETQ A/P (COND ((> HOURS 11.) '/p) (T '/a)))
(SETQ DIG (COND ((< MINS 10.) (NCONS '/0)) (T NIL)))
(SETQ HOURS (\ HOURS 12.))
(IMPLODE (NCONC (EXPLODEN HOURS)
(CONS '/: DIG)
(EXPLODEN MINS)
(LIST A/P '/m)))))
(COMMENT Rule Definitions)
;;; DEF-DEF
;;;
;;; A macro-defining macro! See documentation on next page...
(DEFMACRO DEF-DEF (CLASS HEADER DATABASE-NAME)
`(PROGN
'COMPILE
(DECLARE (SPECIAL ,DATABASE-NAME))
(SETQ ,DATABASE-NAME ())
(DEFMACRO ,(CONCAT 'DEF- CLASS) (RULE-NAME ARG-LIST LOCALS &REST STUFF)
(LET ((CONDITIONS)
(BODY)
(LOCAL-NAMES (DO ((L LOCALS (CDR L))
(LN ()))
((NULL L) (NREVERSE LN))
(PUSH (COND ((ATOM (CAR L)) (CAR L))
(T (CAAR L)))
LN))))
(DO () ((NOT (ATOM (CAR STUFF)))) (POP STUFF))
(DO ((L STUFF (CDR L)))
((ATOM (CAR L))
(SETQ CONDITIONS (NREVERSE CONDITIONS))
(SETQ BODY (CDR L)))
(PUSH (CAR L) CONDITIONS))
(LET ((COND-ID (CONCAT ',HEADER '$ RULE-NAME '/?))
(RULE-ID (CONCAT ',HEADER '$ RULE-NAME))
(DRIVER (CONCAT ',HEADER '$ RULE-NAME '/!)))
`(PROGN 'COMPILE
(DEFUN ,COND-ID ,ARG-LIST
(DECLARE (SPECIAL ,@LOCAL-NAMES))
,@ARG-LIST
,(COND ((> (LENGTH CONDITIONS) 1.)
`(OR ,@CONDITIONS))
(T
(CAR CONDITIONS))))
(DEFUN ,RULE-ID ,ARG-LIST
(DECLARE (SPECIAL ,@LOCAL-NAMES))
,@ARG-LIST
,@BODY)
(DEFUN ,DRIVER ,ARG-LIST
(LET ,LOCALS
(DECLARE (SPECIAL ,@LOCAL-NAMES))
(COND ((,COND-ID ,@ARG-LIST)
(NCONS (,RULE-ID
,@ARG-LIST)))
(T NIL))))
(SETQ ,',DATABASE-NAME
(NCONC ,',DATABASE-NAME
(NCONS ',DRIVER)))
',',DATABASE-NAME))))))
;;; (DEF-DEF <class> <header> <database-name>)
;;;
;;; Initializes a global variable <database-name> to NIL and
;;; defines a macro DEF-<class> which is callable via the syntax
;;;
;;; (DEF-<class> <rulename> <args> <local-vars> . <body>)
;;;
;;; <body> ::= (IF <antecedent-body> THEN <consequent-body>)
;;;
;;; which will define three more functions when called...
;;;
;;; Predicate...
;;;
;;; (DEFUN <header>$<rulename>? <args> <antecedent-body>)
;;;
;;; Action...
;;;
;;; (DEFUN <header>$<rulename> <args> <consequent-body>)
;;;
;;; Driver... Calls action if predicate wins
;;;
;;; (DEFUN <header>$<rulename>! <args> (LET <local-vars> ...))
;;;
;;; and will NCONC the driver's name to the list <database-name> via NCONC.
;;;
(DEF-DEF EXIT EXIT EXITS)
(DEF-DEF TRANSFORM TRANSFORM TRANSFORMATIONS)
(DEF-DEF INTERPRETATION INTERPRET INTERPRETATIONS)
(DEF-DEF QUESTION QUESTION QUESTIONS)
(DEF-DEF STATEMENT STATEMENT RANDOM-STATEMENTS)
(DEFUN TRY-RULES (RULE-SET EXPRESSION)
(*CATCH 'DONE
(DO-FOREVER ((FLAG NIL T))
(DO ((R RULE-SET (CDR R))
(TEMP))
((NULL R) (*THROW 'DONE EXPRESSION))
(SETQ TEMP (FUNCALL (CAR R) EXPRESSION))
(COND (TEMP
(SETQ EXPRESSION (CAR TEMP))
(RETURN T)))))))
(DEFUN TRY-RULES-ONCE (RULE-SET EXPRESSION)
(DO ((R RULE-SET (CDR R))
(TEMP))
((NULL R) NIL)
(SETQ TEMP (FUNCALL (CAR R) EXPRESSION))
(COND (TEMP
(SETQ EXPRESSION (CAR TEMP))
(RETURN EXPRESSION)))))
(COMMENT I/O Routines)
(DEFMACRO CATCH-ROUND-EXIT (FORM) `(*CATCH 'EXIT-ROUND ,FORM))
(DEFMACRO ABORT-ROUND () `(*THROW 'EXIT-ROUND NIL))
(DEFMACRO OUTPUT-BIND (&REST FORM) `(LET ((*DISPLAY* (NCONS '||))) ,@FORM))
(DEFUN READ-SENTENCE ()
(LET ((RESULT (LET* ((S (READ-A-SENTENCE))
(P (PARSE-INPUT S)))
(COND ((FOUL-ANSWER? P)
(HANDLE-FOUL-LANGUAGE P)
(DISPLAY *DISPLAY*)
(READ-SENTENCE))
(T
(HUNK (CAR P) (CXR 2. S) (CDR P)))))))
(COND ((HANDLE-RANDOMNESS RESULT)
(DISPLAY *DISPLAY*)
(READ-SENTENCE))
(T
RESULT))))
(DEFUN REDISPLAY (L)
(DISPLAY *DISPLAY*)
(MAPC #'(LAMBDA (X) (TYO X TYO)) (REVERSE L)))
(DEFUN WARN-/. (())
(SETQ *DOT-WARN* NIL)
(NOINTERRUPT NIL)
(OUTPUT-BIND (DISPLAY '|Type a '.' to terminate your input.|))
(*THROW 'SMART-TYI #\FORM))
(DEFUN SMART-TYI (INSTREAM)
(COND ((AND *DOT-WARN* (ZEROP (LISTEN INSTREAM)))
(LET ((ALARMCLOCK 'WARN-/.))
(*CATCH 'SMART-TYI
(UNWIND-PROTECT
(PROGN (ALARMCLOCK 'TIME 11.) (TYI INSTREAM))
(ALARMCLOCK 'TIME NIL)))))
(T
(TYI INSTREAM))))
(DEFUN READ-A-SENTENCE ()
(DO-FOREVER ((C (TYI TYI) (SMART-TYI TYI))
(L NIL)
(TYPE)
(*DOT-WARN* T))
(CASEQ C
((#\FORM) (REDISPLAY L))
((#/. #/? #/!)
(COND (L ; Only if there was input do we return...
(SETQ TYPE (CASEQ C
((#/.) 'STATEMENT)
((#/!) 'EXCLAMATION)
((#/?) 'QUESTION)))
(SETQ L (NREVERSE L))
(RETURN (HUNK (CAR L) TYPE (CDR L))))
((= C #/?) ; Maybe he's confused...
(REDISPLAY L))))
((#\RETURN)
(COND ((= (CAR L) #\RETURN)
(OUTPUT-BIND
(DISPLAY '|Terminate your input with a '.' please.|))
(POP L)
(REDISPLAY L))
(T
(PUSH C L))))
((#\RUBOUT)
(COND (L (RUBOUT (POP L)))))
(T
(PUSH C L)))))
(DEFUN SENTENCE-TYPE? (X) (CXR 2. X))
(DEFUN SET-SENTENCE-TYPE (X VAL) (RPLACX 2. X VAL) VAL)
(DEFUN MAKE-WORD (X)
(COND ((NULL X) '||)
((ATOM X) X)
((NULL (CDR X)) (MAKE-WORD (CAR X)))
(T (CONCAT (MAKE-WORD (CAR X)) '| | (MAKE-WORD (CDR X))))))
(DEFUN READ-NOUN ()
(LET ((A (READ-SENTENCE))
(BAR) (FOO) (MOD) (MODS) (NOUN) (NOUNS) (PREP)
(PUNC) (REST) (STUFF))
(DECLARE (SPECIAL FOO BAR STUFF NOUN PREP MOD
MODS PUNC REST PREP NOUNS))
(COND ((INDETERMINATE-ANSWER? A)
(DISPLAY '"Oh well. Let's start a new game, then...")
(ABORT-ROUND))
((I-DONT-CARE-ANSWER? A)
(DISPLAY '"Hrrmmf! Then neither do I... I quit!")
(ABORT-ROUND)))
(COND ((MATCHES A
((?= INTERJECTION? )
(*= DELIMITER? )
(* FOO )
(?= NOUN? NOUN )
(* BAR )))
(SETQ A (APPEND FOO NOUN BAR))))
(COND ((MATCHES A
((* STUFF )
(*= NOUN? NOUN )
(?= DELIMITER? PUNC )
(*)))
(SETQ A (APPEND STUFF NOUN))))
(COND ((MATCHES A
((*= MODIFIER? )
(?= NOUN? )
(?= STATE-OF-BEING-VERB? )
(* REST )))
(SETQ A REST)))
(COND ((MATCHES A
((* STUFF )
(?= NOUN? NOUN )
(?= PREPOSITION? PREP )
(*= MODIFIER? MODS )
(*= NOUN? NOUNS )))
(LET ((ANSWER (MAKE-WORD
(LIST* NOUN PREP (APPEND MODS NOUNS)))))
(PUTPROP ANSWER STUFF 'MODIFIERS)
ANSWER))
((MATCHES A
((*= COMPARATIVE-ADJECTIVE? FOO )
(*= COMPARATOR? BAR )
(*= MODIFIER? MODS )
(?= NOUN? NOUN )
(* REST )))
(LET ((ANSWER (MAKE-WORD (CONS NOUN REST)))
(REPLY (APPEND FOO BAR MODS)))
(COND ((MEMQ (CAR REPLY) '(A AN))
(PUTPROP ANSWER (CDR REPLY) 'MODIFIERS))
(T
(PUTPROP ANSWER REPLY 'MODIFIERS)))
ANSWER))
((I-DONT-CARE-ANSWER? A)
(DISPLAY '"Well, since you're so indifferent... I quit!")
(ABORT-ROUND))
((OR (NO-ANSWER? A) (YES-ANSWER? A))
(DISPLAY '"That doesn't make any sense! I quit!")
(ABORT-ROUND))
(T
(DISPLAY '"I don't understand.")
(READ-NOUN)))))
(DEFUN QUERY (X)
(DISPLAY X)
(LET ((REPLY (READ-SENTENCE)))
(COND ((INDETERMINATE-ANSWER? REPLY)
(DISPLAY '|Please just answer 'YES' or 'NO'...|)
(QUERY X))
((QUIT-ANSWER? REPLY) (SUICIDE))
((YES-ANSWER? REPLY) T)
((NO-ANSWER? REPLY) NIL)
(T
(DISPLAY '|I don't follow.|)
(QUERY X)))))
(DEFUN PRINTC (X WHERE) (TERPRI WHERE) (PRINC X WHERE))
(DEFUN DELIMITER? (X) (MEMQ X '(/. /? /! // || /, /-)))
(DEFUN NON-DELIMITER? (X) (NOT (DELIMITER? X)))
(DEFUN OPEN-QUOTE-MARKS? (X) (MEMQ X '(/" |``|)))
(DEFUN CLOSE-QUOTE-MARKS? (X) (MEMQ X '(/" |''|)))
(DEFUN END-OF-SENTENCE? (X) (MEMQ X '(/. /? /!)))
(DEFUN DISPLAY-VERSION ()
(CURSORPOS 'A TYO)
(PRINC '|Animal II (Version | TYO)
(PRINC (VERSION) TYO)
(PRINC '|)| TYO)
(TERPRI TYO))
(DEFUN DISPLAY1 (X SPACE-FLAG CASE-FLAG WHERE)
(COND (SPACE-FLAG
(COND ((< (CHARPOS WHERE) *FILL-COLUMN*) (TYO #\SPACE WHERE))
(T (TERPRI WHERE)))))
(COND ((ATOM X)
(LET ((ALIAS (DISPLAY-ALIAS X)))
(COND (ALIAS (DISPLAY1 ALIAS NIL CASE-FLAG WHERE))
(T
(PRINC (COND ((EQ X 'I) 'I)
(CASE-FLAG (CAPITALIZE X))
((PERSON-NAME? X) (CAPITALIZE X))
(T (LOWERCASIFY X)))
WHERE)))))
(T
(DO ((SFLAG NIL T)
(CFLAG CASE-FLAG (COND ((END-OF-SENTENCE? (CAR L)) T)
(T NIL)))
(L X (CDR L)))
((NULL L))
(COND ((DELIMITER? (CAR L))
(SETQ SFLAG NIL)))
(DISPLAY1 (CAR L) SFLAG CFLAG WHERE)))))
(DEFUN DISPLAY-ALIAS (X)
(AND (SYMBOLP X)
(SELECT-ONE-OF (GET X 'DISPLAY-ALTERNATIVES))))
(DEFUN SELECT-ONE-OF (X)
(COND ((NULL X) NIL)
(T (NTH (RANDOM (LENGTH X)) X))))
(DEFUN SEND-MAIL (HEADER-INFO TEXT)
(LET ((TERPRI T))
(IOTA ((OUTSTREAM '|.MAIL.;MAIL >| 'OUT))
(PRINC '|From-Job:Animal II, Version | OUTSTREAM)
(PRINC (VERSION) OUTSTREAM)
(PRINTC '|Sent-By:ANIMAL| OUTSTREAM)
(PRINTC '|Header-Force:RFC733| OUTSTREAM)
(MAPC #'(LAMBDA (X)
(COND ((MEMQ (CAR X) '(TO: CC:))
(TERPRI OUTSTREAM)
(ADDRESSEE-PRINC (CAR X)
(CDR X)
OUTSTREAM))
(T
(PRINTC (CAR X) OUTSTREAM)
(DISPLAY1 (CDR X) NIL T OUTSTREAM))))
HEADER-INFO)
(PRINTC '|Text;-1| OUTSTREAM)
(TERPRI OUTSTREAM)
(DISPLAY TEXT OUTSTREAM))))
(DEFUN ADDRESSEE-PRINC (TYPE X STREAM)
(LET ((MODES (CDR (ASSQ TYPE '((CC: (R-OPTION CC)))))))
(MAPCAR #'(LAMBDA (X)
(TERPRI STREAM)
(PRINC '|TO:| STREAM)
(PRINC (CONS X MODES) STREAM))
X)))
(DEFUN REMEMBER (X)
(CREATEF (MERGEF `(,(STATUS USERID) ,X) *MEMORY-AREA*)))
(DEFUN REMEMBER? (X)
(PROBEF (MERGEF `(,(STATUS USERID) ,X) *MEMORY-AREA*)))
(DEFUN FORGET (X)
(SLEEP 3.0) ;Sigh. Make sure archive device has enough time to get closed
(DELETEF (MERGEF `(,(STATUS USERID) ,X) *MEMORY-AREA*)))
(DEFUN FORGIVE (X TEXT)
(COND ((REMEMBER? X)
(FORGET X)
(SEND-MAIL `((TO: KMP)
(CC: ,(STATUS USERID))
(SUBJECT: (,(CONCAT *PLAYER-NAME* '|'s|)
"foul language!")))
`("I have decided to forgive" ,*FIRST-NAME*
"for" ,TEXT ".")))))
(DEFUN FRESHLINE (WHERE)
(COND ((NOT (= (CHARPOS WHERE) 0.))
(TERPRI WHERE))))
(DEFUN DISPLAY (X &OPTIONAL (WHERE TYO))
(SETQ *DISPLAY* (COND ((ATOM X) (NCONS X)) (T X)))
(FRESHLINE WHERE)
(DISPLAY1 X NIL T WHERE)
(PRINC '| | WHERE))
(DEFUN SLOW-PRINC (X)
(MAPCAR (FUNCTION (LAMBDA (C) (TYO C TYO) (SLEEP .15)))
(EXPLODEN X))
T)
(COMMENT Main Program Stuff)
(DEFUN ANIMAL ()
(*CATCH 'ANIMAL-SUICIDE
(PROGN (DISPLAY-VERSION)
(OFFER-INSTRUCTIONS)
(DO ((AGAIN (PLAY-AND-OFFER-NEW-ROUND)
(PLAY-AND-OFFER-NEW-ROUND)))
((NOT AGAIN) (SUICIDE))))))
(DEFUN OFFER-INSTRUCTIONS ()
(COND ((QUERY '"Do you want instructions?")
(PRINTF *INSTRUCTION-FILE* TYO))))
(DEFUN ABORT-ROUND-IF-NULL-ANSWER (X)
(COND ((NULL-ANSWER? X)
(DISPLAY '"Oh, well. Thanks anyway.")
(ABORT-ROUND))))
(DEFUN PLAY-AND-OFFER-NEW-ROUND ()
(CATCH-ROUND-EXIT (GUESS-HIS-ANIMAL))
(DISPLAY '"Thanks for the game.")
(QUERY '"Another game?"))
(DEFUN INIT-MEMORY () *MEMORY*)
(DEFUN GUESS-HIS-ANIMAL ()
(LET ((MEMORY (INIT-MEMORY))
(RESULT NIL))
(COND ((SETQ RESULT (FAIL-TO-GUESS? MEMORY))
(LEARN RESULT)
(COND (*SAVE-FILE* (SAVE *SAVE-FILE*)))))))
(DEFUN FAIL-TO-GUESS? (*CURRENT-NODE*)
(COND ((TERMINAL-NODE? *CURRENT-NODE*)
(LET ((*OLD* *CURRENT-NODE*))
(FINALLY-GUESS *OLD*)))
((QUERY (LIST (EXTRACT-QUESTION *CURRENT-NODE*) '?))
(FAIL-TO-GUESS? (EXTRACT-YES-BRANCH *CURRENT-NODE*)))
(T
(FAIL-TO-GUESS? (EXTRACT-NO-BRANCH *CURRENT-NODE*)))))
(DEFUN FINALLY-GUESS (X)
(LET ((GUESS (EXTRACT-TERMINAL X)))
(COND ((QUERY `("I bet it's" ,(@ GUESS) ,GUESS ?)) NIL)
(T X))))
(DEFUN LEARN (X)
(DISPLAY '(WHAT ANIMAL WERE YOU THINKING OF ?))
(LET ((NEW-ANIMAL (READ-NOUN)))
(ABORT-ROUND-IF-NULL-ANSWER NEW-ANIMAL)
(COND ((EQ NEW-ANIMAL (EXTRACT-TERMINAL X))
(OUTPUT-BIND
(DISPLAY
'|That's what I just guessed. Stop fooling around.|))
(ABORT-ROUND)))
(DISPLAY `(WHAT DISTINGUISHES ,(@ NEW-ANIMAL) ,NEW-ANIMAL FROM
,(@ (EXTRACT-TERMINAL X)) ,(EXTRACT-TERMINAL X) ?))
(LET ((NEW-QUESTION)
(OLD-NODE (COPY-NODE X))
(NEW-NODE (CONSTRUCT-TERMINAL NEW-ANIMAL *PLAYER-NAME*)))
(LET ((*NEW* NEW-NODE) (*OLD* OLD-NODE))
(DO ((N (READ-SENTENCE) (READ-SENTENCE)))
((NOT (HANDLE-RANDOMNESS N))
(SETQ NEW-QUESTION N))))
(DISPLACE X (CONSTRUCT-QUESTION
(MAKE-QUESTION OLD-NODE NEW-NODE NEW-QUESTION)
OLD-NODE
NEW-NODE
*PLAYER-NAME*)))))
(COMMENT Answer Types)
(DEFUN NO-ANSWER? (X)
(MATCHES X ((*) (?= NEGATIVE?) (*))))
;;; Bug: (YES-ANSWER? ...) on "Sure, why not?" returns NIL. --Cstacy 7/11/82
(DEFUN YES-ANSWER? (X)
(AND (NOT (MEMQ 'NOT X))
(OR (MATCHES X ((*) (?= AFFIRMATIVE?) (*)))
(MATCHES X ( (*= PREPOSITION?) SOME (?)) ; in some ways,
; respects, ...
; by some standards
( (*) OF COURSE (*) )
( (*) (*= PRONOUN?) (?= DOES?) )
( (*)
(*= PRONOUN?)
(*= ADVERB?)
(?= STATE-OF-BEING-VERB?) )))))
(DEFUN NULL-ANSWER? (A)
(COND ((MEMQ A '(NOTHING NONE NIL))
(DISPLAY '"OK, then. Just testing me, huh?")
T)
((ANIMAL-PRONOUN? A)
(DISPLAY '"Grumble. Let's try to be more specific in the
future, ok?")
T)
((MEMQ A '(|FORGET IT| |NEVER MIND| |SKIP IT|))
(DISPLAY '"OK, be that way!")
T)
((MEMQ A '(STOP QUIT DONE EXIT THROUGH BYE ABORT))
(DISPLAY '"All right, but I win this one...")
T)
((MEMQ A '(DOPPLEGANGER DOUBLE SAME TWIN IDENTICAL ALIAS))
(DISPLAY '"Well, then, *I* win!")
T)
((MEMQ A '(GOD JESUS CHRIST))
(DISPLAY `(,A "is not an animal! Better luck next game."))
T)
(T NIL)))
(DEFUN HANDLE-RANDOMNESS (REPLY)
(OR (QUESTION-HANDLE? REPLY)
(STATEMENT-HANDLE? REPLY)))
(DEFUN STATEMENT-HANDLE? (X)
(TRY-RULES-ONCE RANDOM-STATEMENTS X))
(DEFUN QUESTION-HANDLE? (X)
(OUTPUT-BIND
(COND ((QUESTION? X)
(COND ((TRY-RULES-ONCE QUESTIONS X))
(T
(DISPLAY '"Sorry, I don't understand your question.")))))
(QUESTION? X)))
(DEFUN QUESTION? (X)
(AND (OR (EQ (SENTENCE-TYPE? X) 'QUESTION)
(AND (INTERROGATIVE-WORD? (CAR X))
(CDR X)))
T))
(DEFUN FOUL-ANSWER? (X) (MATCHES X ((*) (?= FOUL?) (*))))
(DEFUN HANDLE-FOUL-LANGUAGE (()) ;REPLY
(OUTPUT-BIND
(DISPLAY
(CASEQ *FOUL-FLAG*
((0) '"Please watch your language.")
((1) '"Hey! Watch your tongue. I warned you before.")
((2) '"Will you watch it with the dirty talk? Thanks.")
(T '"Aw, come on. Stop talking so dirty...")))
(SETQ *FOUL-FLAG* T)
(SETQ *APOLOGY-FLAG* NIL)
(SETQ *FOUL-COUNT* (1+ *FOUL-COUNT*))
(COND ((> *FOUL-COUNT* *FOUL-COUNT-MAX*)
(SEND-MAIL `((TO: KMP)
(CC: ,(STATUS USERID))
(SUBJECT: (,(CONCAT *PLAYER-NAME* '|'s|)
"Foul language!")))
`(,*FIRST-NAME* "said terrible things to me.
I'm going to be pretty mad at"
,*PLAYER-OBJECT-PRONOUN* "until"
,*PLAYER-SUBJECT-PRONOUN* "apologizes."))
(REMEMBER 'FOUL)
(DISPLAY '"I give up. You're hopeless!")
(SUICIDE)))))
(DEFUN I-DONT-CARE-ANSWER? (X)
(MATCHES X
(YOU (*= MODIFIER?) (?= DOES?) NOT CARE (*))
(YOU (*= MODIFIER?) (?= DOES?) NOT (?= WANT?) TO (?= DECIDE?) (*))))
(DEFUN INDETERMINATE-ANSWER? (X)
(MATCHES X ( (*) NOT KNOW (*) )
( (*) NOT SURE (*) )
( (*) NOT REMEMBER (*) )
( (*) NOT (?= UNDERSTAND?) (*) )
( (*) NOT SURE (*) )
( (*) (?= MAYBE?) (*))))
(DEFUN QUIT-ANSWER? (X) (MEMQ 'QUIT X))
(COMMENT Special part-of-speech predicates)
(DEFUN INTERROGATIVE-WORD? (X)
(OR (VERB? X) (MEMQ X '(HOW WHAT WHEN WHERE WHY))))
(DEFUN STATE-OF-BEING-VERB? (X)
(LET ((PART-OF-SPEECH (PART-OF-SPEECH? X)))
(AND (NOT (ATOM PART-OF-SPEECH))
(MEMQ 'BEING-VERB PART-OF-SPEECH))))
(DEFUN *OLD*-CK? (X) (EQ X (EXTRACT-TERMINAL *OLD*)))
(DEFUN *NEW*-CK? (X) (OR (PRONOUN? X) (EQ X (EXTRACT-TERMINAL *NEW*))))
(COMMENT Clever A/An Hack)
;;; (@ <symbol>)
;;;
;;; This is a carefully devised technique for telling whether to say
;;; A, AN or nothing before a given noun or string of words ...
;;; Returns A, AN or || ...
(DEFUN @ (@-X)
(LET ((EXPLODED
(EXPLODEC (CAR (SETQ @-X (PARSE-INPUT (EXPLODEC @-X)))))))
(COND ((OR (= (LENGTH EXPLODED) 1.)
(APPLY 'OR (MAPCAR 'DIGIT? EXPLODED)))
(COND ((MEMQ (CAR EXPLODED) '(F H L M N S X)) 'AN)
(T 'A)))
((AND (MEMQ 'THE @-X)
(DO ((L @-X (CDR L)))
((NULL L) T)
(COND ((PREPOSITION? (CAR L)) (RETURN NIL)))))
'||)
((MEMQ (CAR @-X) '(MIT $MAKE-COMPILER-HAPPY$)) 'AN)
((OR (MEMQ (CAR EXPLODED)
'(B C D F G H J K L M N P Q R S T V W X Y Z))
(AND (EQ (CAR EXPLODED) 'E)
(EQ (CADR EXPLODED) 'U))
(MEMQ (CAR @-X) '(UNICORN UNIQUE UNICYCLE)))
'A)
(T 'AN))))
(COMMENT Making a Question)
(DEFUN MAKE-QUESTION (*OLD* *NEW* SENTENCE)
(COND ((TRY-RULES-ONCE INTERPRETATIONS
(TRY-RULES TRANSFORMATIONS
(TRY-RULES EXITS SENTENCE))))
(T
(OUTPUT-BIND (DISPLAY '"Sorry. I don't understand. Try again."))
(MAKE-QUESTION *OLD* *NEW* (READ-SENTENCE)))))
;; Person says he wants to quit, or doesn't know
;; what's going on, or otherwise seems lost -- Abort round.
(DEF-EXIT APATHY (X) ()
IF (MATCHES X ((?= FORGET?) IT)
(NOTHING)
(NONE)
(NEVER MIND)
((*)
(?= *NEW*-CK?)
(*)
(?= STATE-OF-BEING-VERB?)
NOTHING))
(INDETERMINATE-ANSWER? X)
(QUIT-ANSWER? X)
THEN (DISPLAY '"Well, all right. I guess I win...")
(ABORT-ROUND))
;; New animal means same as old animal? Abort round -- no new
;; animal to be learned.
(DEF-EXIT SAME-MEANING (X) ()
IF (MATCHES X
((*= MODIFIER? )
(?= ANIMAL-PRONOUN? )
MEANS
(*= MODIFIER? )
SAME
(*= COMPARATOR? )
(*= MODIFIER? )
(?= *NEW*-CK? )
(* ))
((*= MODIFIER? )
(?= ANIMAL-PRONOUN? )
(?= STATE-OF-BEING-VERB? )
(*= MODIFIER? )
SAME
(?= COMPARATOR? )
(*= MODIFIER? )
(?= *NEW*-CK? )
(* )))
THEN (DISPLAY '"If it means the same, then you shouldn't have
told me I hadn't guessed it.")
(ABORT-ROUND))
;; We do lousy with AND'd traits, so just give up if we see
;; that word lying around...
(DEF-TRANSFORM MULTI (X) ()
IF (MATCHES X ((*) AND (*)))
THEN (OUTPUT-BIND (DISPLAY '"Please, just tell me one of its traits."))
(READ-SENTENCE))
;; Strip leading interjections, delimiters, etc. and reparse.
(DEF-TRANSFORM STRIP-INTERJECTIONS (X) (FOO BAR)
IF (MATCHES X
((?= INTERJECTION? )
(*= DELIMITER? )
(?= NON-DELIMITER? FOO )
(* BAR )))
THEN (CONS FOO BAR))
;; Simplify DO/DOES+<verb>
(DEF-TRANSFORM DOES+VERB (X) (FOO BAR VERB)
IF (MATCHES X ((* FOO) DOES (?= VERB? VERB) (* BAR)))
THEN (APPEND FOO (NCONS (VERB-SING? VERB)) BAR))
(DEF-TRANSFORM DO+VERB (X) (FOO BAR VERB)
IF (MATCHES X ((* FOO) DO (?= VERB? VERB) (* BAR)))
THEN (APPEND FOO (NCONS (VERB-PLURAL? VERB)) BAR))
;; Remove redundant negations
(DEF-TRANSFORM NOTNOT (X) (FOO BAR)
IF (MATCHES X ((* FOO) NOT NOT (* BAR)))
THEN (APPEND FOO BAR))
;; New animal is a superclass of the old animal.
;; Swap the two animals and reparse (so that the new
;; 'new animal' will be a subclass and can share rules
;; with the other case (see next clause)).
(DEF-TRANSFORM SUPERCLASS (X) ()
IF (MATCHES X
((*= MODIFIER? )
(?= *NEW*-CK? )
(?= STATE-OF-BEING-VERB? )
(*= MODIFIER? )
(?= OKA? )
OF
(*= MODIFIER? )
(?= *OLD*-CK? ))
((*= MODIFIER? )
(?= *OLD*-CK? )
(?= STATE-OF-BEING-VERB? )
(*= MODIFIER? )
(?= AKO? )
OF
(*= MODIFIER? )
(?= *NEW*-CK? )))
THEN (SWAP *OLD* *NEW*)
(TRANSFORM$SUBCLASS `(IT IS A KIND OF ,(EXTRACT-TERMINAL *OLD*))))
;; New animal is a kind of the old animal. Try to create
;; a balanced tree by finding another animal that's a subclass
;; of the old animal, and making them each hang off of one
;; side of the superclass. If the guy can only name one subclass
;; of this animal, then get snotty -- we only want proper
;; subclasses.
(DEF-TRANSFORM SUBCLASS (X) ()
IF (MATCHES X
((*= MODIFIER? )
(?= *NEW*-CK? )
(?= STATE-OF-BEING-VERB? )
(*= MODIFIER? )
(?= AKO? )
OF
(*= MODIFIER? )
(?= *OLD*-CK? ))
((*= MODIFIER? )
(?= *OLD*-CK? )
(?= STATE-OF-BEING-VERB? )
(*= MODIFIER? )
(?= OKA? )
OF
(*= MODIFIER? )
(?= *NEW*-CK? )))
THEN (DISPLAY `("What's another animal that's a kind of"
,(EXTRACT-TERMINAL *OLD*) ?))
(LET ((OTHER (READ-NOUN)))
(ABORT-ROUND-IF-NULL-ANSWER OTHER)
(DISPLACE *OLD* (CONSTRUCT-TERMINAL OTHER *PLAYER-NAME*))
(DISPLAY `("What distinguishes" ,(@ (EXTRACT-TERMINAL *NEW*))
,(EXTRACT-TERMINAL *NEW*)
"from" ,(@ OTHER) ,OTHER ?))
(READ-SENTENCE)))
;; If the guy just gives adjectives, he's probably implying
;; a verb as in "IT IS ..." Assume the implied pronoun is
;; the new animal and proceed.
(DEF-TRANSFORM MISSING-VERB (X) (MODS)
IF (MATCHES X ((*= MODIFIER? MODS)))
THEN `(IT IS ,@MODS))
;; Reject overly short answers that haven't been
;; recognized by this point.
(DEF-TRANSFORM INPUT-TOO-SHORT (X) ()
IF (< (LENGTH X) 2.)
THEN (OUTPUT-BIND (DISPLAY '"Please be more explicit..."))
(READ-SENTENCE))
;; Don't let a comparative adjective slip by without a comparator
(DEF-TRANSFORM MISSING-COMPARATOR (X) (ADJ)
IF (MATCHES X ((* )
(?= (LAMBDA (X) (OR (COMPARATIVE-ADJECTIVE? X)
(EQ X 'MORE))) ; Funny comparatives
ADJ)
(*= (LAMBDA (X) (NOT (COMPARATOR? X))) )))
THEN (OUTPUT-BIND
(DISPLAY `(,ADJ "than what?"))
(LET ((COMPLETION (READ-NOUN)))
`(,@X THAN ,(@ COMPLETION) ,COMPLETION))))
;; A <new-animal> IS <c-adjective> THAN <stuff>
;;
(DEF-INTERPRETATION COMPARATIVE-ADJECTIVE (X)
(VERB ADJ MAYBE-ADJECTIVE X1 NOUN X2) ; Locals
IF (MATCHES X
((*= MODIFIER? )
(*= *NEW*-CK? )
(?= VERB? VERB )
(?= COMPARATIVE-ADJECTIVE? ADJ )
(? MAYBE-ADJECTIVE )
THAN
(* X1 )
(?= NOUN? NOUN )
(* X2 )))
;; *** VERB should get looked at somewhere here
THEN (FUNCALL (COND ((NOUN? MAYBE-ADJECTIVE) 'HAS-POSSESSION)
(T 'HAS-STATE))
`(,ADJ ,MAYBE-ADJECTIVE THAN ,@X1 ,NOUN ,@X2)))
;; Input = A <new-animal> is NOT <description>
;; Reverse the roles, remove the negation, and reparse.
(DEF-TRANSFORM REMOVE-NEGATION (X) (FOO)
IF (MATCHES X
((*= MODIFIER? )
(?= ANIMAL-PRONOUN? )
(?= STATE-OF-BEING-VERB? )
NOT
(* FOO ))
((*= MODIFIER? )
(?= *NEW*-CK? )
(?= STATE-OF-BEING-VERB? )
NOT
(* FOO )))
THEN (SWAP *OLD* *NEW*)
`(IT IS ,@FOO))
;; Input= A <new-animal> IS <adjective> <more-description>
;; Assume the <more-description> all describes animal, and
;; attach it + the adjective as a general property.
(DEF-INTERPRETATION HAS-PROPERTY (X) (ADJ)
IF (MATCHES X
((*= MODIFIER? )
(?= *NEW*-CK? )
(?= STATE-OF-BEING-VERB? )
(?= ADJECTIVE? ADJ )
(* )))
THEN (HAS-PROPERTY ADJ))
;; Input= An <old-animal> IS <adjective> <more-description>
;; Swap the <old-animal> and <new-animal> and retry the
;; parse since we already have rules for this case for
;; <new-animal>.
(DEF-TRANSFORM OLD-IS (X) (ADJ FOO)
IF (MATCHES X
((*= MODIFIER? )
(?= *OLD*-CK? )
(?= STATE-OF-BEING-VERB? )
(?= ADJECTIVE? ADJ )
(* FOO )))
THEN (SWAP *OLD* *NEW*)
`(IT IS ,ADJ ,@FOO))
;; Input= IT HAS <modifiers> <noun>
;; Give <new-animal> a possession of <modifiers> <noun>
(DEF-INTERPRETATION HAS-POSSESSION (X) (MODS NOUN)
IF (MATCHES X
((*= MODIFIER? )
(?= ANIMAL-PRONOUN? )
(?= HAVE? )
(*= MODIFIER? MODS )
(?= NOUN? NOUN )))
THEN (HAS-POSSESSION `(,@MODS ,NOUN)))
;; Input= A <new-animal> <modal> NOT <something>
;; or
;; A <new-animal> DOES NOT <something>
;;
;; Assume that means that an <old-animal> does.
;; So swap the two names, and reparse without the NOT.
(DEF-TRANSFORM INVERTED-DESCRIPTION (X) (VERB GUNK)
IF (MATCHES X
((*= MODIFIER? )
(?= *NEW*-CK? )
(?= MODAL? )
NOT
(*= ADVERB? )
(? VERB )
(* GUNK ))
((*= MODIFIER? )
(?= *NEW*-CK? )
(?= DOES? )
NOT
(*= ADVERB? )
(? VERB )
(* GUNK )))
THEN (PART-OF-SPEECH VERB 'ACTION-VERB)
(SWAP *OLD* *NEW*)
`(IT ,(VERB-SING? VERB) ,@GUNK))
;; Input= An <old-animal> DOES NOT <something>
;;
;; Assume this means a <new-animal> does <something> and reparse.
(DEF-TRANSFORM OLD-ANIMAL-DOES-NOT (X) (VERB THING)
IF (MATCHES X
((*= MODIFIER? )
(?= *OLD*-CK? )
(?= DOES? )
NOT
(*= ADVERB? )
(? VERB )
(* THING )))
THEN (PART-OF-SPEECH VERB 'ACTION-VERB)
`(IT ,(VERB-SING? VERB) ,@THING))
;; Input= An <old-animal> <verb> NOT <something>
;;
(DEF-TRANSFORM OLD-ANIMAL-NEGATED-DESCRIPTION (X) (VERB BODY)
IF (MATCHES X
((*= MODIFIER? )
(?= *OLD*-CK? )
(? VERB )
NOT
(* BODY )))
;; *** This might want to check NO as well -- eg,
;; "A dog has no feet" or "A bird eats no wheat"
THEN `(IT ,VERB ,@BODY))
;; Input= A <new-animal> LIVES <where>
;;
;; Attach <where> as <new-animal>'s habitat.
(DEF-INTERPRETATION HABITAT (X) (WHERE)
IF (MATCHES X
((*= MODIFIER? )
(?= *NEW*-CK? )
(*= ADVERB? )
(?= STATE-OF-BEING-VERB? )
(?= LIVES? )
(* WHERE )))
THEN (HAS-HABITAT WHERE))
;; An <old-animal> LIVES <where>
;;
;; Swap old for new and reparse since there's a rule for
;; that case already.
(DEF-INTERPRETATION OLD-ANIMAL-LIVES (X) (WHERE)
IF (MATCHES X
((*= MODIFIER? )
(?= *OLD*-CK? )
(*= ADVERB? )
(?= STATE-OF-BEING-VERB? )
(?= LIVES? )
(* WHERE )))
THEN (SWAP *OLD* *NEW*)
(HAS-HABITAT WHERE))
(DEF-INTERPRETATION HAS-STATE (X) (DESCRIPTION)
IF (MATCHES X
((*= MODIFIER? )
(?= *NEW*-CK? )
(?= STATE-OF-BEING-VERB? )
(* DESCRIPTION )))
THEN (HAS-STATE DESCRIPTION))
(DEF-INTERPRETATION OLD-ANIMAL-HAS-STATE (X) (DESCRIPTION)
IF (MATCHES X
((*= MODIFIER? )
(?= *OLD*-CK? )
(?= STATE-OF-BEING-VERB? )
(* DESCRIPTION )))
THEN (SWAP *OLD* *NEW*)
(HAS-STATE DESCRIPTION))
(DEF-INTERPRETATION RANDOM-ACTION (X) (VERB OBJ)
IF (MATCHES X
((*= MODIFIER? )
(?= *NEW*-CK? )
(? VERB )
(* OBJ )))
THEN (HAS-ACTION `(,VERB ,@OBJ)))
(DEF-INTERPRETATION OLD-ANIMAL-RANDOM-ACTION (X) (VERB OBJ)
IF (MATCHES X
((*= MODIFIER? )
(?= *OLD*-CK? )
(? VERB )
(* OBJ )))
THEN (SWAP *OLD* *NEW*)
(HAS-ACTION `(,VERB ,@OBJ)))
(DEF-INTERPRETATION MAKES-NOISE (X) (NOISE)
IF (MATCHES X
((*= MODIFIER? )
(?= *NEW*-CK? )
(?= MAKE-NOISE? )
(?= OPEN-QUOTE-MARKS? )
(? NOISE )
(?= CLOSE-QUOTE-MARKS? ))
((*= MODIFIER? )
(?= *NEW*-CK? )
(?= MAKE-NOISE? )
(* NOISE )))
THEN (MAKES-NOISE NOISE))
;;; Look for personal pronouns and confirm them...
(DEF-TRANSFORM PRONOUN-CHECK (X) (FOO PRONOUN BAR)
IF (AND (MATCHES X ((* FOO) (?= PRONOUN? PRONOUN) (* BAR)))
(MEMQ PRONOUN '(HE SHE)))
THEN (LET ((FLAG (OUTPUT-BIND
(QUERY `("Does" ,PRONOUN "refer to"
,(EXTRACT-TERMINAL *NEW*) ?)))))
(COND ((NOT FLAG)
(OUTPUT-BIND (DISPLAY '"Then I don't understand ..."))
(READ-SENTENCE))
(T
`(,@FOO IT ,BAR)))))
(DEFUN MAKE-INTO-AFFIRMATIVE-STATEMENT (X)
(RPLACA X 'YES)
(RPLACD X NIL)
(SET-SENTENCE-TYPE X 'STATEMENT))
(DEF-QUESTION HOW-MANY (X) (DFLAG)
IF (MATCHES X ((*) HOW MANY ($= DISTINCT? DFLAG) (?= ANIMALS?) (*)))
THEN (OUTPUT-BIND
(LET ((*NOPOINT T) (BASE 10.))
(COND ((NOT DFLAG)
(LET ((N (COUNT-ANIMALS *MEMORY*)))
(DISPLAY (COND ((ZEROP N) '"None.")
((= N 1.) '"Only one.")
(T `("I know of" ,N "animals."))))))
(T
(LET ((N (LENGTH (LIST-DISTINCT-ANIMALS))))
(DISPLAY (COND ((ZEROP N) '"None.")
((= N 1.) '"Only one.")
(T `("I know of" ,N
"distinct animals."))))))))))
(DEF-QUESTION WHAT-ANIMALS (X) ()
IF (MATCHES X (WHAT (?= ANIMALS?) DO YOU (*)))
THEN (OUTPUT-BIND
(LET ((LIST-OF-ANIMALS (LIST-DISTINCT-ANIMALS))
(*NOPOINT T)
(BASE 10.))
(DISPLAY-ANIMAL-LIST LIST-OF-ANIMALS))))
(DEFUN DISPLAY-ANIMAL-LIST (ANIMAL-LIST)
(SETQ ANIMAL-LIST (SORT (APPEND ANIMAL-LIST ()) 'ALPHALESSP))
(COND ((NULL ANIMAL-LIST)
(DISPLAY '"I know of no animals!"))
((NOT (CDR ANIMAL-LIST))
(DISPLAY `("I only know of" ,(@ (CAR ANIMAL-LIST))
,(CAR ANIMAL-LIST) ".")))
(T
(LET ((TEMP (MAPCAR #'(LAMBDA (X) (LIST X '/,))
(NREVERSE ANIMAL-LIST))))
(RPLACD (CAR TEMP) NIL)
(RPLACD (CADR TEMP) (NCONS 'AND))
(PUSH (NCONS '/.) TEMP)
(SETQ TEMP (APPLY 'NCONC (NREVERSE TEMP)))
(SETQ TEMP (APPEND '"I know the following animals:" TEMP))
(DISPLAY TEMP)))))
(DEFUN ELIMINATE-REDUNDANCY (L)
(COND ((NULL L) NIL)
(T (CONS (CAR L)
(ELIMINATE-REDUNDANCY (DELETE (CAR L) (CDR L)))))))
(DEFUN LIST-DISTINCT-ANIMALS ()
(LET ((*LIST* ()))
(DECLARE (SPECIAL *LIST*))
(LIST-DISTINCT-ANIMALS-AUX *MEMORY*)
(ELIMINATE-REDUNDANCY *LIST*)))
(DEFUN LIST-DISTINCT-ANIMALS-AUX (X)
(DECLARE (SPECIAL *LIST*))
(COND ((TERMINAL-NODE? X) (PUSH (EXTRACT-TERMINAL X) *LIST*))
(T (LIST-DISTINCT-ANIMALS-AUX (EXTRACT-YES-BRANCH X))
(LIST-DISTINCT-ANIMALS-AUX (EXTRACT-NO-BRANCH X))))
T)
(DEFUN COUNT-ANIMALS (DATABASE)
(COND ((TERMINAL-NODE? DATABASE) 1.)
(T
(+ (COUNT-ANIMALS (EXTRACT-YES-BRANCH DATABASE))
(COUNT-ANIMALS (EXTRACT-NO-BRANCH DATABASE))))))
(DEF-QUESTION WHO-SAID (X) ()
IF (MATCHES X (WHO (*) (?= SAID?) (*)))
THEN (OUTPUT-BIND
(DISPLAY `(,(MAYBE-PRONOUNIFY (EXTRACT-AUTHOR *CURRENT-NODE*))
"said that."))))
(DEFUN MAYBE-PRONOUNIFY (NAME)
(COND ((EQ NAME *PLAYER-NAME*) 'YOU) (T NAME)))
(DEFUN MAYBE-UNPRONOUNIFY (NAME)
(COND ((EQ NAME 'I) *PLAYER-NAME*) (T NAME)))
(DEF-QUESTION DID-I-SAY (X) (NAME)
IF (MATCHES X (DID (? NAME) (?= SAID?) (*)))
THEN (OUTPUT-BIND
(LET ((AUTHOR (EXTRACT-AUTHOR *CURRENT-NODE*))
(NAME (MAYBE-UNPRONOUNIFY NAME)))
(COND ((EQ NAME AUTHOR) (DISPLAY '"Yes."))
(T (DISPLAY
`("No," ,(MAYBE-PRONOUNIFY AUTHOR) "said that.")))))))
(DEF-QUESTION MY-NAME (X) ()
IF (MATCHES X (WHAT IS MY NAME (*)) (WHAT DID YOU CALL ME))
THEN (OUTPUT-BIND
(DISPLAY `("Your full name is" ,*FULL-NAME*
"... I just call you" ,*NICK-NAME* "for short."))))
(DEF-QUESTION IS-GRASS-GREEN (X) ()
IF (MATCHES X (IS ($= DETERMINER?) GRASS GREEN))
THEN (TERPRI TYO)
(PRINC '|/Green,| TYO) (SLEEP .30)
(PRINC '|/ green,| TYO) (SLEEP .30)
(PRINC '|/ the| TYO) (SLEEP .15)
(PRINC '|/ grass| TYO) (SLEEP .15)
(PRINC '|/ is green...| TYO)
(TERPRI TYO) (SLEEP .50)
(PRINC '|/ On| TYO) (SLEEP .15)
(PRINC '|/ the| TYO) (SLEEP .15)
(PRINC '|/ far| TYO) (SLEEP .15)
(PRINC '|/ side| TYO) (SLEEP .15)
(PRINC '|/ of| TYO) (SLEEP .15)
(PRINC '|/ the| TYO) (SLEEP .3)
(PRINC '|/ hill...| TYO)
(MAKE-INTO-AFFIRMATIVE-STATEMENT X)
T)
(DEF-QUESTION IS-THE-POPE-<WORD> (X) ()
IF (MEMBER X '((IS THE POPE CATHOLIC)
(IS THE POPE POLISH)))
THEN (TERPRI TYO)
(PRINC '|(You may have faith in it!)| TYO)
(MAKE-INTO-AFFIRMATIVE-STATEMENT X)
T)
(DEF-QUESTION IS-THE-SKY-BLUE (X) ()
IF (MATCHES X (IS THE SKY BLUE))
THEN (TERPRI TYO)
(PRINC '|(When it isn't cloudy!)| TYO)
(MAKE-INTO-AFFIRMATIVE-STATEMENT X)
T)
(DEF-QUESTION LISP-TRUTHS (X) ()
IF (MATCHES X
(|(| NULL NIL |)|)
(|(| NOT NIL |)|))
THEN (PRINTC '|TTTTTTTTTTT| TYO)
(PRINTC '|T TTT T| TYO)
(PRINTC '| TTT | TYO)
(PRINTC '| TTT | TYO)
(PRINTC '| TTT | TYO)
(PRINTC '| TTTTT | TYO)
(TERPRI TYO)
(MAKE-INTO-AFFIRMATIVE-STATEMENT X)
T)
(DEF-QUESTION IS-WATER-WET (X) ()
IF (MATCHES X (IS WATER WET))
THEN (COND (*WATER-FLAG*
(TERPRI TYO)
(PRINC '|I guess i decided it was...| TYO))
(T
(PRINTC '|(An interesting philosophical question!)| TYO)
(SLEEP 1.)
(SLOW-PRINC '|... hmmm ...|)
(SLEEP 2.)
(PRINTC '| If a drop of water falls in a forest| TYO)
(SLOW-PRINC '| and|)
(PRINTC '| no one feels it before it evaporates| TYO)
(TERPRI TYO)
(SLOW-PRINC '|... thinking ...|)
(SLEEP 5.)
(SETQ *WATER-FLAG* T)
(PRINC '| Yeah, I guess it usually is thought| TYO)
(TERPRI TYO)
(PRINC '|of as such...| TYO)))
(MAKE-INTO-AFFIRMATIVE-STATEMENT X)
T)
(DEF-QUESTION IS-SNOW-WHITE (X) ()
IF (MATCHES X (IS SNOW WHITE))
THEN (TERPRI TYO)
(PRINC '|(Not in Boston, but most places it is!)| TYO)
(MAKE-INTO-AFFIRMATIVE-STATEMENT X)
T)
(DEF-QUESTION WHAT-TIME-IS-IT (X) ()
IF (MATCHES X (WHAT TIME IS IT))
THEN (DISPLAY `("It is now" ,(CLOCK-TIME) "."))
T)
(DEF-QUESTION APOLOGY (X) ()
IF (MATCHES X (WILL YOU (*) FORGIVE ME (*))
(WILL YOU (*) ACCEPT (*) (?= APOLOGY?) (*)))
THEN (RECEIVE-APOLOGY)
T)
(DEF-QUESTION WHEN-NEWS (X) ()
IF (MATCHES X (WHEN (*) NEWS (*)) (WHAT TIME (*) NEWS (*)))
THEN (DISPLAY-NEWS-DATE))
(DEF-STATEMENT NO-APOLOGY (X) ()
IF (MATCHES X ((*) (?= NOT?) (*) (?= APOLOGY?) (*)))
THEN (OUTPUT-BIND (DISPLAY '"Hmmmm...."))
T)
(DEF-STATEMENT MISTAKE (X) ()
IF (MATCHES X
((*) I (*) MADE (*) (?= MISTAKE?) (*))
((*) I (*) (?= SCREWED?) UP (*)))
THEN (OUTPUT-BIND
(DISPLAY '"Well, let's forget this round and start anew, then.")
(ABORT-ROUND)))
(CONTRACTION '(MIS-SPELLED MISSPELLED))
(CONTRACTION '(MIS-SPELED MISSPELLED))
(CONTRACTION '(MISPELLED MISSPELLED))
(CONTRACTION '(MISPELED MISSPELLED))
(CONTRACTION '(MISSPELED MISSPELLED))
(DEF-STATEMENT CORRECT-TYPO (X) (WHO WORD)
IF (MATCHES X
((? WHO) MISSPELLED (? WORD))
((? WORD) IS MISSPELLED (*))
((? WORD) IS SPELLED (?= WRONG?) (*)))
THEN (LET ((B1 (CORRECT-TYPO-IN-CODE WORD (LIST *OLD* *NEW*)))
(B2 (CORRECT-TYPO-IN-CODE WORD *DISPLAY*)))
(OUTPUT-BIND
(DISPLAY (COND ((OR B1 B2) '"Ok. I'll remember that.")
(T '"I don't see it ...")))))
T)
(DEF-STATEMENT TWO-WORDS (X) (WORD PHRASE)
IF (MATCHES X
((? WORD) SHOULD BE (*) TWO WORDS)
(THE WORD (? WORD) SHOULD BE (* PHRASE)))
THEN (*CATCH 'EXIT-TWO-WORDS
(COND
((EXPAND-WORDS-IN-CODE
WORD
(OR PHRASE
(OUTPUT-BIND
(DISPLAY '"What should it be?")
(LET ((PHRASE (READ-SENTENCE)))
(COND ((OR (NULL-ANSWER? PHRASE)
(QUIT-ANSWER? PHRASE)
(YES-ANSWER? PHRASE)
(NO-ANSWER? PHRASE))
(DISPLAY '"Oh, well...")
(*THROW 'EXIT-TWO-WORDS NIL))
(T PHRASE))))))
(OUTPUT-BIND (DISPLAY '"I'll remember that.")))
(T
(OUTPUT-BIND (DISPLAY '"I don't see it...")))))
T)
(DEFUN EXPAND-WORDS-IN-CODE (WORD PHRASE)
(*CATCH 'ABORT-CORRECTION
(LET ((WHERE (FIND-TYPO WORD *DISPLAY*)))
(COND (WHERE
(RPLACA WHERE PHRASE)
(COND (*SAVE-FILE* (SAVE *SAVE-FILE*)))))
T)))
(DEFUN CORRECT-TYPO-IN-CODE (X WHERE)
(*CATCH 'ABORT-CORRECTION
(LET ((TYPO (FIND-TYPO X WHERE)))
(COND (TYPO
(RPLACA TYPO X)
(COND (*SAVE-FILE* (SAVE *SAVE-FILE*)))))
T)))
(DECLARE (SPECIAL *TYPOS*))
(DEFUN FIND-TYPO (X WHERE)
(LET ((*TYPOS* NIL))
(FIND-TYPO-AUX X WHERE)
(SETQ *TYPOS* (SORTCAR *TYPOS* '>))
(COND ((AND *TYPOS* (> (CAAR *TYPOS*) 0.5))
(CDAR *TYPOS*))
(T
(*THROW 'ABORT-CORRECTION NIL)))))
(DEFUN FIND-TYPO-AUX (X Y)
(COND ((ATOM Y) NIL)
((ATOM (CAR Y))
(PUSH (CONS (TYPO-MATCH X (CAR Y)) Y) *TYPOS*)
(FIND-TYPO-AUX X (CDR Y)))
(T
(FIND-TYPO-AUX X (CAR Y))
(FIND-TYPO-AUX X (CDR Y)))))
(DEFUN GET-CHARN (X I FLAT)
(COND ((OR (< I 1) (> I FLAT)) -1.)
(T (GETCHARN X I))))
(DEFUN TYPO-MATCH (X Y)
(LET* ((FACTOR 0.0)
(RATING 0.0)
(XEND (FLATC X))
(YEND (FLATC Y))
(QTY (//$ 1.0 (FLOAT (MIN XEND YEND)))))
(SETQ FACTOR
(-$ 1.0 (//$ (ABS (FLOAT (- XEND YEND)))
(FLOAT (MAX XEND YEND)))))
(DO ((I 1. (1+ I)) (YC))
((OR (> I XEND) (> I YEND)))
(COND ((= (GETCHARN X I) (SETQ YC (GETCHARN Y I)))
(SETQ RATING (+$ RATING QTY)))
((OR (= (GET-CHARN X (1- I) XEND) YC)
(= (GET-CHARN X (1+ I) XEND) YC))
(SETQ RATING (+$ (*$ QTY 0.6) RATING)))
((OR (= (GET-CHARN X (- I 2) XEND) YC)
(= (GET-CHARN X (+ I 2) XEND) YC))
(SETQ RATING (+$ (*$ QTY 0.3) RATING)))))
(*$ FACTOR RATING)))
(DEFUN INTERJECTION-ONLY? (X)
(AND (NOT (AFFIRMATIVE? X))
(NOT (NEGATIVE? X))
(INTERJECTION? X)))
(DEF-STATEMENT INTERJECTION-ONLY (X) ()
IF (MATCHES X ((?= INTERJECTION-ONLY?) (*= INTERJECTION-ONLY?)))
THEN (OUTPUT-BIND (DISPLAY '|Yup. That's life...|))
T)
(DEF-QUESTION MAD (X) ()
IF (MATCHES X (ARE YOU (*) (?= ANGRY?) (?= PREPOSITION?) ME (*))
(ARE YOU (*) (?= ANGRY?)))
THEN (COND (*FOUL-FLAG*
(COND (*FORGIVE-FLAG*
(COND (*APOLOGY-FLAG*
(DISPLAY '"Yes, I am still a bit mad."))
(T
(DISPLAY '"Yes, I am very mad. Your
language has really been in the
gutter today."))))
(T
(DISPLAY '"Yes. Your language has been atrocious."))))
(*FORGIVE-FLAG*
(DISPLAY '"No, but I was earlier!"))
(*APOLOGY-FLAG*
(DISPLAY '"You should really see someone about this. No,
I'm really not mad at you. I wish you'd stop
apologizing for nothing..."))
(T
(DISPLAY '"I have nothing to be mad at you for.")))
T)
(DEFUN NOT? (X) (EQ X 'NOT))
(DEFUN NOTNOT? (X) (NOT (EQ X 'NOT)))
(DEF-STATEMENT APOLOGY (X) ()
IF (MATCHES X (I (*= NOTNOT?) (?= APOLOGY?) (*)))
THEN (OUTPUT-BIND (RECEIVE-APOLOGY))
T)
(DEFUN RECEIVE-APOLOGY ()
(COND ((AND (NOT *FOUL-FLAG*) (NOT *FORGIVE-FLAG*))
(COND ((NOT *APOLOGY-FLAG*)
(DISPLAY
(SELECT-ONE-OF '("I don't know why you are apologizing."
"You don't owe me an apology."))))
(T
(DISPLAY
(SELECT-ONE-OF '("All right! Stop apologizing."
"You got some sort of guilt complex?"
"Perhaps you should see a priest.")))))
(SETQ *APOLOGY-FLAG* T))
((NOT *FOUL-FLAG*)
(DISPLAY
(SELECT-ONE-OF '("I forgave you already!"
"Yes, yes. I forgave you!")))
(SETQ *APOLOGY-FLAG* T))
((NOT *FORGIVE-FLAG*)
(DISPLAY '"All right. I accept your apology...")
(SETQ *FOUL-FLAG* NIL)
(SETQ *FORGIVE-FLAG* T)
(FORGIVE 'FOUL '"using foul language"))
((NOT *APOLOGY-FLAG*)
(DISPLAY '"Sorry, I gave you your chance and you blew it.")
(SETQ *APOLOGY-FLAG* T))
(T
(DISPLAY
(SELECT-ONE-OF
'("OK. Since you're being so insistent. I accept
your apology"
"OK. That sounds sincere to me.")))
(SETQ *APOLOGY-FLAG* NIL)
(SETQ *FOUL-FLAG* NIL)
(SETQ *FORGIVE-FLAG* T)
(FORGIVE 'FOUL '"using foul language"))))
(COMMENT Meanings)
(DEFMACRO DEF-MEANING (MEANING &REST WORDS)
`(PROGN 'COMPILE
(DEFUN ,(CONCAT MEANING '?) (X)
(MEMQ ',MEANING (GET X 'MEANINGS)))
,@(MAPCAR #'(LAMBDA (WORD)
`(ADDPROP ',WORD ',MEANING 'MEANINGS))
WORDS)))
(DEF-MEANING DISTINCT
DISTINCT UNIQUE INDIVIDUAL SPECIFIC)
(DEF-MEANING SAID
TELL TOLD SAY SAID TEACH TAUGHT SHOW SHOWED)
(DEF-MEANING MISTAKE
MISTAKE ERROR)
(DEF-MEANING MALE
MALE GUY MAN BOY MASCULINE)
(DEF-MEANING FEMALE
FEMALE GAL WOMAN GIRL FEMININE)
(DEF-MEANING WRONG
WRONG INCORRECTLY BADLY POORLY)
(DEF-MEANING AKO ; A-Kind-Of (Subclass)
CLASS SUBCLASS KIND TYPE VARIETY SUBSET VARIATION MUTATION
SORT DESCENDENT BRANCH SPECIES BREED OFFSPRING CHILD BABY)
(DEF-MEANING OKA ; Opposite of AKO (Superclass)
ANCESTOR SUPERSET PARENT SUPERCLASS PREDECESSOR)
(DEF-MEANING SCREWED
SCREWED LOUSED MESSED BOTCHED)
(DEF-MEANING LIVES
LIVE LIVES FOUND LIVING)
(DEF-MEANING UNDERSTAND
UNDERSTAND FOLLOW SEE COMPREHEND)
(DEF-MEANING FORGET
SKIP FORGET)
(DEF-MEANING LEARN
LEARN FIND GET HEAR SEE)
(DEF-MEANING DOES
DO DID DOES)
(DEF-MEANING WANT
WISH WANT DESIRE CHOOSE)
(DEF-MEANING DECIDE
DECIDE CHOOSE PICK SAY ANSWER)
(DEF-MEANING MAKE-NOISE
SAID SAY SAYS GO GOES)
(DEF-MEANING ME
ME)
(DEF-MEANING HOST
TIP SITE HOST SYSTEM TERMINAL TTY CRT)
(DEF-MEANING WINNING
WINNING SMART GOOD)
(DEF-MEANING LOGGED
LOGGED LINKED ATTACHED)
(DEF-MEANING TAUGHT
TAUGHT TEACHES TEACH SAYS SAY SAID TELL TELLS
TOLD EXPLAINED EXPLAIN EXPLAINS SHOWED SHOW SHOWS)
(DEF-MEANING ERROR-WORD
MISTAKE TYPO TYPOS MISTAKES ERROR ERRORS GOOF GOOFS
PROBLEM PROBLEMS)
(DEF-MEANING KIDDING
KIDDING JOKING)
(DEF-MEANING HAVE
HAS HAD HAVE)
(DEF-MEANING MAYBE
MAYBE PERHAPS SOMETIMES OCCASIONALLY POSSIBLY)
(DEF-MEANING ANIMALS
ANIMALS BEASTS CREATURES)
(DEF-MEANING ANIMAL-PRONOUN
IT THEY ANIMAL BEAST CREATURE THAT THOSE THIS THESE THAT ONE)
(DEF-MEANING NEGATIVE
NO NEGATORY NAH BAD HUH-UH HUHUH UNTRUE SELDOM NOPE NOT
FALSE NEGATIVE NA NEVER NIL N)
(DEF-MEANING AFFIRMATIVE
YES SURE YEAH COOL FINE TRUE RIGH UHHUH YEP P T Y
ROGER YEA YA GOOD PROBABLY CORRECT HYPOTHETICALLY OK OKAY
UHHUH UHUH UH-HUH OUI DA PROCEED GREAT CONTINUE DO MORE ABSOLUTELY
UNQUESTIONABLY APPROXIMATELY MOSTLY PRACTICALLY DEFINITELY
CERTAINLY POSITIVELY SURELY AFFIRMATIVE)
(DEF-MEANING APOLOGY
SORRY APOLOGIZE APOLOGY APOLOGIES)
(DEF-MEANING ANGRY
ANGRY SORE ANNOYED MAD UPSET PISSED)
(DEF-MEANING FOUL
ANUS ANUSES ASSHOLE ASSHOLES
BASTARD BASTARDS BITCH BITCHES BOOB BOOBS
COCK COCKS COMMIE COMMIES CRAP CRAPPY CROTCH CROTCHES
CRUD CRUDDY CUNT CUNTS CUNILINGUS CUNNILINGUS
DAMN DAMNED DAMMIT DICK DICKS DILDO DILDOS DILDOES DOPE DOPES
DUMMY DUMMIES DUMDUM DUMDUMS DUMBDUMB DUMBDUMBS
DUM-DUM DUM-DUMS DUMB-DUMB DUMB-DUMBS
FAG FAGS FAGGOT FAGGOTS FART FARTHEAD FARTS
FELLATIO FELATIO FORNICATE FORNICATES FORNICATED FORNICATING
FORNICATION FUCK FUCKS FUCKED FUCKED-UP FUCKING
FUCKER FUCKERS FUCKHEAD FUCKHEADS FUCKWAD FUCKWADS
GAY GAYS GODAM GODAMN GODAMNED GODDAM GODDAMN GODDAMNED
GOD-DAM GOD-DAMN GOD-DAMNED
HELL
KIKE
LICK LICKED LICKING
MOTHER-FUCKING MOTHERFUCKING MOTHERFUCKER MOTHERFUCKERS
MOTHER-FUCKER MOTHER-FUCKERS
NIGGER
ORGASM ORGASMS ORGASMIC
PENIS PIMP PIMPS PIMPING PIMPED PINKO PINKOS PISS PISSES PISSHEAD
POLACK POLOCK POLOK POLLACK POLLOCK POLLOK PRICK PRICKS PROSTITUTE
PROSTITUTES PROSTITUTION PUSSY PUSSIES
QUEER
SCREW SCREWS SCREWED SCROD SCREWED SHIT SHITS SHITHEAD SHITHEADS
SIXTY-NINE SIXTYNINE /69 SOB SONOFABITCH SON-OF-A-BITCH
STUPID SUCK SUCKS SUX SUCKING SUCKED SUCKER SUCKERS
TIT TITS
WHORE WHORES WOP)
(COMMENT Display Definitions)
;;; Database constructors
(DEFMACRO DEF-CONCEPT (FORM &REST DISPLAY-FORMS)
`(PROGN 'COMPILE
(DEFUN ,FORM (X)
(COND ((ATOM X) (LIST ',FORM X))
(T (CONS ',FORM X))))
(DEFPROP ,FORM ,DISPLAY-FORMS DISPLAY-ALTERNATIVES)))
(DEF-CONCEPT MAKES-NOISE
"Does it say"
"Does it go"
"Does it make noises like")
(DEF-CONCEPT HAS-PROPERTY
"Is it"
"Would you say it is"
"Is your animal"
"Can it be described as")
(DEF-CONCEPT HAS-STATE
"Is your animal"
"Is it")
(DEF-CONCEPT ARE-YOU-THINKING-OF
"Are you thinking of"
"Were you thinking of"
"Is your animal"
"Is the animal you are thinking of")
(DEF-CONCEPT HAS-POSSESSION
"Does it have"
"Has it got"
"Does your animal have")
(DEF-CONCEPT HAS-ABILITY
"Can it"
"Does it have the ability to"
"Could it normally"
"Does your animal commonly")
(DEF-CONCEPT HAS-CLASSIFICATION
"Is it a kind of"
"Is your animal some type of"
"Is it some class of")
(DEF-CONCEPT HAS-ACTION
"Is it true that it"
"Could i say it"
"Would you say that it")
(DEF-CONCEPT HAS-HABITAT
"Is it found"
"Does it live"
"Is it at home"
"Is its habitat")
(COMMENT Saving and Restoring Database)
(DEFUN SAVE (FILENAME)
(IOTA ((OUTSTREAM (MERGEF '|_ANIM_ OUTPUT| FILENAME) '(OUT)))
(PRINT *MEMORY* OUTSTREAM)
(RENAMEF OUTSTREAM FILENAME)
(CLOSE OUTSTREAM)
'DONE))
(DEFUN UNSAVE (FILENAME)
(IOTA ((INSTREAM FILENAME '(IN)))
(SETQ *MEMORY* (READ INSTREAM))
'DONE))
(DEFUN DUMP (FILENAME)
(SSTATUS FLUSH T)
(GC)
(SSTATUS TOPLEVEL '(ANIMAL))
(NOINTERRUPT T)
(SUSPEND '|:KILL | FILENAME)
(SETUP-FOR-ANIMAL))
(DEFUN SETUP-FOR-ANIMAL ()
(COND ((NOT (SETUP-USERNAME-VARS))
(PRINC
'|Hey! You should run :INQUIR. I don't play with strangers.|
TYO)
(SUICIDE)))
(CLEAR-INPUT TYI)
(PRINTC '|Howdy, | TYO)
(PRINC (CAPITALIZE *NICK-NAME*) TYO)
(PRINC '|. Welcome to the ANIMAL game.| TYO)
(NOTES)
(LET ((INIT (PROBEF `((DSK ,(STATUS HSNAME)) ,(STATUS USERID) ANIMAL))))
(COND (INIT
(PRINTC '|Loadin' up your init.| TYO)
(LOAD INIT)
(PRINC '|.. All set.| TYO))))
(COND ((SETQ *FOUL-FLAG* (REMEMBER? 'FOUL))
(DISPLAY '"By the way -- we weren't
on good terms the last time we played.
I hope you have learned your lesson now.")))
(UNSAVE *SAVE-FILE*)
(NOTIFY-KMP)
(DISABLE-INTERRUPTS)
(NOINTERRUPT NIL)
(NEWS))
(DEFUN SETUP-USERNAME-VARS ()
(*CATCH 'EARLY-EXIT
(PROGN
(OPEN-INQUIR-FILE)
(LET ((((LAST FIRST MIDDLE) TITLE LINEAGE NIL NICKNAME)
;((LAST FIRST MIDDLE) TITLE LINEAGE ALIAS? NICKNAME)
(LET ((VAL (GET-USER-NAME (STATUS USERID))))
(COND ((NOT VAL) (*THROW 'EARLY-EXIT NIL)) (T VAL)))))
(SETQ *PLAYER-NAME* (STATUS USERID))
(SETQ *FULL-NAME* (CONCAT (CAPITALIZE FIRST) '| |
(CAPITALIZE LAST)))
(UPDATE-NAME-DATABASE FIRST MIDDLE LAST TITLE LINEAGE)
(SETQ *FIRST-NAME* FIRST)
(SETQ *NICK-NAME* (OR NICKNAME FIRST))
(SETQ *LAST-NAME* LAST))
(CLOSE-INQUIR-FILE)
T)))
(DEFUN UPDATE-NAME-DATABASE (FIRST MIDDLE () () ()) ; Last Title Lineage
(LET ((FIRST (UPPERCASIFY FIRST))
(MIDDLE (UPPERCASIFY MIDDLE)))
(COND ((REMEMBER? 'MALE) (PLAYER-IS-MALE))
((REMEMBER? 'FEMALE) (PLAYER-IS-FEMALE))
((NOT (PERSON-NAME? (UPPERCASIFY FIRST)))
(COND ((PERSON-NAME? MIDDLE)
(COND ((MALE-NAME? MIDDLE)
(PLAYER-IS-MALE))
(T
(PLAYER-IS-FEMALE))))
(T
(ASK-SEX FIRST NIL))))
((AND (MALE-NAME? FIRST) (FEMALE-NAME? FIRST))
(COND ((PERSON-NAME? MIDDLE)
(COND ((MALE-NAME? MIDDLE)
(PLAYER-IS-MALE))
(T
(PLAYER-IS-FEMALE))))
(T
(ASK-SEX FIRST T))))
((MALE-NAME? FIRST) (PLAYER-IS-MALE))
((FEMALE-NAME? FIRST) (PLAYER-IS-FEMALE))
(T
(BUG '"My sex-determination algorithm fell through." T)
(PLAYER-IS-MALE) ; Highly chauvanistic but prevents
; more lossage later...
))))
(DEFUN BUG (TEXT RECOVERABLE?)
(OUTPUT-BIND
(DISPLAY '"Hang on, I seem to have a bug...")
(SEND-MAIL `((TO: KMP)
(CC: ,(STATUS USERID))
(SUBJECT: "A bug!"))
`("Ooops, I have a bug..." ,TEXT))
(COND (RECOVERABLE?
(DISPLAY '"Ok, all set. I sent KMP some mail about it."))
(T
(DISPLAY TEXT)
(DISPLAY '"Looks bad. I better quit. I sent KMP mail about
it but if you noticed anything odd about this
circumstance, maybe you could send him mail, too.
Thanks.")
(SUICIDE)))))
(DEFUN ASK-SEX (NAME AMBIGUITY)
(OUTPUT-BIND
(COND ((NOT AMBIGUITY)
(DISPLAY `("Gee, I've never met anyone with the name"
,NAME "before. I'm afraid that means I also don't
know if you are a guy or a girl... which are you?")))
(T
(DISPLAY `("Hey, I hate to ask this because you probably
get asked all the time, but a name like" ,NAME
"is kinda ambiguous... Are you a guy or a girl?"))))
(DO ((ANSWER (READ-SENTENCE) (READ-SENTENCE)))
(NIL)
(COND ((HANDLE-RANDOMNESS ANSWER))
((MATCHES ANSWER ((*) NOT (*) (?= FEMALE?) (*))
((*) (?= MALE?) (*)))
(REMEMBER 'MALE)
(PLAYER-IS-MALE)
(RETURN T))
((MATCHES ANSWER ((*) NOT (*) (?= MALE?) (*))
((*) (?= FEMALE?) (*)))
(REMEMBER 'FEMALE)
(PLAYER-IS-FEMALE)
(RETURN T))
((YES-ANSWER? ANSWER)
(DISPLAY '"Can you be more specific?"))
((NO-ANSWER? ANSWER)
(DISPLAY '"I find that hard to believe..."))
((INDETERMINATE-ANSWER? ANSWER)
(DISPLAY '"You can confide in me..."))
((I-DONT-CARE-ANSWER? ANSWER)
(DISPLAY '"Well, I care! Please tell me."))
((QUIT-ANSWER? ANSWER)
(DISPLAY '"Well, if you insist...")
(SUICIDE))
(T
(DISPLAY '"I don't follow.")))
(DISPLAY '"Are you male or female?"))))
(DEFUN PLAYER-IS-MALE ()
(SETQ *PLAYER-OBJECT-PRONOUN* 'HIM)
(SETQ *PLAYER-SUBJECT-PRONOUN* 'HE))
(DEFUN PLAYER-IS-FEMALE ()
(SETQ *PLAYER-OBJECT-PRONOUN* 'HER)
(SETQ *PLAYER-SUBJECT-PRONOUN* 'SHE))
(DEFUN DISABLE-INTERRUPTS ()
(COND ((NOT *DEBUG*)
(DO ((I 0. (1+ I)))
((= I 127.))
(SSTATUS TTYINT I NIL))
(SSTATUS TTYINT 7. 7.)
T)
(T NIL)))
;; Die quietly -- Lisp seems to do it wrong
(DECLARE (*EXPR QUIET-DEATH))
(LAP QUIET-DEATH SUBR)
(*LOGOU 1)
()
(DEFUN SUICIDE ()
(COND ((NOT *DEBUG*) (QUIET-DEATH))
(T
(SSTATUS TOPLEVEL NIL)
(LET ((ERRSET NIL))
(OR (ERRSET (*THROW 'ANIMAL-SUICIDE 'SUICIDE) NIL)
(^G))))))
(DEFUN NOTES ()
(COND ((PROBEF *NOTES-FILE*)
(DISPLAY '"Special notice...")
(PRINTF *NOTES-FILE* TYO))))
(DEFUN NEWS ()
(COND ((AND (PROBEF *NEWS-FILE*)
(PROGN (DISPLAY-NEWS-DATE)
(QUERY '"Read news?")))
(LET ((OLD-^S (STATUS TTYINT #/)))
(*CATCH 'FLUSH
(UNWIND-PROTECT
(PROGN
(SSTATUS TTYINT #/
#'(LAMBDA (() ()) (*THROW 'FLUSH T)))
(PRINTF *NEWS-FILE* TYO))
(SSTATUS TTYINT #/ OLD-^S))))
T)))
(DEFUN DISPLAY-NEWS-DATE ()
(LET ((*NOPOINT T) (BASE 10.) (FILE-INFO))
(IOTA ((INSTREAM *NEWS-FILE* 'IN))
(SETQ FILE-INFO ; 4th word has file credate info
(NTH 3. (SYSCALL 4. 'FILBLK INSTREAM))))
(CURSORPOS 'A TYO)
(PRINC '|News last updated | TYO)
(PRINC (LOAD-BYTE FILE-INFO 23. 4.) TYO) ;Month = 3.9 - 3.6
(PRINC '// TYO)
(PRINC (LOAD-BYTE FILE-INFO 18. 5.) TYO) ;Day = 3.5 - 3.1
(PRINC '// TYO)
(PRINC (LOAD-BYTE FILE-INFO 27. 7.) TYO) ;Year = 4.7 - 4.1
(PRINC '|.| TYO)))
(DEFUN NOTIFY-KMP ()
(COND ((EQ (STATUS USERID) 'KMP)
(SETQ *DEBUG* T) ; Enable debugging
(SETQ PRIN1 'PRIN2)) ; Special printer for debugging
((PROBEF '((USR *) KMP HACTRN))
(ERRSET (IOTA ((STREAM '((CLI *) KMP HACTRN) '(OUT)))
(PRINC '|/<2F>Message from The Animal Game at MIT-MC |
STREAM)
(PRINC (CLOCK-TIME) STREAM)
(PRINC '|]| STREAM)
(TERPRI STREAM)
(PRINC (STATUS UNAME) STREAM)
(PRINC '| is gonna play against me!| STREAM)
(TERPRI STREAM))
NIL))))
;;; Redefine PRIN1 to print out input forms nicer.
(DEFUN SPECIAL-PRIN1 (WHAT WHERE)
(COND ((NULL WHAT) (PRINC '|()| WHERE))
((ATOM WHAT) (PRIN1 WHAT))
((AND (HUNKP WHAT) (= (HUNKSIZE WHAT) 3.))
(PRINC '|{| WHERE)
(DISPLAY1 (CXR 2. WHAT) NIL T WHERE)
(PRINC '|: "| WHERE)
(DISPLAY1 (CONS (CAR WHAT) (CDR WHAT)) NIL T WHERE)
(PRINC '|"}| WHERE))
(T
(PRINC '|(| WHERE)
(DO ((L WHAT (CDR L)))
((ATOM L)
(COND ((NULL L) (PRINC '|)| WHERE))
(T (PRINC '|. | WHERE)
(PRINC L WHERE)
(PRINC '|)| WHERE))))
(SPECIAL-PRIN1 (CAR L) WHERE)
(COND ((CDR L) (PRINC '| | WHERE))))))
T)
(DEFUN PRIN2 (X &OPTIONAL (WHERE TYO))
(SPECIAL-PRIN1 X WHERE))
;;; Local Modes::
;;; Comment Column:60:
;;; Comment Begin:; :
;;; Comment Start:;:
Reference in New Issue View Git Blame Copy Permalink