github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-02-07 00:47:06 +00:00
Code Issues Releases Wiki Activity
Files
25bf412d761d27d8eeb8a4b16aa245cc77977997
PDP-10.its/src/games/doc.(init)
Eric Swenson 088ec2d6d9 Added NGAME and games invoked by it.
2018-05-20 12:49:09 -07:00

1540 lines
41 KiB
Common Lisp
Raw 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.
;;; -*- LISP -*-
(COMMENT)
(PROG2
(SETQ PRIN1 'PRINC)
'|/
The doctor will be ready in a sec... When he is ready,/
he will say so. Please end responses with/
a period./
Be patient!/
-The Doctor's Secretary/
|
((LAMBDA (FILE)
((LAMBDA (MSGFILES)
(LOAD '((LISP) LET FASL))
(LOAD '((LISP) DEFMAX FASL))) (NCONS FILE))
(CLOSE FILE))
(OPEN '((NUL *) * *) 'OUT))
(SSTATUS FEATURE NOLDMSG)
(CLEAR-INPUT TYI))
(PROGN
(SETQ PRIN1 NIL)
(SETQ GC-OVERFLOW '(LAMBDA (X) T))
(SSTATUS FEATURE NOLDMSG)
(*RSET T)
(NOUUO T)
(DEFAULTF '(_LISP_ >))
(SETQ LISPT-PROTECT T)
(CLOSE (PROG2 T INFILE (INPUSH -1.)))
(DECLARE (SPECIAL ERRLIST FOO EXIT *RSET LINEL AFFIRMATIVES NEGATIVES
MAYBES SMALL-LETTERS N THING CONTRACTIONS S-QUOTE OPEN-QUOTES
CLOSE-QUOTES SPACE COMMA PERIOD SEMICOLON EXCLAM
GUESS-X MEMORY KMPMODE A DEFAULTF WRITABLE LISPT-JNAME
OPEN-PAREND CLOSE-PAREND IN_FILE WRITE-PROTECT
DOTDOTDOT EXCLAM-3 COLON QMARK HYPHEN NEWLINE TAB))
(DEFUN WINNER ()
(MEMQ (STATUS UNAME)
'(TNP KMP RWK MRG JPG BKERNS JM BMT RZ EJS WAM CSTACY
PAULP FRAWLE BUD MIKE GLS HIC ELLEN RL KRD)))
(EVAL-WHEN (EVAL COMPILE)
(COND ((NOT (STATUS FEATURE IOTA))
(LOAD '((DSK LIBLSP) IOTA FASL)))))
(COND ((AND (NOT (EQ (STATUS USERID) 'KMP))
(PROBEF '((USR *) KMP HACTRN)))
(LET ((BASE 10.) (*NOPOINT T) ((HOUR MIN) (STATUS DAYTIME)))
(ERRSET
(IOTA ((STREAM '((CLI *) KMP HACTRN) '(OUT)))
(MAPC (FUNCTION (LAMBDA (X) (PRINC X STREAM)))
(LIST
'|/[Message from The Doctor Game at MIT-MC |
(COND ((ZEROP (\ HOUR 12.)) '|12|) (T (\ HOUR 12.)))
'/:
(COND ((< MIN 10.) (IMPLODE (LIST '/0 (+ MIN 48.))))
(T MIN))
(COND ((ZEROP (// HOUR 12.)) '|am|)
(T '|pm|))
'/] (ASCII 13.) (STATUS UNAME)
'| is gonna have a private chat with me. If you|
(ASCII 13.)
(ASCII 10.)
'|feel like a good laugh, you're welcome to watch.|
))
(TERPRI STREAM))
NIL))))
(SETQ MONOSYLLABLES
'|/
Your attitude at the end of the session was wholly unacceptable./
Please try to come back next time with a willingness to speak more/
freely. If you continue to refuse to talk openly, there is little/
I can do to help!/
|)
(DEFUN SUICIDE ()
(IOTA ((STREAM '|.MAIL.;MAIL >| '(OUT ASCII BLOCK DSK)))
(PRINC '|FROM-JOB:KMP's DOCTOR| STREAM)
(TERPRI STREAM)
(PRINC '|SENT-BY:DOCTOR| STREAM)
(TERPRI STREAM)
(PRINC '|TO:| STREAM)
(PRINC (LIST (STATUS UNAME) 'MC) STREAM)
(TERPRI STREAM)
(PRINC '|SUBJECT:Session of | STREAM)
(LET ((BASE 10.) (*NOPOINT T) (DATE (STATUS DATE)) (TIME))
(PRINC (CADR DATE) STREAM)
(PRINC '// STREAM)
(PRINC (CADDR DATE) STREAM)
(PRINC '// STREAM)
(PRINC (CAR DATE) STREAM)
(TERPRI STREAM)
(PRINC '|TEXT;-1| STREAM)
(TERPRI STREAM)
(PRINC '|Session lasted | STREAM)
(PRINC (FIX (SETQ TIME (//$ (-$ (TIME) INIT-TIME) 60.0)))
STREAM)
(PRINC '| minutes, so your bill is $| STREAM)
(DO ((L (EXPLODEN (*$ TIME 0.25)) (CDR L)))
((= (CAR L) 46.)
(TYO 46. STREAM)
(TYO (OR (CADR L) 48.) STREAM)
(TYO (OR (CADDR L) 48.) STREAM))
(TYO (CAR L) STREAM))
(TERPRI STREAM)
(TYO 9. STREAM)
(PRINC '| - The Doctor's Secretary| STREAM)
(TERPRI STREAM)
(TERPRI STREAM)
(COND (OBSERVATION-LIST
(TERPRI STREAM)
(PRINC '|PS. The doctor also had some comments he
asked me to convey to you:/
/
| STREAM)
(DO ((O OBSERVATION-LIST (CDR O)))
((NULL O))
(PRINC (CAR O) STREAM)
(TERPRI STREAM))))))
(QUIT))
(SETQ INIT-TIME (TIME))
(DEFUN WORKING-HOURS? ()
(AND (MEMQ (STATUS DOW) '(MONDAY TUESDAY WEDNESDAY THURSDAY FRIDAY))
(> (CAR (STATUS DAYTIME)) 8.)
(< (CAR (STATUS DAYTIME)) 20.)))
(COND ((AND (WORKING-HOURS?) (NOT (WINNER)))
(TERPRI TYO)
(PRINC '|This is not the time of day to be playing games!|)
(TERPRI TYO)
(PRINC '|Please come back later. This game is unavailable|)
(TERPRI TYO)
(PRINC '|during the hours of 9am-8pm Monday-Friday.|)
(QUIT)))
(SETQ LISPT-JNAME '|DOX|)
(SETQ BASE 10. IBASE 10. *NOPOINT T)
(DEFUN MAP-PROP (X Y Z)
(MAPCAR (FUNCTION (LAMBDA (X) (PUTPROP X Y Z)))
X))
(DEFUN UNIX-EVAL (X) (COND ((ATOM X)
(COND ((BOUNDP X) (EVAL X))
(T NIL)))
(T (EVAL X))))
(DEFUN WHILE FEXPR (X)
(COND ((UNIX-EVAL (CAR X)) NIL)
(T (MAPCAR 'UNIX-EVAL (CDR X))
(APPLY 'WHILE X))))
(DEFUN CVTA (X) (ASCII X))
(DEFUN CVTN (X) (CAR (EXPLODEN X)))
(DEFUN READCH () (ASCII (TYI)))
(DEFUN PEEKCH () (ASCII (TYIPEEK)))
(DEFUN MEANING (X) (GET X 'MEANING))
(DEFUN PUT-MEANING FEXPR (X)
(PUTPROP (CAR X) (UNIX-EVAL (CADR X)) 'MEANING))
(PUT-MEANING HOWDY 'HOWDY)
(PUT-MEANING HI 'HOWDY)
(PUT-MEANING GREETINGS 'HOWDY)
(PUT-MEANING HELLO 'HOWDY)
(PUT-MEANING PDP11 'MACH)
(PUT-MEANING COMPUTER 'MACH)
(PUT-MEANING UNIX 'MACH)
(PUT-MEANING MACHINE 'MACH)
(PUT-MEANING COMPUTERS 'MACH)
(PUT-MEANING MACHINES 'MACH)
(PUT-MEANING PDP11S 'MACH)
(PUT-MEANING FOO 'MACH)
(PUT-MEANING FOOBAR 'MACH)
(PUT-MEANING MULTICS 'MACH)
(PUT-MEANING MACSYMA 'MACH)
(PUT-MEANING TELETYPE 'MACH)
(PUT-MEANING LA36 'MACH)
(PUT-MEANING VT52 'MACH)
(PUT-MEANING ZORK 'MACH)
(PUT-MEANING TREK 'MACH)
(PUT-MEANING STARTREK 'MACH)
(PUT-MEANING ADVENT 'MACH)
(PUT-MEANING PDP 'MACH)
(PUT-MEANING DEC 'MACH)
(PUT-MEANING SHIT 'FOUL)
(PUT-MEANING BASTARD 'FOUL)
(PUT-MEANING DAMN 'FOUL)
(PUT-MEANING DAMNED 'FOUL)
(PUT-MEANING HELL 'FOUL)
(PUT-MEANING SUCK 'FOUL)
(PUT-MEANING SUCKING 'FOUL)
(PUT-MEANING SUX 'FOUL)
(PUT-MEANING ASS 'FOUL)
(PUT-MEANING WHORE 'FOUL)
(PUT-MEANING BITCH 'FOUL)
(PUT-MEANING ASSHOLE 'FOUL)
(PUT-MEANING SHRINK 'FOUL)
(PUT-MEANING POT 'TOKE)
(PUT-MEANING GRASS 'TOKE)
(PUT-MEANING WEED 'TOKE)
(PUT-MEANING MARIJUANA 'TOKE)
(PUT-MEANING ACAPULCO 'TOKE)
(PUT-MEANING COLUMBIAN 'TOKE)
(PUT-MEANING TOKIN 'TOKE)
(PUT-MEANING JOINT 'TOKE)
(PUT-MEANING TOKE 'TOKE)
(PUT-MEANING TOKING 'TOKE)
(PUT-MEANING TOKIN/' 'TOKE)
(PUT-MEANING PILLS 'DRUG)
(PUT-MEANING DOPE 'DRUG)
(PUT-MEANING ACID 'DRUG)
(PUT-MEANING LSD 'DRUG)
(PUT-MEANING SPEED 'DRUG)
(PUT-MEANING HEROINE 'DRUG)
(PUT-MEANING HASH 'DRUG)
(PUT-MEANING COCAINE 'DRUG)
(PUT-MEANING UPPERS 'DRUG)
(PUT-MEANING DOWNERS 'DRUG)
(PUT-MEANING LOVES 'LOVES)
(PUT-MEANING LOVE 'LOVE)
(PUT-MEANING HATES 'HATES)
(PUT-MEANING DISLIKES 'HATES)
(PUT-MEANING HATE 'HATE)
(PUT-MEANING DISLIKE 'HATE)
(PUT-MEANING STONED 'STATE)
(PUT-MEANING DRUNK 'STATE)
(PUT-MEANING DRUNKEN 'STATE)
(PUT-MEANING HIGH 'STATE)
(PUT-MEANING HORNY 'STATE)
(PUT-MEANING BLASTED 'STATE)
(PUT-MEANING HAPPY 'STATE)
(PUT-MEANING PARANOID 'STATE)
(PUT-MEANING WISH 'DESIRE)
(PUT-MEANING WANT 'DESIRE)
(PUT-MEANING DESIRE 'DESIRE)
(PUT-MEANING LIKE 'DESIRE)
(PUT-MEANING HOPE 'DESIRE)
(PUT-MEANING HOPES 'DESIRE)
(PUT-MEANING DESIRES 'DESIRE)
(PUT-MEANING WANTS 'DESIRE)
(PUT-MEANING DESIRES 'DESIRE)
(PUT-MEANING LIKES 'DESIRE)
(PUT-MEANING FRUSTRATED 'MOOD)
(PUT-MEANING DEPRESSED 'MOOD)
(PUT-MEANING ANNOYED 'MOOD)
(PUT-MEANING UPSET 'MOOD)
(PUT-MEANING UNHAPPY 'MOOD)
(PUT-MEANING EXCITED 'MOOD)
(PUT-MEANING WORRIED 'MOOD)
(PUT-MEANING LONELY 'MOOD)
(PUT-MEANING ANGRY 'MOOD)
(PUT-MEANING PISSED 'MOOD)
(PUT-MEANING JEALOUS 'MOOD)
(PUT-MEANING AFRAID 'FEAR)
(PUT-MEANING FEAR 'FEAR)
(PUT-MEANING SCARED 'FEAR)
(PUT-MEANING VIRGINITY 'SEXNOUN)
(PUT-MEANING COCK 'SEXNOUN)
(PUT-MEANING CUNT 'SEXNOUN)
(PUT-MEANING PROSTITUTE 'SEXNOUN)
(PUT-MEANING CONDOM 'SEXNOUN)
(PUT-MEANING SEX 'SEXNOUN)
(PUT-MEANING RAPES 'SEXNOUN)
(PUT-MEANING WIFE 'FAMILY)
(PUT-MEANING BROTHER 'FAMILY)
(PUT-MEANING SISTER 'FAMILY)
(PUT-MEANING FATHER 'FAMILY)
(PUT-MEANING MOTHER 'FAMILY)
(PUT-MEANING HUSBAND 'FAMILY)
(PUT-MEANING SIBLINGS 'FAMILY)
(PUT-MEANING GRANDMOTHER 'FAMILY)
(PUT-MEANING GRANDFATHER 'FAMILY)
(PUT-MEANING MATERNAL 'FAMILY)
(PUT-MEANING PATERNAL 'FAMILY)
(PUT-MEANING STAB 'DEATH)
(PUT-MEANING MURDER 'DEATH)
(PUT-MEANING MURDERS 'DEATH)
(PUT-MEANING SUICIDE 'DEATH)
(PUT-MEANING SUICIDES 'DEATH)
(PUT-MEANING KILL 'DEATH)
(PUT-MEANING KILLS 'DEATH)
(PUT-MEANING DIE 'DEATH)
(PUT-MEANING DIES 'DEATH)
(PUT-MEANING DEATH 'DEATH)
(PUT-MEANING DEATHS 'DEATH)
(PUT-MEANING PAIN 'SYMPTOMS)
(PUT-MEANING ACHE 'SYMPTOMS)
(PUT-MEANING FEVER 'SYMPTOMS)
(PUT-MEANING SORE 'SYMTOMS)
(PUT-MEANING ACHING 'SYMPTOMS)
(PUT-MEANING STOMACHACHE 'SYMPTOMS)
(PUT-MEANING HEADACHE 'SYMPTOMS)
(PUT-MEANING HURTS 'SYMPTOMS)
(PUT-MEANING DISEASE 'SYMPTOMS)
(PUT-MEANING VIRUS 'SYMPTOMS)
(PUT-MEANING VOMIT 'SYMPTOMS)
(PUT-MEANING VOMITING 'SYMPTOMS)
(PUT-MEANING BARF 'SYMPTOMS)
(PUT-MEANING TOOTHACHE 'SYMPTOMS)
(PUT-MEANING HURT 'SYMPTOMS)
(PUT-MEANING RUM 'ALCOHOL)
(PUT-MEANING GIN 'ALCOHOL)
(PUT-MEANING VODKA 'ALCOHOL)
(PUT-MEANING ALCOHOL 'ALCOHOL)
(PUT-MEANING BOURBON 'ALCOHOL)
(PUT-MEANING BEER 'ALCOHOL)
(PUT-MEANING WINE 'ALCOHOL)
(PUT-MEANING WHISKEY 'ALCOHOL)
(PUT-MEANING SCOTCH 'ALCOHOL)
(PUT-MEANING FUCK 'SEXVERB)
(PUT-MEANING SCREW 'SEXVERB)
(PUT-MEANING SCREWING 'SEXVERB)
(PUT-MEANING FUCKING 'SEXVERB)
(PUT-MEANING RAPE 'SEXVERB)
(PUT-MEANING KISS 'SEXVERB)
(PUT-MEANING KISSING 'SEXVERB)
(PUT-MEANING KISSES 'SEXVERB)
(PUT-MEANING SCREWS 'SEXVERB)
(PUT-MEANING FUCKS 'SEXVERB)
(PUT-MEANING BECAUSE 'CONJ)
(PUT-MEANING BUT 'CONJ)
(PUT-MEANING HOWEVER 'CONJ)
(PUT-MEANING BESIDES 'CONJ)
(PUT-MEANING ANYWAY 'CONJ)
(PUT-MEANING THAT 'CONJ)
(PUT-MEANING EXCEPT 'CONJ)
(PUT-MEANING WHY 'CONJ)
(PUT-MEANING HOW 'CONJ)
(PUT-MEANING UNTIL 'WHEN)
(PUT-MEANING WHEN 'WHEN)
(PUT-MEANING WHILE 'WHEN)
(PUT-MEANING SINCE 'WHEN)
(DEFUN KAR(X) (COND ((ATOM X) X)
(T (CAR X))))
(DEFUN KDR (X) (COND ((ATOM X) NIL)
(T (CDR X))))
(DEFUN CADR (X) (KAR (KDR X)))
(DEFUN CDDR (X) (KDR (KDR X)))
(DECLARE (SPECIAL TYPOS))
(SETQ TYPOS ())
(DEFUN TYPOS: FEXPR (X) (SETQ TYPOS (MAPCAR 'TYPOS-AUX X)))
(DEFUN TYPOS-AUX (X)
(PUTPROP (CAR X) (CADR X) 'CORRECTION)
(PUTPROP (CADR X) (CADDR X) 'EXPANSION)
(CAR X))
(DEFUN TYPOP (X) (MEMQ X TYPOS))
(DEFUN CORRECTION (X) (GET X 'CORRECTION))
(DEFUN EXPANSION (X) (GET X 'EXPANSION))
(TYPOS: (THEYLL THEY/'LL (THEY WILL))
(THEYRE THEY/'RE (THEY ARE))
(IM I/'M (YOU ARE))
(I7M I/'M (YOU ARE))
(ISA |IS A| (IS A))
(THIER THEIR (THEIR))
(DONT DON/'T (DO NOT))
(DON7T DON/'T (DO NOT))
(YOU7RE YOU/'RE (I AM))
(YOU7VE YOU/'VE (I HAVE))
(YOU7LL YOU/'LL (I WILL)))
(DEFUN WARN-TYPOS (X)
(CURSORPOS 'A TYO)
(PRINC '|WATCH YOUR SPELLING! YOU MIS-SPELLED | TYO)
(/"PRINC (CAR X))
(MAP (FUNCTION
(LAMBDA (X)
(COND ((NULL (CDR X)) (PRINC '|, AND |))
(T (PRINC '|, |)))
(COND ((> (CHARPOS TYO) 60.) (TERPRI TYO)))
(/"PRINC (CAR X))))
(CDR X))
(PRINC '/. TYO))
(DEFUN /"PRINC (X) (TYO 34. TYO) (PRINC X TYO) (TYO 34. TYO))
(DEFUN CORRECT-SPELLING (X)
(DO ((X X (CDR X))
(L ())
(TEMP)
(TYPO-LIST)
(CORREX-FLAG ()))
((NULL X)
(COND (CORREX-FLAG (WARN-TYPOS TYPO-LIST)))
(MAPCAN (FUNCTION (LAMBDA (X) (COND ((ATOM X) (NCONS X)) (T X))))
(NREVERSE L)))
(COND ((SETQ TEMP (TYPOP (CAR X)))
(SETQ CORREX-FLAG T)
(LET ((C (CORRECTION (CAR X))))
(PUSH (EXPANSION C) L)
(PUSH C TYPO-LIST)))
(T
(PUSH (CAR X) L)))))
(DEFUN SHORTEN (SENT)
(PROG (FOO TEMP)
(SETQ TEMP '(NIL BECAUSE BUT HOWEVER BESIDES ANYWAY UNTIL
WHILE THAT EXCEPT WHY HOW))
RECHK
(SETQ TEMP (KDR TEMP))
(COND ((NULL TEMP)
(RETURN NIL)))
(SETQ FOO (MEMQ (KAR TEMP) SENT))
(COND ((NOT FOO)(GO RECHK))
((LESSP (LENGTH FOO) 4)
(GO RECHK)))
(SETQ SENT FOO)
(FIXUP)
(RETURN T) ))
(DEFUN DEFINE (SENT FOUND)
(PROG ()
(SVO SENT FOUND 1 NIL)
(COND
((NOT (NOUNP SUBJ))
(RETURN NIL))
((PRONOUNP SUBJ)
(RETURN NIL))
((NULL SUBJ)
(RETURN NIL))
((NULL (MEANING OBJECT))
(RETURN NIL)))
(PUTPROP SUBJ (MEANING OBJECT) 'MEANING)
(RETURN T)))
(DEFUN DEFQ (SENT)
(PROG (TEMP)
(SETQ TEMP '(MEANS APPLIES MEAN REFERS REFER RELATED
SIMILAR DEFINED ASSOCIATED LINKED LIKE SAME))
FOO (COND ((MEMQ (KAR TEMP) SENT)
(PROGN
(SETQ FOUND (KAR TEMP))
(RETURN T)))
((NULL (KDR TEMP))
(RETURN NIL)))
(SETQ TEMP (KDR TEMP)) (GO FOO)))
(DEFUN DEF (X)
(PROGN
(TYPE (LIST 'THE 'WORD X 'MEANS (MEANING X) 'TO 'ME))
NIL))
(DEFUN FORGET () (PROG (TEMP)
(SETQ TEMP HISTORY)
(SETQ HISTORY NIL)
LOOP (COND ((NULL (KDR TEMP))(RETURN NIL)))
(SETQ HISTORY (CONS (KAR TEMP) HISTORY))
(SETQ TEMP (KDR TEMP))
(GO LOOP)))
(DEFUN QUERY (X)
(PROG (A)
TOP (TXTYPE (ASSM (LIST X 'WHAT?)))
(SETQ A (TXREAD))
LOOP (COND ((NULL A)
(GO TOP)))
(COND ((NOUNP (KAR A)) (RETURN (KAR A))))
(COND ((VERBP (KAR A)) (RETURN (BUILD (BUILD X '/ ) (KAR A)))))
(SETQ A (KDR A))
(GO LOOP)))
(DEFUN SUBJSEARCH (SENT KEY TYPE)
(PROG (FOO)
(SETQ FOO (- (INDEX SENT KEY) TYPE))
(WHILE (NOT (GREATERP FOO 0))
(SETQ SUBJ (PART SENT FOO))
(COND ((NOUNP SUBJ) (RETURN T)))
(SETQ FOO (SUB1 FOO)))
(SETQ SUBJ 'YOU) (RETURN NIL) ))
(DEFUN NOUNP (X)
(OR (PRONOUNP X)
(NOT (OR (VERBP X) (EQUAL X 'NOT) (PREPP X) (MODIFIERP X) )) ))
(DEFUN PRONOUNP (X) (MEMQ X '(I ME YOU HE HIM SHE HER IT WE US THEY THEM
THAT THOSE THIS THESE MYSELF YOURSELF HIMSELF HERSELF THINGS THING
ANYTHING SOMETHING EVERYTHING) ))
(MAP-PROP '(AM IS ARE WAS WERE HAS HAVE HAD DO DID
FIND TAKE GET HIT MOVE HIT HURT KILL EAT DRINK LAY OUGHT
DOES SHALL SHOULD WILL WOULD CAN COULD MAY MIGHT MUST BE
BEEN BEING GOING GOES WENT GO GONE REFER MEAN MEANS REFERS
ASSOCIATED APPLIES RELATED LINKED USE USING USED DEFINED USES
FEEL FEELS FELT THINK THINKS THOUGHT HATES DISLIKES
HATE DISLIKE LOVE LOVES LIKES WISH WANT DESIRE LIKE
RAPE KISS KISSING KISSES SCREWS FUCKS
HOPE DESIRES WANTS DESIRES FUCK SCREW SCREWING FUCKING)
'VERB
'SENTENCE-TYPE)
(DEFUN VERBP (X) (EQ (GET X 'SENTENCE-TYPE) 'VERB))
(DEFUN PLURAL (X)
(PROG (FOO)
(SETQ FOO (EXPLODE X))
(RETURN
(COND ((NOT (EQUAL (PART FOO (LENGTH FOO)) 'S))
(BUILD X 'S))
(T X)))))
(SETQ INTER
'((WELL/,)
(|HMMM... SO,|)
(SO)
(|...AND|)
(THEN)))
(SETQ CONTINUE
'((CONTINUE)
(PROCEED)
(GO ON)
(KEEP GOING) ))
(SETQ RELATION
'((YOUR RELATIONSHIP WITH)
(SOMETHING YOU REMEMBER ABOUT)
(YOUR FEELINGS TOWARD)
(SOME EXPERIENCES YOU HAVE HAD WITH)
(HOW YOU FEEL ABOUT)))
(DEFUN SETPREP (SENT KEY)
(PROG (FOO)
(SETQ FOO (MEMQ KEY SENT))
(COND ((PREPP (CADR FOO))(GETNOUN (CDDR FOO)))
(T 'SOMETHING)) ))
(DEFUN GETNOUN (X)
(COND ((NULL X)(SETQ OBJECT 'SOMETHING))
((ATOM X)(SETQ OBJECT X))
((EQ (LENGTH X) 1)
(SETQ OBJECT (COND
((NOUNP (SETQ OBJECT (KAR X))) OBJECT)
(T (QUERY OBJECT)))))
((EQ (KAR X) 'TO)
(BUILD 'TO/ (GETNOUN (KDR X))))
((PREPP (KAR X))
(GETNOUN (KDR X)))
((NOT (NOUNP (KAR X)))
(BUILD (BUILD (KAR (REPLACE (LIST (KAR X))
'(A (THIS)
SOME (THIS)
ONE (THAT))))
SPACE)
(GETNOUN (KDR X))))
(T (SETQ OBJECT (KAR X))) ))
(DEFUN MODIFIERP (X)
(MEMQ X '(THE A AN EVERY SOME ONE VERY OFTEN MY MUCH
LINKED YOUR HIS HER THEIR OUR ANY MANY RELATED
ALL SIMILAR SIMILAR ALWAYS ASSOCIATED GOOD BAD
UGLY PRETY BIG SMALL TOO REALLY MORE LESS ALSO)))
(DEFUN PREPP (X)
(MEMQ X '(OF IN ON WITH FROM FOR TO AT SAME AS LIKE ABOUT
BY BESIDE AROUND UNDER ABOVE THROUGH BENEATH
BEHIND OVER )))
(DEFUN REMEMBER (THING)
(COND ((NULL HISTORY)
(SETQ HISTORY (LIST THING)))
(T (SETQ HISTORY (APPEND HISTORY (LIST THING))))))
(SETQ FEARS '( (($ WHYSAY) YOU ARE ($ AFRAIDOF) (// FOUND)(// QMARK))
(YOU SEEM TERRIFIED BY (// FOUND)(// PERIOD))
(WHEN DID YOU FIRST FEEL ($ AFRAIDOF)(// FOUND)(// QMARK)) ))
(SETQ SURE '((SURE)(POSITIVE)(CERTAIN)))
(SETQ AFRAIDOF '( (AFRAID OF) (FRIGHTENED BY) (SCARED OF) ))
(SETQ AREYOU '( (ARE YOU)(HAVE YOU BEEN)(HAVE YOU BEEN) ))
(SETQ ISRELATED '( (HAS SOMETHING TO DO WITH)(IS RELATED TO)
(COULD BE THE REASON FOR) ))
(SETQ ARERELATED '((HAVE SOMETHING TO DO WITH)(ARE RELATED TO)
(COULD HAVE CAUSED)(COULD BE THE REASON FOR) ))
(SETQ MOODS '( (($ AREYOU)(// FOUND) OFTEN?)
(WHAT CAUSES YOU TO BE (// FOUND)(// QMARK))
(($ WHYSAY) YOU ARE (// FOUND)(// QMARK)) ))
(SETQ MAYBE
'((MAYBE)
(PERHAPS)
(POSSIBLY)))
(DEFUN TYPE (X)(TXTYPE (ASSM X)))
(DEFUN FIXUP ()
(SETQ SENT (RPLACD
(REPLACE (LIST (KAR SENT))
'(ME (I)
HIM (HE)
HER (SHE)
THEM (THEY)
OKAY (/)
WELL (/)
SIGH (/)
HMM (/)
HMMM (/)
HMMMM (/)
HMMMMM (/)
GEE (/)
SURE (/)
GREAT (/)
OH (/)
FINE (/)
OK (/)
NO (/)))
(KDR SENT))))
(SETQ WHATWHEN
'((WHAT HAPPENED WHEN)
(WHAT WOULD HAPPEN IF)))
(SETQ HELLO
'((HOW DO YOU DO?) (HELLO/.) (HOWDY!) (HELLO/.) (HI/.)))
(SETQ DRNK
'((DO YOU DRINK A LOT OF (// FOUND)(// QMARK))
(DO YOU GET DRUNK OFTEN?)
(($ DESCRIBE) YOUR DRINKING HABITS/.) ))
(SETQ DRUGS '( (DO YOU USE (// FOUND) OFTEN?)(($ AREYOU)
ADDICTED TO (// FOUND)(// QMARK))(DO YOU REALIZE THAT DRUGS CAN
BE VERY HARMFUL?)(($ MAYBE) YOU SHOULD TRY TO QUIT USING (// FOUND)
(// PERIOD)) ))
(SETQ WHYWANT '( (($ WHYSAY) (// SUBJ) MIGHT ($ WANT) (// OBJ)(// QMARK))
(WHEN DID (// SUBJ) FIRST ($ WANT) (// OBJ)(// QMARK))
(HAVE YOU EVER GOTTEN (// OBJ)(// QMARK)) ))
(SETQ WANT '( (WANT) (DESIRE) (WISH) (WANT) (HOPE) ))
(SETQ SHORTLST
'((CAN YOU ELABORATE ON THAT?)
(($ PLEASE) CONTINUE/.)
(GO ON/, DON/'T BE AFRAID/.)
(YOU/'RE BEING A BIT BRIEF/, ($ PLEASE) GO INTO DETAIL/.)
(CAN YOU BE MORE EXPLICIT?)
(($ PLEASE) YOU GO INTO MORE DETAIL?)
(YOU AREN/'T BEING VERY TALKATIVE TODAY!)
(WHY MUST YOU RESPOND SO BRIEFLY?)))
(SETQ FAMLST
'((TELL ME ($ SOMETHING) ABOUT (// OWNER) FAMILY (// PERIOD))
(YOU SEEM TO DWELL ON (// OWNER) FAMILY (// PERIOD))
(($ AREYOU) HUNG UP ON (// OWNER) FAMILY?)))
(SETQ HUHLST
'((($ WHYSAY)(// SENT)(// QMARK))
(IS IT BECAUSE OF ($ THINGS) THAT YOU SAY (// SENT)(// QMARK)) ))
(SETQ FEELINGS-ABOUT
'((FEELINGS ABOUT)
(APREHENSIONS TOWARD)
(THOUGHTS ON)
(EMOTIONS TOWARD)))
(SETQ RANDOM-ADJECTIVE
'((VIVID)
(EMOTIONALLY STIMULATING)
(RECENT)
(UNUSUAL)
(SHOCKING)
(EMBARRASSING)))
(SETQ WHYSAY
'((WHY DO YOU SAY)
(WHAT MAKES YOU BELIEVE)
(ARE YOU SURE THAT)
(WHAT MAKES YOU THINK) ))
(SETQ ISEE
'((I SEE /././.)
(YES/,)
(I UNDERSTAND/.)
(OH/.) ))
(SETQ PLEASE
'((PLEASE/,)
(I WOULD APPRECIATE IT IF YOU WOULD)
(PERHAPS YOU COULD)
(PLEASE/,)
(WOULD YOU PLEASE)
(COULD YOU)))
(SETQ SOMETHING
'((SOMETHING)
(MORE)
(HOW YOU FEEL)))
(SETQ THINGS
'((HANGUPS YOU HAVE)
(YOUR INHIBITIONS)
(SOME PROBLEMS IN YOUR CHILDHOOD)
(THE PEOPLE YOU HANG AROUND WITH)
(PROBLEMS AT SCHOOL)
(YOUR SEX LIFE)
(YOUR HANGUPS)
(SOME PROBLEMS AT HOME)))
(SETQ DESCRIBE
'((DESCRIBE)
(TELL ME ABOUT)
(DISCUSS)
(ELABORATE ON)))
(SETQ IBELIEVE
'((I BELIEVE) (I THINK) (I HAVE A FEELING) (IT SEEMS TO ME THAT)))
(SETQ PROBLEMS '( (PROBLEMS)
(INHIBITIONS)
(HANGUPS)
(ANXIETIES)
(FRUSTRATIONS) ))
(SETQ BOTHER
'((DOES IT BOTHER YOU THAT)
(ARE YOU ANNOYED THAT)
(DID YOU EVER REGRET)
(ARE YOU SATISFIED WITH THE FACT THAT)))
(SETQ MACHLST
'((YOU HAVE YOUR MIND ON (// FOUND)(// COMMA) IT SEEMS/.)
(YOU SHOULD TRY TAKING YOUR MIND OFF OF (// FOUND)(// PERIOD))
(ARE YOU A COMPUTER HACKER?)))
(SETQ QLIST
'((I/'LL ASK THE QUESTIONS/, IF YOU DON/'T MIND!)
(($ PLEASE) ALLOW ME TO DO THE QUESTIONING/.)
(($ PLEASE) TRY TO ANSWER THAT QUESTION YOURSELF/.)))
(SETQ ELIST
'((($ PLEASE) TRY TO CALM YOURSELF/.)
(YOU SEEM VERY EXCITED/. RELAX/. ($ PLEASE) ($ DESCRIBE) ($ THINGS))
(YOU/'RE BEING VERY EMOTIONAL/. CALM DOWN/.)))
(SETQ FOULLST
'((($ PLEASE) WATCH YOUR TONGUE!)
(($ PLEASE) AVOID SUCH UNWHOLESOME THOUGHTS)
(SUCH LEWDNESS IS NOT APPRECIATED/.)))
(SETQ DEATHLST
'((THIS IS NOT A HEALTHY WAY OF THINKING/.)
(($ BOTHER) YOU/, TOO/, MAY DIE SOMEDAY?)
(I AM WORRIED BY YOUR OBSSESSION WITH THIS TOPIC!)
(DID YOU WATCH A LOT OF CRIME AND VIOLENCE ON TELEVISION AS A CHILD?))
)
(SETQ SEXLST
'((($ AREYOU) ($ AFRAIDOF) SEX?)
(($ DESCRIBE)($ SOMETHING) ABOUT YOUR SEXUAL HISTORY/.)
(($ PLEASE)($ DESCRIBE) YOUR SEX LIFE/././.)
(($ DESCRIBE) YOUR ($ FEELINGS-ABOUT) YOUR SEXUAL PARTNER/.)
(($ DESCRIBE) YOUR MOST ($ RANDOM-ADJECTIVE) SEXUAL EXPERIENCE/.)
(($ AREYOU) SATISFIED WITH (// LOVER) /././.?)))
(SETQ NEGLST
'((WHY NOT?)
(($ BOTHER) I ASK THAT?)
(WHY NOT?)
(WHY NOT?)
(HOW COME?)
(($ BOTHER) I ASK THAT?)))
(SETQ BECLST '(
(IS IT BECAUSE (// SENT) THAT YOU CAME TO ME?)
(($ BOTHER)(// SENT)(// QMARK))
(WHEN DID YOU FIRST KNOW THAT (// SENT)(// QMARK))
(IS THE FACT THAT (// SENT) THE REAL REASON?)
(DOES THE FACT THAT (// SENT) EXPLAIN ANYTHING ELSE?)
(($ AREYOU)($ SURE)(// SENT)(// QMARK) ) ))
(SETQ SHORTBECLST '(
(($ BOTHER) I ASK YOU THAT?)
(THAT/'S NOT MUCH OF AN ANSWER!)
(($ INTER) WHY WON/'T YOU TALK ABOUT IT?)
(SPEAK UP!)
(($ AREYOU) ($ AFRAIDOF) TALKING ABOUT IT?)
(DON/'T BE ($ AFRAIDOF) ELABORATING/.)
(($ PLEASE) GO INTO MORE DETAIL/.)))
(SETQ THLST '(
(($ MAYBE)($ THINGS)($ ARERELATED) THIS/.)
(IS IT BECAUSE OF ($ THINGS) THAT YOU ARE GOING THRU ALL THIS?)
(HOW DO YOU RECONCILE ($ THINGS)(// QMARK) )
(($ MAYBE) THIS ($ ISRELATED)($ THINGS)(// QMARK)) ))
(SETQ REMLST '( (EARLIER YOU SAID ($ HISTORY)(// QMARK))
(YOU MENTIONED THAT ($ HISTORY)(// QMARK))
(($ WHYSAY)($ HISTORY)(// QMARK) ) ))
(SETQ TOKLST
'((IS THIS HOW YOU RELAX?)
(HOW LONG HAVE YOU BEEN SMOKING GRASS?)
(($ AREYOU) ($ AFRAIDOF) OF BEING DRAWN TO USING HARDER STUFF?)))
(SETQ STATES
'((DO YOU GET (// FOUND) OFTEN?)
(DO YOU ENJOY BEING (// FOUND)(// QMARK))
(HOW OFTEN ($ AREYOU)(// FOUND))
(WHEN WERE YOU LAST (// FOUND)(// QMARK))))
(SETQ REPLIST
'(I (YOU)
MY (YOUR)
ME (YOU)
YOU (ME)
YOUR (MY)
MINE (YOURS)
YOURS (MINE)
OUR (YOUR)
OURS (YOURS)
WE (YOU)
DUNNO (DO NOT KNOW)
YES (/)
NO/, (/)
YES/, (/)
YA (I)
WANNA (WANT TO)
GOTTA (HAVE TO)
GONNA (GOING TO)
NEVER (DOES NOT EVER)
DOESN/'T (DOES NOT)
DON/'T (DO NOT)
AREN/'T (ARE NOT)
ISN/'T (IS NOT)
WON/'T (WILL NOT)
CAN/'T (CANNOT)
HAVEN/'T (HAVE NOT)
I/'M (YOU ARE)
OURSELVES (YOURSELVES)
MYSELF (YOURSELF)
YOURSELF (MYSELF)
YOU/'RE (I AM)
YOU/'VE (I HAVE)
I/'VE (YOU HAVE)
I/'LL (YOU WILL)
YOU/'LL (I SHALL)
I/'D (YOU WOULD)
YOU/'D (I WOULD)
HERE (THERE)
PLEASE (/)
OH/, (/)
OH (/)
SHOULDN/'T (SHOULD NOT)
WOULDN/'T (WOULD NOT)
WON/'T (WILL NOT)
HASN/'T (HAS NOT)))
(DEFUN REPLACE (SENT RLIST)
(PROG (TEMP FOO)
AGAIN
(COND ((NULL SENT)(RETURN TEMP)))
(SETQ FOO (MEMQ (KAR SENT) RLIST))
(SETQ FOO (COND (FOO (CADR FOO))
(T (LIST (KAR SENT)))))
(SETQ TEMP (CONCAT TEMP FOO))
(SETQ SENT (KDR SENT))
(GO AGAIN)))
(SETQ EOF -1.)
(DEFUN FILEINPUTCHECK ()
(AND
(ERRSET (IOTA ((STREAM (LIST '(DSK KMP) (STATUS UNAME) 'DOX)))
(DO ((C (TYI STREAM EOF) (TYI STREAM EOF))
(L ()))
((= C EOF)
(SETQ FILEINPUT (IMPLODE (NREVERSE L)))
(DELETEF STREAM))
(COND ((NOT (OR (= C 3.) (= C 0.) (= C 12.)))
(PUSH C L)))))
NIL)
'FILETYPEOUT))
(DEFUN WHEREGO (SENT)
(COND ((NULL SENT)(OR (FILEINPUTCHECK) ($ WHEREOUTP)))
((NULL (MEANING (KAR SENT)))
(WHEREGO (KDR SENT)))
(T (PROGN (SETQ FOUND (KAR SENT))
(MEANING (KAR SENT))))))
(DEFUN PART (LST NUM)
(COND ((ATOM LST) LST)
((GREATERP NUM (LENGTH LST)) NIL)
((LESSP NUM 2)(KAR LST))
(T (PART (KDR LST)(SUB1 NUM)))))
(DEFUN INDEX (LST ELEM)
(COND ((NOT (MEMQ ELEM LST)) 0)
(T (+ (- (LENGTH LST)
(LENGTH (MEMQ ELEM LST)))
1))))
(DEFUN SVO (SENT KEY TYPE MEM)
(PROG (FOO)
(SETQ FOO (MEMQ (PART SENT (- (INDEX SENT KEY) TYPE)) SENT))
(SETQ MEM (AND (SUBJSEARCH SENT KEY TYPE) MEM))
V (SETQ FOO (KDR FOO))
(COND ((VERBP (KAR FOO))(SETQ VERB (KAR FOO)))
((NULL (KDR FOO))(SETQ VERB (KAR FOO)))
(T (GO V)) )
(SETQ OBJ (GETNOUN (KDR FOO)))
(COND ((EQUAL OBJECT 'I)(SETQ OBJECT 'ME))
((EQUAL SUBJ 'ME)(SETQ SUBJ 'I)))
(COND (MEM (REMEMBER (LIST SUBJ VERB OBJ)))) ))
(DEFUN POSSESS (SENT KEY)
(PROG (COUNT)
(SETQ COUNT (INDEX SENT KEY))
(COND ((EQUAL COUNT 1)(SETQ OWNER 'YOUR))
(T (PROG (TEMP)(SETQ OWNER (PART SENT (SUB1 COUNT)))
(SETQ TEMP (EXPLODE OWNER))
(COND ((AND (NOT
(EQUAL 'S (PART TEMP
(LENGTH TEMP))))
(NOT (EQUAL OWNER 'MY))
(NOT (EQUAL OWNER 'HER))
(NOT (EQUAL OWNER 'THEIR)))
(SETQ OWNER 'YOUR))))))))
(SETQ LINEL (LINEL TYO))
(DEFUN TXTYPE(A)
(TERPRI)
(WHILE (NOT A)
(COND ((> (+ (FLATC (KAR A)) (CHARPOS T) -2.) LINEL)
(TERPRI)))
(PRINC (KAR A))
(PRINC SPACE)
(SETQ A (CDR A)))
(TERPRI))
(DEFUN LIST1 (X)(COND ((ATOM X)(COND ((NULL X) NIL)(T (LIST X))))(T X)))
(DEFUN BUILD (STR1 STR2)
(COND ((NULL STR1) STR2)((NULL STR2) STR1)
((AND (ATOM STR1)
(ATOM STR2))
(IMPLODE (CONCAT (EXPLODEC STR1)(EXPLODEC STR2))))
(T NIL)))
(DEFUN CONCAT (X Y)
(COND ((NULL X)(COND ((NULL Y) NIL)(T (LIST1 Y))))
((NULL Y)(LIST1 X))
((ATOM X)(COND ((ATOM Y)(LIST1 X Y))(T (APPEND (LIST1 X) Y))))
((ATOM Y)(APPEND X (LIST1 Y)))
(T (APPEND X Y))))
(DEFUN ASSM(PROTO)
(COND ((NULL PROTO) NIL)
((ATOM (KAR PROTO))
(CONS (KAR PROTO) (ASSM (KDR PROTO))))
(T (CONCAT (UNIX-EVAL (KAR PROTO))(ASSM (KDR PROTO))))))
(DEFUN // (X) X)
(SETQ HOWDYFLAG NIL)
(DEFUN DOC ()
(SETQ OBSERVATION-LIST ())
(COND ((ATOM (ERRSET
(PROG (LINCOUNT REPETITIVE-SHORTNESS **MAD**)
(SETQ REPETITIVE-SHORTNESS (CONS 0. 0.))
(TTY-OFF)
(SETQ LINCOUNT 0.)
(TYPE '(I AM THE PSYCHIATRIST/. ($ PLEASE)
($ DESCRIBE) YOUR ($ PROBLEMS)(// PERIOD)))
(SETQ LOVER '(YOUR PARTNER))
(SETQ SUBJ NIL VERB NIL OBJ NIL OBJECT NIL HISTORY NIL
FOUND NIL SENT NIL OWNER NIL)
TOP (SETQ LINCOUNT (1+ LINCOUNT))
(SETQ BAK SENT)
(SETQ SENT (TXREAD))
(COND
((EQUAL SENT '(FOO))
(TYPE '(BAR! ($ PLEASE)($ CONTINUE)))
(GO TOP))
((OR (MEMBER SENT '((GOOD BYE) (SEE YOU LATER) (I QUIT) (SO LONG)
(GO AWAY) (GET LOST)))
(MEMQ (KAR SENT)
'(BYE HALT BREAK QUIT DONE EXIT GOODBYE
BYE/, STOP PAUSE GOODBYE/, STOP PAUSE)))
(TTY-ON)
(RETURN 'GOOD-BYE))
((EQUAL (KAR SENT) 'WHATMEANS) (PROGN (DEF (CADR SENT))(GO TOP)))
((EQUAL SENT '(PARSE)) (PROGN
(TYPE (LIST 'SUBJ '= SUBJ COMMA SPACE SPACE
'VERB '= VERB NEWLINE
'OBJECT 'PHRASE '= OBJ
COMMA
'NOUN 'FORM '= OBJECT NEWLINE
'CURRENT 'KEYWORD 'IS FOUND
COMMA SPACE
'MOST 'RECENT 'POSSESSIVE
'IS OWNER NEWLINE
'SENTENCE 'USED 'WAS
'/././.
'(// BAK)))(GO TOP)))
((EQUAL (KAR SENT) 'FORGET) (PROGN (SET (CADR SENT) NIL)
(TYPE '(($ ISEE)($ PLEASE)
($ CONTINUE)(// PERIOD) ))
(GO TOP)))
((DEFQ SENT) (DEFINE SENT FOUND)))
(COND ((GREATERP (LENGTH SENT) 12)(SHORTEN SENT)))
(COND ((EQUAL SENT '(DDT))(VALRET '|:YOU CAN TALK TO DDT:VK |)
(TYPE '(($ PLEASE)($ CONTINUE) DISCUSSING YOUR ($ PROBLEMS)))(GO TOP))
)
(SETQ SENT (CORRECT-SPELLING (REPLACE SENT REPLIST)))
(COND ((AND (NOT (MEMQ 'ME SENT))(NOT (MEMQ 'I SENT))
(MEMQ 'AM SENT))(SETQ SENT (REPLACE SENT '(AM (ARE))))))
(COND ((LESSP (LENGTH SENT) 2)
(COND ((EQ (MEANING (CAR SENT)) 'HOWDY)
(GO HOWDY)))
(GO SHORT)))
(COND ((MEMQ 'AM SENT)(SETQ SENT (REPLACE SENT '(ME (I))))))
(FIXUP)
(COND ((AND (EQ (CAR SENT) 'DO) (EQ (CADR SENT) 'NOT))
(COND ((ZEROP (RANDOM 3.))
(TYPE '(ARE YOU ($ AFRAIDOF) THAT?))
(GO TOP))
((ZEROP (RANDOM 2.))
(TYPE '(DON/'T TELL ME WHAT TO DO/. I AM THE
PSYSCHIATRIST HERE!))
(GO RTHING))
(T
(TYPE '(($ WHYSAY) THAT I SHOULDN/'T (CDDR SENT)
(// QMARK)))
(GO TOP)))))
GOTOIT (GO (WHEREGO SENT))
DESIRE1
(GO ($ WHEREOUTP))
FILETYPEOUT
(CURSORPOS 'A)
(PRINC FILEINPUT)
(CURSORPOS 'A)
(GO TOP)
HUH (TYPE ($ HUHLST))
(GO TOP)
RTHING (TYPE ($ THLST))
(GO TOP)
REMEM (COND ((NULL HISTORY)(GO HUH)) )
(TYPE ($ REMLST))
(GO TOP)
HOWDY (COND ((NOT HOWDYFLAG)
(TYPE '(($ HELLO) WHAT BRINGS YOU TO SEE ME?))
(SETQ HOWDYFLAG T))
(T
(TYPE '(($ IBELIEVE) WE/'VE INTRODUCED OURSELVES ALREADY/.))
(TYPE '(($ PLEASE) ($ DESCRIBE) ($ THINGS) (// PERIOD)))))
(GO TOP)
WHEN (COND ((LESSP (LENGTH (MEMQ FOUND SENT)) 3)(GO SHORT)) )
(SETQ SENT (KDR (MEMQ FOUND SENT)))
(FIXUP)
(TYPE '(($ WHATWHEN)(// SENT)(// QMARK)))
(GO TOP)
CONJ (COND ((LESSP (LENGTH (MEMQ FOUND SENT)) 4)(GO SHORT)) )
(SETQ SENT (KDR (MEMQ FOUND SENT)))
(FIXUP)
(COND ((EQUAL (KAR SENT) 'OF)
(TYPE '(ARE YOU ($ SURE) THAT IS THE REAL REASON?))
(SETQ THINGS (CONS (KDR SENT) THINGS))
(GO TOP) ))
(REMEMBER SENT)
(TYPE ($ BECLST))
(GO TOP)
SHORT (COND ((= (CAR REPETITIVE-SHORTNESS) (1- LINCOUNT))
(RPLACD REPETITIVE-SHORTNESS (1+ (CDR REPETITIVE-SHORTNESS))))
(T
(RPLACD REPETITIVE-SHORTNESS 1.)))
(RPLACA REPETITIVE-SHORTNESS LINCOUNT)
(COND ((> (CDR REPETITIVE-SHORTNESS) 6.)
(COND ((NOT **MAD**)
(TYPE '(($ AREYOU) JUST TRYING TO SEE WHAT KIND OF THINGS
I HAVE IN MY VOCABULARY? PLEASE TRY TO
CARRY ON A REASONABLE CONVERSATION!))
(SETQ **MAD** T)
(GO TOP))
(T
(TYPE '(I GIVE UP/. YOU NEED A LESSON IN CREATIVE
WRITING /././.))
(TTY-ON)
(PUSH MONOSYLLABLES OBSERVATION-LIST)
(RETURN 'I-QUIT)))))
(COND ((EQUAL SENT (ASSM '(YES)))
(TYPE '(($ ISEE) ($ INTER) ($ WHYSAY) THIS IS SO?)))
((EQUAL SENT (ASSM '(BECAUSE)))
(TYPE ($ SHORTBECLST)))
((EQUAL SENT (ASSM '(NO)))
(TYPE ($ NEGLST)))
(T (TYPE ($ SHORTLST))))
(GO TOP)
ALCOHOL (TYPE ($ DRNK))(GO TOP)
LOVE LOVES
DESIRE (SETQ FOO (MEMQ FOUND SENT))
(COND ((LESSP (LENGTH FOO) 2)(GO (BUILD (MEANING FOUND) 1)))
((NOT (EQ (CADR FOO) 'TO))(GO (BUILD (MEANING FOUND) 1)) ) )
(SVO SENT FOUND 1 NIL)
(REMEMBER (LIST SUBJ 'WOULD 'LIKE OBJ))
(TYPE ($ WHYWANT)) (GO TOP)
DRUG (TYPE ($ DRUGS))(REMEMBER (LIST 'YOU 'USED FOUND))(GO TOP)
TOKE (TYPE ($ TOKLST))(GO TOP)
STATE (TYPE ($ STATES))(REMEMBER (LIST 'YOU 'WERE FOUND))(GO TOP)
MOOD (TYPE ($ MOODS))(REMEMBER (LIST 'YOU 'FELT FOUND))(GO TOP)
FEAR (SETQ FOUND (SETPREP SENT FOUND))
(TYPE ($ FEARS))(REMEMBER (LIST 'YOU 'WERE 'AFRAID 'OF FOUND))(GO TOP)
HATE (SVO SENT FOUND 1 T)
(COND ((MEMQ 'NOT SENT) (FORGET) (GO HUH) ))
(COND ((EQUAL SUBJ 'YOU)(TYPE '(WHY DO YOU (// VERB)(// OBJ)(// QMARK)
)))
(T (TYPE '(($ WHYSAY)(LIST SUBJ VERB OBJ)))))
(GO TOP)
SYMPTOMS (TYPE '(($ MAYBE) YOU SHOULD CONSULT A DOCTOR OF MEDICINE/,
I AM A PSYCHIATRIST))
(GO TOP)
HATES (SVO SENT FOUND 1 T)
(TYPE '(($ WHYSAY)(LIST SUBJ VERB OBJ)))
(GO TOP)
LOVES1
(SVO SENT FOUND 1 T)
QLOVES (TYPE '(($ BOTHER)(LIST SUBJ VERB OBJ)))
(GO TOP)
LOVE1 (SVO SENT FOUND 1 T)
(COND ((MEMQ 'NOT SENT) (FORGET) (GO HUH) ))
(COND ((EQUAL OBJECT 'SOMETHING)
(SETQ OBJECT '(THIS PERSON YOU LOVE))))
(COND ((EQUAL SUBJ 'YOU)(PROGN (SETQ LOVER OBJECT)
(COND ((EQUAL LOVER '(THIS PERSON YOU LOVE))
(SETQ LOVER '(YOUR PARTNER))
(FORGET)
(TYPE '(WITH WHOM ARE YOU IN LOVE?))
(GO TOP)))
(TYPE '(($ PLEASE)
($ DESCRIBE)
($ RELATION)
(// LOVER)
(// PERIOD) )) ))
((EQUAL SUBJ 'I)
(TXTYPE '(WE WERE DISCUSSING YOU!)))
(T (FORGET)
(SETQ OBJ 'SOMEONE)
(SETQ VERB (BUILD VERB 'S))
(GO QLOVES) ) )
(GO TOP)
MACH (SETQ FOUND (PLURAL FOUND))
(TYPE ($ MACHLST))
(GO TOP)
SEXNOUN SEXVERB
(COND ((OR (MEMQ 'ME SENT)(MEMQ 'MYSELF SENT)(MEMQ 'I SENT))
(GO FOUL) ))
(TYPE ($ SEXLST))(GO TOP)
DEATH (TYPE ($ DEATHLST))
(GO TOP)
FOUL (TYPE ($ FOULLST))
(GO TOP)
FAMILY (POSSESS SENT FOUND)
(TYPE ($ FAMLST))
(GO TOP)
)
T ))(DOC))
(T
(TERPRI TYO)
(PRINC '|MY SECRETARY WILL SEND YOU A BILL.| TYO)
(TERPRI TYO)
(SUICIDE))))
(SETQ WHEREOUTP '( HUH REMEM RTHING ) )
(DEFUN $ FEXPR (WHAT)
(PROG (VV FIRST)
(SETQ VV (UNIX-EVAL (CAR WHAT)))
(SETQ FIRST (KAR VV))
(SETQ VV (APPEND (KDR VV)(LIST FIRST)))
(SET (CAR WHAT) VV)
(RETURN FIRST) ))
(DEFUN CHARBAK (A P)
(COND ((EQUAL TTY 9.)
(COND ((NOT A)
(PRINC (ASCII 7.)))
(T (CURSORPOS 'X TYO))))
(T (COND ((NOT A) (PRINC (ASCII 7.)))
(P (PRINC (ASCII A)))
(T (PRINC '\)
(PRINC (ASCII A)))))))
(SETQ FOO
(SYSCALL 3 'TTYGET TYI)) ;GET THE ORIGINAL DATA
(COND ((MEMQ (STATUS UNAME) '(KMP EJS CGR ERIC RWK TNP TURNIP))
(SETQ KMPMODE T))
(T (SETQ KMPMODE NIL)))
(COND (KMPMODE
(SETQ *RSET T)
(SETQ ERRLIST '((TTY-ON)
(TERPRI)
(PRINC (ASCII 7.))
(PRINC '|>*BEEP*<|)))
(SETQ EXIT '(LAMBDA () (^G)))
(DEFPROP DEBUG ((MC RWK) DEBUG) AUTOLOAD))
(T
(SETQ ERRLIST '((TERPRI)
(PRINC (ASCII 7.))
(DOC)))
(SSTATUS TTYINT 2. 7.)
(SSTATUS TTYINT 4. NIL)
(SSTATUS TTYINT 17. 7.)
(SSTATUS TTYINT 19. NIL)
(SSTATUS TTYINT 23. NIL)
(SSTATUS TTYINT 24. 7.)
(SETQ EXIT 'QUIT)))
(SSTATUS FEATURE NOLDMSG)
(SETQ IBASE 10. BASE 10.)
(SETQ LINEL 78.)
;;;
;;; The following are library functions necessary to this program
;;;
(DEFUN MEMLIST (X Y)
(APPLY 'OR (MAPCAR (FUNCTION (LAMBDA (X) (LIST 'QUOTE (MEMQ X Y))))
X)))
(SETQ SMALL-LETTERS (EXPLODEC '|abcdefghijklmnopqrstuvwxyz|))
(DEFUN CAPS (X) (CAR (EXPLODEN (KAPS (ASCII X)))))
(DEFUN KAPS (X)
(COND
((MEMQ X SMALL-LETTERS)
(CDR (ASSOC X '((|a| . A)(|b| . B)(|c| . C)(|d| . D)
(|e| . E)(|f| . F)(|g| . G)(|h| . H)
(|i| . I)(|j| . J)(|k| . K)(|l| . L)
(|m| . M)(|n| . N)(|o| . O)(|p| . P)
(|q| . Q)(|r| . R)(|s| . S)(|t| . T)
(|u| . U)(|v| . V)(|w| . W)(|x| . X)
(|y| . Y)(|z| . Z)))))
(T X)))
;;;
;;; The function build will take a two atoms and build them together
;;; like implode, but will not ignore multiple characters like implode
;;; would.
;;;
(DEFUN BUILD (X Y)
(COND ((NOT (ATOM X))
(TERPRI)
(PRINC
'|Error: First arg to BUILD not an atom. It will be ignored.|
)
(PRINC X)
(BUILD NIL Y))
((NOT (ATOM Y))
(TERPRI)
(PRINC
'|Error: 2nd arg to BUILD not an atom. It will be ignored.|)
(PRINC Y)
(BUILD X NIL))
((NULL X) Y)
((NULL Y) X)
(T (IMPLODE (APPEND (DELETE '/| (DELETE '// (EXPLODE X)))
(DELETE '/| (DELETE '// (EXPLODE Y))))))))
;;;
;;; The ADDPROP function will add an item to the list in the property
;;; slot desginated in the arg-list.
;;;
(DEFUN ADDPROP (ATOM-NAME NEW-PROP PROP-NAME)
(PROG (OLD-PROP)
(SETQ OLD-PROP (GET ATOM-NAME PROP-NAME))
(COND ((NULL NEW-PROP) NIL)
((NULL OLD-PROP)
(PUTPROP ATOM-NAME (LIST NEW-PROP) PROP-NAME))
((ATOM OLD-PROP)
(PUTPROP ATOM-NAME (LIST NEW-PROP OLD-PROP) PROP-NAME))
(T (PUTPROP ATOM-NAME
(CONS NEW-PROP OLD-PROP)
PROP-NAME)))))
(DEFUN TTY-OFF ()
(SYSCALL 0 'TTYSET
TYI
(BOOLE 1 (CAR FOO) 3272356035.)
(BOOLE 1 (CADR FOO) 3272356035.)))
(DEFUN TTY-ON ()
(SYSCALL 0 'TTYSET
TYI
(CAR FOO)
(CADR FOO)))
(SETQ S-QUOTE '/')
(SETQ OPEN-QUOTES '/'/')
(SETQ CLOSE-QUOTES '/`/`)
(SETQ SPACE '/ )
(SETQ COMMA '/,)
(SETQ PERIOD '/./ )
(SETQ SEMICOLON '/;)
(SETQ EXCLAM '!/ )
(SETQ DOTDOTDOT '/./././ )
(SETQ EXCLAM-3 '!!!/ )
(SETQ COLON ':/ )
(SETQ QMARK '?/ )
(SETQ HYPHEN '-)
(SETQ NEWLINE (ASCII 13.))
(SETQ TAB (ASCII 9.))
(DEFUN NON-PUNCTUATION (X) (NOT (PUNCTUATION X)))
(DEFUN PUNCTUATION (X) (MEMQ X (LIST
COMMA SPACE PERIOD HYPHEN S-QUOTE DOTDOTDOT
QMARK COLON SEMICOLON EXCLAM EXCLAM-3
OPEN-QUOTES CLOSE-QUOTES)))
;;;
;;; The line-read function will read line by line, allowing deletes and
;;; printing deleted regions backwards between backslashes ... It will
;;; exit upon reading of either a double-carriage return or a carriage
;;; return preceded by a period, exclamation mark, or a question mark.
;;;
(DEFUN LINE-READ ()
(PROG (LINE C B P A TEMP)
(SETQ P NIL)
TOP (SETQ C (CAPS (TYI TYI)))
R1 (COND ((EQUAL C 9.) (SETQ C 32.))
((AND (GREATERP C 64.)
(LESSP C 91.)
(EQ B 45.))
(SETQ LINE (APPEND LINE (LIST 45.))))
((EQUAL C 10.) (SETQ C 13.)))
(COND ((OR (EQUAL C 127.) (EQUAL C 8.)) ;RUBOUT (BACKSPACE)
(SETQ LINE (CHAR-RUBOUT LINE))
(SETQ A (GET 'CHAR-RUBOUT 'CHAR))
(CHARBAK A P)
(SETQ P T)
(SETQ B (CAR (LAST LINE)))
(GO TOP)))
(COND ((EQUAL C 12.) ;CONTROL-L
(TERPRI)
(CURSORPOS 'C TYO)
(PRINC (IMPLODE LINE))
(SETQ P NIL)
(GO TOP))
((EQUAL C 27.)
(PRINC (ASCII 7.))
(GO TOP))
((AND (NOT (EQUAL TTY 9.)) P)
(PRINC '\)
(SETQ P NIL)))
(COND ((OR (MEMBER C '(18. 21. 13. 11. 4.))
(GREATERP C 26.))
(PRINC (ASCII C))))
(COND ((EQUAL C 46.)
(SETQ LINE (APPEND LINE (LIST 46.)))
(GO OUTCHECK))
((EQUAL C 33.)
(SETQ LINE (APPEND LINE (LIST 33.)))
(GO OUTCHECK))
((EQUAL C 63.)
(COND ((NULL LINE)
(SETQ LINE (LIST 87. 72. 65. 84. 63.)))
(T (SETQ LINE (APPEND LINE (LIST 63.)))))
(GO OUTCHECK))
((EQUAL C 13.)
(COND ((EQUAL B 45.) ;HYPHENATION
(SETQ B (CAR (LAST LINE)))
(GO TOP)))
(SETQ B NIL)
(SETQ LINE (APPEND LINE (LIST 32.)))
(GO TOP))
((OR (EQUAL C 21.) (EQUAL C 4.)) ;CONTROL-U, CONTROL-D
(SETQ B NIL)
(SETQ LINE NIL)
(TERPRI TYO)
(GO TOP))
((OR (EQUAL C 18.) (EQUAL C 11.)) ;CONTROL-R, CONTROL-K
(TERPRI)
(PRINC (IMPLODE LINE))
(GO TOP))
((EQUAL C 45.)
(SETQ B 45.)
(GO TOP))
((AND (LESSP C 58.) ;RECOVER MINUS
(GREATERP C 47.) ;SIGN FOR NUMBERS
(EQUAL B 45.))
(SETQ LINE (APPEND LINE (LIST 45.)))))
BACK
(SETQ LINE (APPEND LINE (LIST C)))
(SETQ B C)
(GO TOP)
OUTCHECK
(COND ((NULL LINE) (GO TOP)) ;NO TEXT
(T (RETURN LINE)))))
(DEFUN CHAR-RUBOUT (CHAR-LIST) ;Helping function
(COND ((NULL CHAR-LIST) ;for LINE-READ
(PUTPROP 'CHAR-RUBOUT NIL 'CHAR)
NIL)
((ATOM CHAR-LIST) (ERR))
((NULL (CDR CHAR-LIST))
(PUTPROP 'CHAR-RUBOUT (CAR CHAR-LIST) 'CHAR)
NIL)
(T (APPEND (LIST (CAR CHAR-LIST))
(CHAR-RUBOUT (CDR CHAR-LIST))))))
;;;
;;; The following functions will read a set of input and parse it into
;;; a list of sentences
;;;
(DEFUN PARSE-READ () (PARSE-INPUT (LINE-READ)))
(DEFUN PARSE-INPUT (LINE)
(PROG2 (PUTPROP 'SENTENCE NIL 'TYPE)
(REVERSE (CDR (DO ((WORD (PARSE-WORD LINE) (PARSE-WORD LINE))
(PARAGRAPH (NCONS NIL))
(A NIL))
((NULL WORD) PARAGRAPH)
(SETQ A (GET 'WORD-BREAK 'TYPE))
(SETQ PARAGRAPH
(PARSE-PARAGRAPH A WORD PARAGRAPH)))))
(PUTPROP 'SENTENCE (REVERSE (GET 'SENTENCE 'TYPE)) 'TYPE)))
(DEFUN PARSE-PARAGRAPH (BREAK WORD PARAGRAPH)
(COND ((EQUAL BREAK 32.) ;SPACE
(CONS
(APPEND (CAR PARAGRAPH)
WORD)
(CDR PARAGRAPH)))
((EQUAL BREAK 63.) ;QUESTION MARK
(ADDPROP 'SENTENCE 'QUESTION 'TYPE)
(CONS NIL
(CONS (APPEND (CAR PARAGRAPH)
WORD)
(CDR PARAGRAPH))))
((OR (EQUAL BREAK 46.)
(EQUAL BREAK 33.) ;EXCLAM
(EQUAL BREAK 59.)) ;PERIOD/SEMICOLON
(ADDPROP 'SENTENCE 'STATEMENT 'TYPE)
(CONS NIL
(CONS (APPEND (CAR PARAGRAPH)
WORD)
(CDR PARAGRAPH))))
((EQUAL BREAK 44.) ;COMMA
(CONS
(APPEND (CAR PARAGRAPH)
(APPEND WORD (LIST COMMA)))
(CDR PARAGRAPH)))
((EQUAL BREAK 58.) ;COLON
(CONS
(APPEND (CAR PARAGRAPH)
(APPEND WORD (LIST COLON)))
(CDR PARAGRAPH)))))
(DEFUN PARSE-WORD (LINE)
(PROG (WORD)
(SETQ WORD NIL)
(COND ((OR (NULL LINE)
(AND (EQUAL (LENGTH LINE) 1.)
(WORD-BREAK (CAR LINE))))
(RETURN NIL)))
(DO ((C (CAR LINE) (CAR LINE))
(L (CDR LINE) (CDR LINE)))
((NOT (WORD-BREAK C)))
(COND ((NULL L) (RETURN NIL)))
(RPLACA LINE (CAR L))
(RPLACD LINE (CDR L)))
(COND ((NULL LINE) (RETURN NIL)))
(DO ((C (CAR LINE) (CAR LINE))
(L (CDR LINE) (CDR LINE)))
((WORD-BREAK C))
(SETQ WORD (CONS C WORD))
(COND ((NULL L) (RETURN NIL)))
(RPLACA LINE (CAR L))
(RPLACD LINE (CDR L)))
(RETURN (LIST (IMPLODE (REVERSE WORD))))))
(DEFUN WORD-BREAK (X)
(PUTPROP 'WORD-BREAK X 'TYPE)
(COND ((OR (EQUAL X 32.) ;SPACE
(EQUAL X 33.) ;EXCLAMATION MARK
(EQUAL X 44.) ;COMMA
(EQUAL X 46.) ;PERIOD
(EQUAL X 58.) ;COLON
(EQUAL X 59.) ;SEMI-COLON
(EQUAL X 63.)) T) ;QUESTION MARK
(T NIL)))
(DEFUN TXREAD ()
(PROG (A B)
TOP (SETQ A (DELETE COMMA (CAR (PARSE-READ))))
(SETQ B (CAR (GET 'SENTENCE 'TYPE)))
(COND ((EQ B 'STATEMENT)
(RETURN A))
((EQ B 'QUESTION)
(TYPE ($ QLIST))
(TYPE '(($ PLEASE)
($ DESCRIBE)
($ SOMETHING)
ABOUT
($ THINGS)
(// PERIOD)))))
(GO TOP)))
(DOC))
Reference in New Issue View Git Blame Copy Permalink