doctor.el

早期freebsd实现

(defun doctor-othermodifierp (x)
  (memq x '(all also always amusing any anyway associated awesome
		bad beautiful best better but certain clear
		ever every fantastic fun funny
		good great gross growdy however if ignorant
		less linked losing lusing many more much
		never nice obnoxious often poor pretty real related rich
		similar some stupid super superb
		terrible terrific too total tubular ugly very)))

(defun doctor-prepp (x)
  (memq x '(about above after around as at
		  before beneath behind beside between by
		  for from in inside into
		  like near next of on onto over
		  same through thru to toward towards
		  under underneath with without)))

(defun doctor-remember (thing)
  (cond ((null history)
	 (setq history (list thing)))
	(t (setq history (append history (list thing))))))

(defun doctor-type (x)
  (setq x (doctor-fix-2 x))
  (doctor-txtype (doctor-assm x)))

(defun doctor-fixup (sent)
  (setq sent (append
	      (cdr
	       (assq (car sent)
		     (append
		      '((me  i)
			(him  he)
			(her  she)
			(them  they)
			(okay)
			(well)
			(sigh)
			(hmm)
			(hmmm)
			(hmmmm)
			(hmmmmm)
			(gee)
			(sure)
			(great)
			(oh)
			(fine)
			(ok)
			(no))
		      (list (list (car sent)
				  (car sent))))))
	      (cdr sent)))
  (doctor-fix-2 sent))

