doctor.el

早期freebsd实现

(doctor-put-meaning soccer 'sports)
(doctor-put-meaning softball 'sports)
(doctor-put-meaning sports 'sports)
(doctor-put-meaning swimming 'sports)
(doctor-put-meaning swim 'sports)
(doctor-put-meaning tennis 'sports)
(doctor-put-meaning volleyball 'sports)
(doctor-put-meaning math 'math)
(doctor-put-meaning mathematics 'math)
(doctor-put-meaning mathematical 'math)
(doctor-put-meaning theorem 'math)
(doctor-put-meaning axiom 'math)
(doctor-put-meaning lemma 'math)
(doctor-put-meaning algebra 'math)
(doctor-put-meaning algebraic 'math)
(doctor-put-meaning trig 'math)
(doctor-put-meaning trigonometry 'math)
(doctor-put-meaning trigonometric 'math)
(doctor-put-meaning geometry 'math)
(doctor-put-meaning geometric 'math)
(doctor-put-meaning calculus 'math)
(doctor-put-meaning arithmetic 'math)
(doctor-put-meaning zippy 'zippy)
(doctor-put-meaning zippy 'zippy)
(doctor-put-meaning pinhead 'zippy)
(doctor-put-meaning chat 'chat)

(defun doctor ()
  "Switch to *doctor* buffer and start giving psychotherapy."
  (interactive)
  (switch-to-buffer "*doctor*")
  (doctor-mode))

(defun doctor-ret-or-read (arg)
  "Insert a newline if preceding character is not a newline,
Otherwise call the Doctor to parse preceding sentence"
  (interactive "*p")
  (if (= (preceding-char) ?\n)
      (doctor-read-print)
    (newline arg)))

(defun doctor-read-print nil
  "top level loop"
  (interactive)
  (let ((sent (doctor-readin)))
    (insert "\n")
    (setq lincount (1+ lincount))
    (doctor-doc sent)
    (insert "\n")
    (setq bak sent)))

(defun doctor-readin nil
  "Read a sentence. Return it as a list of words"
  (let (sentence)
    (backward-sentence 1)
    (while (not (eobp))
      (setq sentence (append sentence (list (doctor-read-token)))))
    sentence))

(defun doctor-read-token ()
  "read one word from buffer"
  (prog1 (intern (downcase (buffer-substring (point)
					     (progn
					       (forward-word 1)
					       (point)))))
    (re-search-forward "\\Sw*")))

;; Main processing function for sentences that have been read.

(defun doctor-doc (sent)
  (cond
   ((equal sent '(foo))
    (doctor-type '(bar! ($ please)($ continue))))
   ((doctor-member sent howareyoulst)
    (doctor-type '(i\'m ok \.  ($ describe) yourself \.)))
   ((or (doctor-member sent '((good bye) (see you later) (i quit) (so long)
			      (go away) (get lost)))
	(memq (car sent)
	      '(bye halt break quit done exit goodbye 
		    bye\, stop pause goodbye\, stop pause)))
    (doctor-type ($ bye)))
   ((and (eq (car sent) 'you)
	 (memq (doctor-cadr sent) abusewords))
    (setq found (doctor-cadr sent))
    (doctor-type ($ abuselst)))
   ((eq (car sent) 'whatmeans)
    (doctor-def (doctor-cadr sent)))
   ((equal sent '(parse))
    (doctor-type (list  'subj '= subj ",  "
			'verb '= verb "\n"
			'object 'phrase '= obj ","
			'noun 'form '=  object "\n"
			'current 'keyword 'is found
			", "
			'most 'recent 'possessive
			'is owner "\n"
			'sentence 'used 'was
			"..."
			'(// bak))))
   ;;   ((eq (car sent) 'forget)
   ;;    (set (doctor-cadr sent) nil)
   ;;    (doctor-type '(($ isee)($ please)
   ;;     ($ continue)\.)))
   (t
    (if (doctor-defq sent) (doctor-define sent found))
    (if (> (length sent) 12)(doctor-shorten sent))
    (setq sent (doctor-correct-spelling (doctor-replace sent replist)))
    (cond ((and (not (memq 'me sent))(not (memq 'i sent))
		(memq 'am sent))
	   (setq sent (doctor-replace sent '((am . (are)))))))
    (cond ((equal (car sent) 'yow) (doctor-zippy))
	  ((< (length sent) 2)
	   (cond ((eq (doctor-meaning (car sent)) 'howdy)
		  (doctor-howdy))
		 (t (doctor-short))))
	  (t
	   (if (memq 'am sent)
	       (setq sent (doctor-replace sent '((me . (i))))))
	   (setq sent (doctor-fixup sent))
	   (if (and (eq (car sent) 'do) (eq (doctor-cadr sent) 'not))
	       (cond ((zerop (random-range 3))
		      (doctor-type '(are you ($ afraidof) that \?)))
		     ((zerop (random-range 2))
		      (doctor-type '(don\'t tell me what to do \. i am the
					    psychiatrist here!))
		      (doctor-rthing))
		     (t
		      (doctor-type '(($ whysay) that i shouldn\'t
				     (doctor-cddr sent)
				     \?))))
	     (doctor-go (doctor-wherego sent))))))))

;; Things done to process sentences once read.

(defun doctor-correct-spelling (sent)
  "correct the spelling and expand each word in sentence"
  (if sent
      (apply 'append (mapcar '(lambda (word)
				(if (memq word typos)
				    (get (get word 'doctor-correction) 'doctor-expansion)
				  (list word)))
			     sent))))

(defun doctor-shorten (sent)
  "Make a sentence managably short using a few hacks"
  (let (foo
	retval
	(temp '(because but however besides anyway until
		    while that except why how)))
    (while temp
	   (setq foo (memq (car temp) sent))
	   (if (and foo
		    (> (length foo) 3))
	       (setq sent foo
		     sent (doctor-fixup sent)
		     temp nil
		     retval t)
	       (setq temp (cdr temp))))
    retval))

(defun doctor-define (sent found)
  (doctor-svo sent found 1 nil)
  (and
   (doctor-nounp subj)
   (not (doctor-pronounp subj))
   subj
   (doctor-meaning object)
   (put subj 'doctor-meaning (doctor-meaning object))
   t))

(defun doctor-defq (sent)
  "Set global var  found  to first keyword found in sentence SENT"
  (setq found nil)
  (let ((temp '(means applies mean refers refer related
		      similar defined associated linked like same)))
    (while temp
	   (if (memq (car temp) sent)
	       (setq found (car temp)
		     temp nil)
	       (setq temp (cdr temp)))))
  found)

(defun doctor-def (x)
  (progn
   (doctor-type (list 'the 'word x 'means (doctor-meaning x) 'to 'me)) 
   nil))

(defun doctor-forget ()
  "Delete the last element of the history list"
  (setq history (reverse (cdr (reverse history)))))

(defun doctor-query (x)
  "Prompt for a line of input from the minibuffer until a noun or a
verb word is seen. Put dialogue in buffer."
  (let (a
	(prompt (concat (doctor-make-string x)
			" what \?  "))
	retval)
    (while (not retval)
	   (while (not a)
	     (insert ?\n
		     prompt
		     (read-string prompt)
		     ?\n)
	     (setq a (doctor-readin)))
	   (while (and a (not retval))
		  (cond ((doctor-nounp (car a))
			 (setq retval (car a)))
			((doctor-verbp (car a))
			 (setq retval (doctor-build
				       (doctor-build x " ")
				       (car a))))
			((setq a (cdr a))))))
    retval))

(defun doctor-subjsearch (sent key type)
  "Search for the subject of a sentence SENT, looking for the noun closest to
and preceding KEY by at least TYPE words. Set global variable subj to the
subject noun, and return the portion of the sentence following it"
  (let ((i (- (length sent) (length (memq key sent)) type)))
    (while (and (> i -1) (not (doctor-nounp (nth i sent))))
      (setq i (1- i)))
    (cond ((> i -1)
	   (setq subj (nth i sent))
	   (nthcdr (1+ i) sent))
	  (t
	   (setq subj 'you)
	   nil))))

(defun doctor-nounp (x)
  "Returns t if the symbol argument is a noun"
	(or (doctor-pronounp x)
	    (not (or (doctor-verbp x)
		     (equal x 'not)
		     (doctor-prepp x)
		     (doctor-modifierp x) )) ))

(defun doctor-pronounp (x)
  "Returns t if the symbol argument is a pronoun"
  (memq x '(
	i me mine myself
	we us ours ourselves ourself
	you yours yourself yourselves
	he him himself she hers herself
	it that those this these things thing
	they them themselves theirs
	anybody everybody somebody
	anyone everyone someone
	anything something everything)))

(mapcar (function (lambda (x) (put x 'doctor-sentence-type 'verb)))
	'(abort aborted aborts ask asked asks am
		applied applies apply are associate
		associated ate
		be became become becomes becoming
		been being believe belived believes
		bit bite bites bore bored bores boring bought buy buys buying
		call called calling calls came can caught catch come
		contract contracted contracts control controlled controls
		could croak croaks croaked cut cuts
		dare dared define defines dial dialed dials did die died dies
		dislike disliked
		dislikes do does drank drink drinks drinking
		drive drives driving drove dying
		eat eating eats expand expanded expands
		expect expected expects expel expels expeled expelled
		explain explained explains
		fart farts feel feels felt fight fights find finds finding
		forget forgets forgot fought found fuck fucked
		fucking fucks
		gave get gets getting give gives go goes going gone got gotten
		had harm harms has hate hated hates have having
		hear heard hears hearing help helped helping helps
		hit hits hope hoped hopes hurt hurts
		implies imply is
		join joined joins jump jumped jumps
		keep keeping keeps kept
		kill killed killing kills kiss kissed kisses kissing
		knew know knows
		laid lay lays let lets lie lied lies like liked likes
		liking listen listens
		login look looked looking looks
		lose losing lost
		love loved loves loving
		luse lusing lust lusts
		made make makes making may mean means meant might
		move moved moves moving must
		need needed needs 
		order ordered orders ought
		paid pay pays pick picked picking picks 
		placed placing prefer prefers put puts
		ran rape raped rapes
		read reading reads recall receive received receives
		refer refered referred refers
		relate related relates remember remembered remembers
		romp romped romps run running runs
		said sang sat saw say says
		screw screwed screwing screws scrod see sees seem seemed
		seems seen sell selling sells
		send sendind sends sent shall shoot shot should
		sing sings sit sits sitting sold studied study
		take takes taking talk talked talking talks tell tells telling
		think thinks
		thought told took tooled touch touched touches touching
		transfer transfered transfers transmit transmits transmitted
		type types types typing
		walk walked walking walks want wanted wants was watch
		watched watching went were will wish would work worked works
		write writes writing wrote use used uses using))

(defun doctor-verbp (x) (if (symbolp x)
			    (eq (get x 'doctor-sentence-type) 'verb)))

(defun doctor-plural (x)
  "form the plural of the word argument"
  (let ((foo (doctor-make-string x)))
    (cond ((string-equal (substring foo -1) "s")
	   (cond ((string-equal (substring foo -2 -1) "s")
		  (intern (concat foo "es")))
		 (t x)))
	   ((string-equal (substring foo -1) "y")
	    (intern (concat (substring foo 0 -1)
			    "ies")))
	   (t (intern (concat foo "s"))))))

(defun doctor-setprep (sent key)
  (let ((val)
	(foo (memq key sent)))
    (cond ((doctor-prepp (doctor-cadr foo))
	   (setq val (doctor-getnoun (doctor-cddr foo)))
	   (cond (val val)
		 (t 'something)))
	  ((doctor-articlep (doctor-cadr foo))
	   (setq val (doctor-getnoun (doctor-cddr foo)))
	   (cond (val (doctor-build (doctor-build (doctor-cadr foo) " ") val))
		 (t 'something)))
	  (t 'something))))

(defun doctor-getnoun (x)
  (cond ((null x)(setq object 'something))
	((atom x)(setq object x))
	((eq (length x) 1)
	 (setq object (cond
		       ((doctor-nounp (setq object (car x))) object)
		       (t (doctor-query object)))))
	((eq (car x) 'to)
	 (doctor-build 'to\  (doctor-getnoun (cdr x))))
	((doctor-prepp (car x))
	 (doctor-getnoun (cdr x)))
	((not (doctor-nounp (car x)))
	 (doctor-build (doctor-build (cdr (assq (car x)
						(append
						 '((a . this)
						   (some . this)
						   (one . that))
						 (list
						  (cons
						   (car x) (car x))))))
				     " ")
		       (doctor-getnoun (cdr x))))
	(t (setq object (car x))) ))

(defun doctor-modifierp (x)
  (or (doctor-adjectivep x)
      (doctor-adverbp x)
      (doctor-othermodifierp x)))

(defun doctor-adjectivep (x)
  (or (numberp x)
      (doctor-nmbrp x)
      (doctor-articlep x)
      (doctor-colorp x)
      (doctor-sizep x)
      (doctor-possessivepronounp x)))

(defun doctor-adverbp (xx)
  (string-equal (substring (doctor-make-string xx) -2) "ly"))

(defun doctor-articlep (x)
  (memq x '(the a an)))

(defun doctor-nmbrp (x)
  (memq x '(one two three four five six seven eight nine ten
		eleven twelve thirteen fourteen fifteen
		sixteen seventeen eighteen nineteen
		twenty thirty forty fifty sixty seventy eighty ninety
		hundred thousand million billion
		half quarter
		first second third fourth fifth
		sixth seventh eighth nineth tenth)))
		 
(defun doctor-colorp (x)
  (memq x '(beige black blue brown crimson
		  gray grey green
		  orange pink purple red tan tawny
		  violet white yellow)))

(defun doctor-sizep (x)
  (memq x '(big large tall fat wide thick
		small petite short thin skinny)))

(defun doctor-possessivepronounp (x)
  (memq x '(my your his her our their)))