doctor.l

<B>Digital的Unix操作系统VAX 4.2源码</B>

;	@(#)doctor.l	4.3	(Berkeley) 7/26/83
;
(eval-when (eval) (cvttomaclisp))
; these functions are franz only.
; to make doctor:
;   liszt -mr -o doctor doctor.l

(declare (special endtime starttime ticks float-format user topipe
		  user-top-level))

(defun mailbill ()
  (setq endtime (ptime)
	ticks  (difference (car endtime) (car starttime))
	user (getenv '|USER|)
	float-format "%.2f")
  (apply 'process (list (concat "//bin//mail " user)
		       'topipe
		       'frompipe))
  (msg (|P| topipe) "From the doctor" |N|
		  "To: " user |N|
  		  "Subject: bill for services" |N| |N|
  		  "Please remit $" (min 50. (quotient (times ticks 10000.0) 
					     (times 60 60 60)))
  			" for " (quotient ticks 60.0) " cpu seconds "
			|N|
			"       thank you, " |N|
			"           The doctor."
			|N|)
  (close topipe))

(DECLARE (SPECIAL TERMINAL LETTER WORD SENTENCE KEYSTACK TERMINALWIDTH 
		  CARRIAGERETURN RUBOUT LINEFEED FLAG PARSELIST 
		  RULES FLIPFLOP S D LINE)
	 (SPECIAL READTABLE)
	 (EVAL (READ)))

(PROG2  (SETSYNTAX #/' 2 ) 
	(SETSYNTAX #/; 2 )
	(setsyntax #/" 2)
	(setsyntax #/, 2)
	(setsyntax #/` 2)
	(setsyntax #/# 2)
	)






(DEFUN GOBBLE-LINES-OF-CHARS NIL
     (PROG (CH L)
      C    (SETQ CH (readc))
           (COND ((AND (EQ CH linefeed)
		       (SETQ L (CONS CH L))
		       (EQ (SETQ CH (readc)) linefeed))
		  (RETURN (NREVERSE (CONS CH L))))
		(t(SETQ L (CONS CH L))))
	   (GO C) ))


(DEFUN WORKER NIL
 (setq terminalwidth 72)
	(PROG (SENTENCE KEYSTACK)
	      (TERPRI)
	      (PRINC (QUOTE SPEAK/ UP!/ HIT/ 2/ RETURNS/ after/ typing))
	      (TERPRI)
	  A   (SETQ SENTENCE (SETQ KEYSTACK NIL))
	      (READIN)
	      (ANALYZE)
	      (TERPRI)
	      (TERPRI)
	      (GO A)) )
   






(DEFUN READIN NIL 
   (PROG (WORD LETTER FLAG TERMINAL LINE)
         (SETQ LINE (GOBBLE-LINES-OF-CHARS))
      A  (COND ((NULL (READWORD)) (GO B)))
         (MAKESENTENCE)
	 (SETKEYSTACK)
      B  (BREAKANALYZE)
	 (COND ((NOT FLAG) (GO A)))
	 (SETQ SENTENCE (NREVERSE SENTENCE)) ))

(DEFUN READWORD NIL 
 (PROG NIL
       (SETQ WORD NIL)
  A    (COND ((SETQ FLAG (GET (NEXTCH) (QUOTE BREAK)))
	      (RETURN (COND (WORD (SETQ WORD
					(IMPLODE (REVERSE WORD))))))))
       (SETQ WORD (CONS LETTER WORD))
       (GO A)))

(DEFUN MAKESENTENCE NIL 
 (SETQ SENTENCE
       (CONS (COND ((SETQ FLAG (GET WORD (QUOTE TRANSLATION)))
			    FLAG)
		   (WORD))
	     SENTENCE)))

(DEFUN SETKEYSTACK NIL 
 (COND ((AND (SETQ FLAG (GET WORD (QUOTE PRIORITY)))
	     KEYSTACK
	     (GREATERP FLAG
		       (GET (CAR KEYSTACK) (QUOTE PRIORITY))))
	(SETQ KEYSTACK (CONS WORD KEYSTACK)))
       (FLAG (SETQ KEYSTACK (APPEND KEYSTACK (LIST WORD))))))

(DEFUN BREAKANALYZE NIL 
 (COND ((EQ LETTER CARRIAGERETURN) (SETQ FLAG TERMINAL)
					(SETQ TERMINAL T))
       ((AND 	(SETQ FLAG (GET LETTER (QUOTE PUNCTUATION)))
		KEYSTACK)
		(GOBBLE))
       (FLAG (SETQ SENTENCE (SETQ FLAG NIL)))
       ((NOT (EQ LETTER LINEFEED))
	    (SETQ TERMINAL NIL))))

(DEFUN TEST (D S)
 (PROG NIL
  G    (COND ((NULL D)
	      (RETURN (COND ((NOT S)
			     (SETQ PARSELIST
				   (REVERSE PARSELIST))))))
	     ((NOT (COND ((NUMBERP (CAR D))
			  (COND ((ZEROP (CAR D)) (TEST5))
				((TEST3 (CAR D) NIL))))
			 ((TEST4 (CAR D)) (TEST2))))
	      (RETURN NIL)))
       (SETQ D (CDR D))
       (GO G)))

(DEFUN ADVANCE NIL 
     (RPLACA (CDAR RULES)
	     (COND ((NULL (CDADAR RULES)) (CDDAR RULES))
		   ((CDADAR RULES)))))

(DEFUN SENTPRINT (ANS)
       (PROG (N)
	  A0 (SETQ N 0)
	  A  (PRINC (CAR ANS))
	     (SETQ N (PLUS N (FLATSIZE (CAR ANS))))
	     (COND ((SETQ ANS (CDR ANS))
		    (COND ((GREATERP N TERMINALWIDTH)
			   (TERPRI) 
			   (GO A0))
			  ((PRINC (QUOTE / ))))
		    (GO A)))
	     (MEMORY)))

(DEFUN RECONSTRUCT (R)
     (COND ((NULL R) NIL)
	   ((NUMBERP (CAR R)) (APPEND (RECO1 (CAR R) PARSELIST)
				      (RECONSTRUCT (CDR R))))
	   ((CONS (CAR R) (RECONSTRUCT (CDR R))))))

(DEFUN GOBBLE NIL 
 (PROG NIL
      A	   (NEXTCH)
	   (BREAKANALYZE)
	   (COND ((NOT FLAG) (GO A)))))

(DEFUN NEXTCH NIL
	(SETQ LETTER (CAR LINE))
	(SETQ LINE (CDR LINE))
	LETTER)

(DEFUN TEST1 (PROPL X)
   (COND ((NULL PROPL) NIL)
	 ((GET X (CAR PROPL)) T)
		 ((TEST1 (CDR PROPL) X))))

(DEFUN TEST2 NIL 
  (PROG NIL
   (SETQ PARSELIST (CONS (LIST (CAR S)) PARSELIST))
   (SETQ S (CDR S))
   (RETURN T)))

(DEFUN TEST3 (X L)
	 (COND ((ZEROP X) (SETQ PARSELIST (CONS (REVERSE L) PARSELIST)))
	       (S (TEST3 (SUB1 X)
			 (CONS (CAR S) (PROG2 (SETQ S (CDR S)) L))))))

(DEFUN TEST4 (D)
     (COND ((NULL S) NIL)
	   ((ATOM D) (EQ D (CAR S)))
	   ((CAR D) (MEMBER (CAR S) D))
	   ((TEST1 (CDR D) (CAR S)))))

(DEFUN TEST5 NIL 
 (PROG (L)
       (COND ((NULL (CDR D)) (SETQ PARSELIST (CONS S PARSELIST))
			     (RETURN (NOT (SETQ S NIL)))))
  A    (COND ((TEST4 (CADR D))
	      (RETURN (SETQ PARSELIST
			    (CONS (REVERSE L) PARSELIST))))
	     ((AND (SETQ L (CONS (CAR S) L)) (SETQ S (CDR S)))
	      (GO A)))))

(DEFUN RECO1 (X P)
  (COND ((GREATERP X 1) 
	 (RECO1 (SUB1 X) (CDR P))) 
	((CAR P))))

(DEFUN ANALYZE NIL 
    (PROG (RULES PARSELIST DECOMP)
	(SETQ KEYSTACK
	      (APPEND KEYSTACK
		      (LIST (GET (QUOTE NONE)
				 (COND ((ZEROP (SETQ FLIPFLOP
						     (DIFFERENCE 2 FLIPFLOP)))
					(QUOTE MEM))
				       ((QUOTE LASTRESORT)))))))
   A	(SETQ RULES (GET (CAR KEYSTACK) (QUOTE RULES)))
   B	(SETQ DECOMP (CAAR (COND ((ATOM (CAR RULES))
				  (SETQ RULES (GET (CAR RULES) (QUOTE RULES))))
				 (RULES))))
	(SETQ PARSELIST NIL)
	(COND ((NOT (TEST DECOMP SENTENCE)) (SETQ RULES (CDR RULES)))
	      ((AND (NOT (ATOM (CAR (SETQ RULES (CAR (ADVANCE))))))
		    (NOT (EQ (CAAR RULES) (QUOTE PRE))))
	       (RETURN (SENTPRINT (RECONSTRUCT (CAR RULES)))))
	      ((NOT (ATOM (CAR RULES)))
	       (SETQ SENTENCE (RECONSTRUCT (CADAR RULES)))
	       (SETQ RULES (CDDAR RULES)))
	      ((EQ (CAR RULES) (QUOTE NEWKEY)) (SETQ KEYSTACK (CDR KEYSTACK))
					       (GO A)))
	(GO B)))


(DEFUN MEMORY NIL 
    ((LAMBDA (PARSELIST)
	     (AND (SETQ RULES (GET (CAR KEYSTACK) (QUOTE MEMR)))
		  (TEST (CAAR RULES) SENTENCE)
		  ((LAMBDA (X) (RPLACA X
				       (APPEND (CAR X)
					       (LIST (RECONSTRUCT (CAAR (ADVANCE)))))))
			(CDAR (GET (GET (QUOTE NONE) (QUOTE MEM)) (QUOTE RULES))))))
	NIL))


(COMMENT DOCTOR SET UP OF SOME INITIAL VALUES AND PROPERTIES)


(MAPC 	(QUOTE (LAMBDA (X) (PUTPROP (SET (CAR X) (ASCII (CADR X))) T (QUOTE BREAK))))
	(QUOTE ((RUBOUT 127.)
		(BLANK 32.)
		(CARRIAGERETURN 10.)
		(LINEFEED 10.)
		(HORIZONTALTAB 9.))))

(SETQ FLIPFLOP 0)

(MAPC 	(QUOTE (LAMBDA (X) 
		   (PUTPROP X T (QUOTE BREAK))
		   (PUTPROP X T (QUOTE PUNCTUATION))))
	(QUOTE (/. /, /( /) ! ? : /;)))


(COMMENT  DOCTOR SCRIPT - UPDATED TO /25 NOV /69)

(PUTPROP (QUOTE NONE)
	 ((LAMBDA (X)
		  (PUTPROP X 
			   (QUOTE (((0)
					(NIL)
					(I AM NOT SURE I UNDERSTAND YOU FULLY)
					(PLEASE GO ON)
					(WHAT DOES THAT SUGGEST TO YOU)
					(DO YOU FEEL STRONGLY ABOUT DISCUSSING SUCH THINGS))))
			   (QUOTE RULES))
		   X)
	   (GENSYM))
	 (QUOTE LASTRESORT))

(PUTPROP (QUOTE NONE)
	 ((LAMBDA (X)
		  (PUTPROP X 
			   (LIST  (LIST (LIST 0)
					(LIST NIL)
					(GET (QUOTE NONE)
					     (QUOTE LASTRESORT))))
			   (QUOTE RULES))
		  X)
	      (GENSYM))
	 (QUOTE MEM))



(DEFPROP SORRY 0 PRIORITY)

(DEFPROP SORRY
	 (((0) (NIL)
	       (PLEASE DON/'T APOLOGIZE)
	       (APOLOGIES ARE NOT NECESSARY)
	       (WHAT FEELINGS DO YOU HAVE WHEN YOU APOLOGIZE)
	       (I/'VE TOLD YOU THAT APOLOGIES ARE NOT REQUIRED)
	       (APOLOGIES ARE NOT NECESSARY/, PLEASE GO ON)))
	 RULES)

(DEFPROP DONT DON/'T TRANSLATION)

(DEFPROP CANT CAN/'T TRANSLATION)

(DEFPROP WONT WON/'T TRANSLATION)

(DEFPROP REMEMBER 5 PRIORITY)

(DEFPROP REMEMBER
	 (((0 YOU REMEMBER 0) (NIL)
			      (DO YOU OFTEN THINK OF 4)
			      (DOES THINKING OF 4 BRING ANYTHING ELSE TO MIND)
			      (WHAT ELSE DO YOU REMEMBER)
			      (WHY DO YOU REMEMBER 4 JUST NOW)
			      (WHAT IN THE PRESENT SITUATION REMINDS YOU OF 4)
			      (WHAT IS THE CONNECTION BETWEEN ME AND 4))
	  ((0 DO I REMEMBER 0) (NIL)
			       (DID YOU THINK I WOULD FORGET 5)
			       (WHY DO YOU THINK I SHOULD RECALL 5 NOW)
			       (WHAT ABOUT 5)
			       WHAT
			       (YOU MENTIONED 5))
	  ((0) (NIL) NEWKEY))
	 RULES)

(DEFPROP IF 3 PRIORITY)

(DEFPROP IF
	 (((0 IF 0 HAD 0) (NIL) (PRE (1 2 3 MIGHT HAVE 5) IF))
	  ((0 IF 0) (NIL)
		    (DO YOU THINK ITS LIKELY THAT 3)
		    (DO YOU WISH THAT 3)
		    (WHAT DO YOU THINK ABOUT 3)
		    (REALLY IF 3)))
	 RULES)

(DEFPROP DREAMT 4 PRIORITY)

(DEFPROP DREAMT
	 (((0 YOU DREAMT 0) (NIL)
			    (REALLY 4)
			    (HAVE YOU EVER FANTASIED 4 WHILE YOU WERE AWAKE)
			    (HAVE YOU DREAMT 4 BEFORE)
			    DREAM
			    NEWKEY)
	 ((0) (NIL) DREAM NEWKEY))
	 RULES)

(DEFPROP DREAMED DREAMT TRANSLATION)

(DEFPROP DREAMED 4 PRIORITY)

(DEFPROP DREAMED (DREAMT) RULES)

(DEFPROP DREAM 3 PRIORITY)

(DEFPROP DREAM
	 (((0)
	   (NIL)
	   (WHAT DOES THAT DREAM SUGGEST TO YOU)
	   (DO YOU DREAM OFTEN)
	   (WHAT PERSONS APPEAR IN YOUR DREAMS)
	   (DON/'T YOU BELIEVE THAT DREAM HAS SOMETHING TO DO WITH YOUR PROBLEM)
	   (DO YOU EVER WISH YOU COULD FLEE FROM REALITY)
	   NEWKEY))
	 RULES)

(DEFPROP DREAMS DREAM TRANSLATION)

(DEFPROP DREAMS 3 PRIORITY)

(DEFPROP DREAMS (DREAM) RULES)

(DEFPROP WHAT 0 PRIORITY)

(DEFPROP WHAT
	(((WHAT WHERE)
	  (NIL)
	  HOW)
	 ((0 (WHAT WHERE) 0)
	  (NIL)
	  (TELL ME ABOUT 2 3)
	  (2 3)
	  (DO YOU WANT ME TO TELL YOU 2 3)
	  (REALLY)
	  (I SEE)
	  NEWKEY))
	RULES)

(DEFPROP ALIKE 10. PRIORITY)

(DEFPROP ALIKE (DIT) RULES)

(DEFPROP SAME 10. PRIORITY)

(DEFPROP SAME (DIT) RULES)

(DEFPROP CERTAINLY 0 PRIORITY)

(DEFPROP CERTAINLY (YES) RULES)

(DEFPROP FEEL T BELIEF)

(DEFPROP THINK T BELIEF)

(DEFPROP BELIEVE T BELIEF)

(DEFPROP WISH T BELIEF)

(DEFPROP BET T BELIEF)

(DEFPROP MY
	 (((0 YOUR 1 0)
	   (NIL)
	   (EARLIER YOU SAID YOUR 3 4)
	   (BUT YOUR 3 4)
	   (DOES THAT HAVE ANYTHING TO DO WITH YOUR STATEMENT ABOUT 3 4)))
	 MEMR)



(DEFPROP PERHAPS 0 PRIORITY)

(DEFPROP PERHAPS
	 (((0) (NIL)
	       (YOU DON/'T SEEM QUITE CERTAIN)
	       (WHY THE UNCERTAIN TONE)
	       (CAN/'T YOU BE MORE POSITIVE)
	       (YOU AREN/'T SURE)
	       (DON/'T YOU KNOW)))
	 RULES)

(DEFPROP MAYBE 0 PRIORITY)

(DEFPROP MAYBE (PERHAPS) RULES)

(DEFPROP NAME 15. PRIORITY)

(DEFPROP NAME
	 (((0)
	   (NIL)
	   (I AM NOT INTERESTED IN NAMES)
	   (I/'VE TOLD YOU BEFORE I DON/'T CARE ABOUT NAMES /- PLEASE CONTINUE)))
	 RULES)

(DEFPROP DEUTSCH 0 PRIORITY)

(DEFPROP DEUTSCH (((0) (NIL) (I AM SORRY/, I SPEAK ONLY ENGLISH))) RULES)

(DEFPROP FRANCAIS 0 PRIORITY)

(DEFPROP FRANCAIS (DEUTSCH) RULES)

(DEFPROP SVENSKA 0 PRIORITY)

(DEFPROP SVENSKA (DEUTSCH) RULES)

(DEFPROP ITALIANO 0 PRIORITY)

(DEFPROP ITALIANO (DEUTSCH) RULES)

(DEFPROP ESPANOL 0 PRIORITY)

(DEFPROP ESPANOL (DEUTSCH) RULES)

(DEFPROP HELLO 0 PRIORITY)

(DEFPROP HELLO (((0) (NIL) (HOW DO YOU DO/. PLEASE STATE YOUR PROBLEM))) RULES)

(DEFPROP COMPUTER 50. PRIORITY)

(DEFPROP COMPUTER
	 (((0) (NIL)
	       (DO COMPUTERS WORRY YOU)
	       (WHY DO YOU MENTION COMPUTERS)
	       (WHAT DO YOU THINK MACHINES HAVE TO DO WITH YOUR PROBLEM)
	       (DON/'T YOU THINK COMPUTERS CAN HELP PEOPLE)
	       (WHAT ABOUT MACHINES WORRIES YOU)
	       (WHAT DO YOU THINK ABOUT MACHINES)))
	 RULES)

(DEFPROP MACHINE 50. PRIORITY)

(DEFPROP MACHINE (COMPUTER) RULES)

(DEFPROP MACHINES 50. PRIORITY)

(DEFPROP MACHINES (COMPUTER) RULES)

(DEFPROP COMPUTERS 50. PRIORITY)

(DEFPROP COMPUTERS (COMPUTER) RULES)

(DEFPROP AM 0 PRIORITY)

(DEFPROP AM ARE TRANSLATION)

(DEFPROP AM
	 (((0 ARE YOU 0) (NIL)
			 (DO YOU BELIEVE YOU ARE 4)
			 (WOULD YOU WANT TO BE 4)
			 (YOU WISH I WOULD TELL YOU YOU ARE 4)
			 (WHAT WOULD IT MEAN IF YOU WERE 4)
			 HOW)
	  ((0) (NIL) (WHY DO YOU SAY /'AM/') (I DON/'T UNDERSTAND THAT)))
	 RULES)

(DEFPROP ARE 0 PRIORITY)

(DEFPROP ARE
	 (((0 THERE ARE 0 YOU 0) (NIL) (PRE (1 2 3 4) ARE))
	  ((0 THERE ARE 1 0) (NIL)
			     (WHAT MAKES YOU THINK 2 3 4 5)
			     (DO YOU USUALLY CONSIDER 4 5)
			     (DO YOU WISH 2 WERE 4 5))
	  ((0 THERE ARE 0) (NIL) NEWKEY)
	  ((0 ARE I 0) (NIL)
		       (WHY ARE YOU INTERESTED IN WHETHER I AM 4 OR NOT)
		       (WOULD YOU PREFER IF I WEREN/'T 4)