(defun doctor-fix-2 (sent)
  (let ((foo sent))
    (while foo
      (if (and (eq (car foo) 'me)
	       (doctor-verbp (doctor-cadr foo)))
	  (rplaca foo 'i)
	(cond ((eq (car foo) 'you)
	       (cond ((memq (doctor-cadr foo) '(am be been is))
		      (rplaca (cdr foo) 'are))
		     ((memq (doctor-cadr foo) '(has))
		      (rplaca (cdr foo) 'have))
		     ((memq (doctor-cadr foo) '(was))
		      (rplaca (cdr foo) 'were))))
	      ((equal (car foo) 'i)
	       (cond ((memq (doctor-cadr foo) '(are is be been))
		      (rplaca (cdr foo) 'am))
		     ((memq (doctor-cadr foo) '(were))
		      (rplaca (cdr foo) 'was))
		     ((memq (doctor-cadr foo) '(has))
		      (rplaca (cdr foo) 'have))))
	      ((and (doctor-verbp (car foo))
		    (eq (doctor-cadr foo) 'i)
		    (not (doctor-verbp (car (doctor-cddr foo)))))
	       (rplaca (cdr foo) 'me))
	      ((and (eq (car foo) 'a)
		    (doctor-vowelp (string-to-char
				    (doctor-make-string (doctor-cadr foo)))))
	       (rplaca foo 'an))
	      ((and (eq (car foo) 'an)
		    (not (doctor-vowelp (string-to-char
					 (doctor-make-string (doctor-cadr foo))))))
	       (rplaca foo 'a)))
	(setq foo (cdr foo))))
    sent))

(defun doctor-vowelp (x)
  (memq x '(?a ?e ?i ?o ?u)))

(defun doctor-replace (sent rlist)
  "Replaces any element of SENT that is the car of a replacement element
pair in RLIST"
  (apply 'append
	 (mapcar
	  (function
	   (lambda (x)
	     (cdr (or (assq x rlist)   ; either find a replacement
		      (list x x)))))   ; or fake an identity mapping
	  sent)))

(defun doctor-wherego (sent)
  (cond ((null sent)($ whereoutp))
	((null (doctor-meaning (car sent)))
	 (doctor-wherego (cond ((zerop (random-range 2))
				(reverse (cdr sent)))
			       (t (cdr sent)))))
	(t
	 (setq found (car sent))
	 (doctor-meaning (car sent)))))

(defun doctor-svo (sent key type mem)
  "Find subject, verb and object in sentence SENT with focus on word KEY.
TYPE is number of words preceding KEY to start looking for subject. MEM is
t if results are to be put on doctor's memory stack. Return is in global
variables subj, verb and object"
  (let ((foo (doctor-subjsearch sent key type) sent))
    (or foo
	(setq foo sent
	      mem nil))
    (while (and (null (doctor-verbp (car foo))) (cdr foo))
      (setq foo (cdr foo)))
    (setq verb (car foo))
    (setq obj (doctor-getnoun (cdr foo)))
    (cond ((eq object 'i)(setq object 'me))
	  ((eq subj 'me)(setq subj 'i)))
    (cond (mem (doctor-remember (list subj verb obj))))))

(defun doctor-possess (sent key)
  "Set possessive in SENT for keyword KEY. Hack on previous word, setting
global variable owner to possibly correct result"
  (let* ((i (- (length sent) (length (memq key sent)) 1))
	 (prev (if (< i 0) 'your
		 (nth i sent))))
    (setq owner (if (or (doctor-possessivepronounp prev)
			(string-equal "s"
				      (substring (doctor-make-string prev)
						 -1)))
		    prev
		  'your))))

;; Output of replies.

(defun doctor-txtype (ans)
  "Output to buffer a list of symbols or strings as a sentence"
  (setq *print-upcase* t *print-space* nil)
  (mapcar 'doctor-type-symbol ans)
  (insert "\n"))

(defun doctor-type-symbol (word)
  "Output a symbol to the buffer with some fancy case and spacing hacks"
  (setq word (doctor-make-string word))
  (if (string-equal word "i") (setq word "I"))
  (if *print-upcase*
      (progn
	(setq word (capitalize word))
	(if *print-space*
	    (insert " "))))
  (cond ((or (string-match "^[.,;:?! ]" word)
	     (not *print-space*))
	 (insert word))
	(t (insert ?\  word)))
  (if (> (current-column) fill-column)
      (apply auto-fill-hook nil))
  (setq *print-upcase* (string-match "[.?!]$" word)
	*print-space* t))

(defun doctor-build (str1 str2)
  "Make a symbol out of the concatenation of the two non-list arguments"
  (cond ((null str1) str2)
	((null str2) str1)
	((and (atom str1)
	      (atom str2))
	 (intern (concat (doctor-make-string str1)
			 (doctor-make-string str2))))
	(t nil)))

(defun doctor-make-string (obj)
  (cond ((stringp obj) obj)
	((symbolp obj) (symbol-name obj))
	((numberp obj) (int-to-string obj))
	(t "")))

(defun doctor-concat (x y)
  "like append, but force atomic arguments to be lists"
  (append
   (if (and x (atom x)) (list x) x)
   (if (and y (atom y)) (list y) y)))

(defun doctor-assm (proto)
  (cond ((null proto) nil)
	((atom proto) (list proto))
	((atom (car proto))
	 (cons (car proto) (doctor-assm (cdr proto))))
	(t (doctor-concat (doctor-assm (eval (car proto))) (doctor-assm (cdr proto))))))

;; Functions that handle specific words or meanings when found.

(defun doctor-go (destination)
  "Call a doctor- function"
  (funcall (intern (concat "doctor-" (doctor-make-string destination)))))

(defun doctor-desire1 ()
  (doctor-go ($ whereoutp)))

(defun doctor-huh ()
  (cond ((< (length sent) 9) (doctor-type ($ huhlst)))
	(t (doctor-type ($ longhuhlst)))))

(defun doctor-rthing () (doctor-type ($ thlst)))

(defun doctor-remem () (cond ((null history)(doctor-huh))
			     ((doctor-type ($ remlst)))))

(defun doctor-howdy ()
  (cond ((not howdyflag)
	 (doctor-type '(($ hello) what brings you to see me \?))
	 (setq howdyflag t))
	(t
	 (doctor-type '(($ ibelieve) we\'ve introduced ourselves already \.))
	 (doctor-type '(($ please) ($ describe) ($ things) \.)))))

(defun doctor-when ()
  (cond ((< (length (memq found sent)) 3)(doctor-short))
	(t
	 (setq sent (cdr (memq found sent)))
	 (setq sent (doctor-fixup sent))
	 (doctor-type '(($ whatwhen)(// sent) \?)))))

(defun doctor-conj ()
  (cond ((< (length (memq found sent)) 4)(doctor-short))
	(t
	 (setq sent (cdr (memq found sent)))
	 (setq sent (doctor-fixup sent))
	 (cond ((eq (car sent) 'of)
		(doctor-type '(are you ($ sure) that is the real reason \?))
		(setq things (cons (cdr sent) things)))
	       (t
		(doctor-remember sent)
		(doctor-type ($ beclst)))))))

(defun doctor-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**)
		(doctor-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))
	       (t
		(doctor-type '(i give up \. you need a lesson in creative
				 writing \.\.\.))
		;;(push monosyllables observation-list)
		)))
	(t
	 (cond ((equal sent (doctor-assm '(yes)))
		(doctor-type '(($ isee) ($ inter) ($ whysay) this is so \?)))
	       ((equal sent (doctor-assm '(because)))
		(doctor-type ($ shortbeclst)))
	       ((equal sent (doctor-assm '(no)))
		(doctor-type ($ neglst)))
	       (t (doctor-type ($ shortlst)))))))
	   
(defun doctor-alcohol () (doctor-type ($ drnk)))

(defun doctor-desire ()
  (let ((foo (memq found sent)))
    (cond ((< (length foo) 2)
	   (doctor-go (doctor-build (doctor-meaning found) 1)))
	  ((memq (doctor-cadr foo) '(a an))
	   (rplacd foo (append '(to have) (cdr foo)))
	   (doctor-svo sent found 1 nil)
	   (doctor-remember (list subj 'would 'like obj))
	   (doctor-type ($ whywant)))
	  ((not (eq (doctor-cadr foo) 'to))
	   (doctor-go (doctor-build (doctor-meaning found) 1)))
	  (t
	   (doctor-svo sent found 1 nil)
	   (doctor-remember (list subj 'would 'like obj))
	   (doctor-type ($ whywant))))))

(defun doctor-drug ()
  (doctor-type ($ drugs))
  (doctor-remember (list 'you 'used found)))

(defun doctor-toke ()
  (doctor-type ($ toklst)))

(defun doctor-state ()
  (doctor-type ($ states))(doctor-remember (list 'you 'were found)))

(defun doctor-mood ()
  (doctor-type ($ moods))(doctor-remember (list 'you 'felt found)))

(defun doctor-fear ()
  (setq feared (doctor-setprep sent found))
  (doctor-type ($ fears))
  (doctor-remember (list 'you 'were 'afraid 'of feared)))

(defun doctor-hate ()
  (doctor-svo sent found 1 t)
  (cond ((memq 'not sent) (doctor-forget) (doctor-huh))
	((equal subj 'you)
	 (doctor-type '(why do you (// verb)(// obj) \?)))
	(t (doctor-type '(($ whysay)(list subj verb obj))))))

(defun doctor-symptoms ()
  (doctor-type '(($ maybe) you should consult a doctor of medicine\,
		 i am a psychiatrist \.)))

(defun doctor-hates ()
  (doctor-svo sent found 1 t)
  (doctor-hates1))

(defun doctor-hates1 ()
  (doctor-type '(($ whysay)(list subj verb obj))))

(defun doctor-loves ()
  (doctor-svo sent found 1 t)
  (doctor-qloves))

(defun doctor-qloves ()
  (doctor-type '(($ bother)(list subj verb obj) \?)))

(defun doctor-love ()
  (doctor-svo sent found 1 t)
  (cond ((memq 'not sent) (doctor-forget) (doctor-huh))
	((memq 'to sent) (doctor-hates1))
	(t
	 (cond ((equal object 'something)
		(setq object '(this person you love))))
	 (cond ((equal subj 'you)
		(setq lover obj)
		(cond ((equal lover '(this person you love))
		       (setq lover '(your partner))
		       (doctor-forget)
		       (doctor-type '(with whom are you in love \?)))
		      ((doctor-type '(($ please)
				      ($ describe)
				      ($ relation)
				      (// lover)
				      \.)))))
	       ((equal subj 'i)
		(doctor-txtype '(we were discussing you!)))
	       (t (doctor-forget)
		  (setq obj 'someone)
		  (setq verb (doctor-build verb 's))
		  (doctor-qloves))))))

(defun doctor-mach ()
  (setq found (doctor-plural found))
  (doctor-type ($ machlst)))

(defun doctor-sexnoun () (doctor-sexverb))

(defun doctor-sexverb ()
  (if (or (memq 'me sent)(memq 'myself sent)(memq 'i sent))
      (doctor-foul)
    (doctor-type ($ sexlst))))

(defun doctor-death () (doctor-type ($ deathlst)))

(defun doctor-foul ()
  (doctor-type ($ foullst)))

(defun doctor-family ()
  (doctor-possess sent found)
  (doctor-type ($ famlst)))

;; I did not add this -- rms.
(defun doctor-rms ()
  (cond (rms-flag (doctor-type ($ stallmanlst)))
	(t (setq rms-flag t) (doctor-type '(do you know Stallman \?)))))

(defun doctor-school nil (doctor-type ($ schoollst)))

(defun doctor-eliza ()
  (cond (eliza-flag (doctor-type ($ elizalst)))
	(t (setq eliza-flag t)
	   (doctor-type '((// found) \? hah !
			  ($ please) ($ continue) \.)))))
	   
(defun doctor-sports ()  (doctor-type ($ sportslst)))

(defun doctor-math () (doctor-type ($ mathlst)))

(defun doctor-zippy ()
  (cond (zippy-flag (doctor-type ($ zippylst)))
	(t (setq zippy-flag t)
	   (doctor-type '(yow! are we interactive yet \?)))))


(defun doctor-chat () (doctor-type ($ chatlst)))