comparison lisp/play/doctor.el @ 47322:8a11a2109567

(doctor-cadr, doctor-caddr, doctor-cddr): Remove. Update callers.

47321:54efbd9f8cab

;; See also the file etc/CENSORSHIP in the Emacs distribution
;; for a discussion of why and how this file was censored, and the
;; political implications of the issue.

;;; Code:

(defun doctor-cadr (x) (car (cdr x)))
(defun doctor-caddr (x) (car (cdr (cdr x))))
(defun doctor-cddr (x) (cdr (cdr x)))

(defun // (x) x)

(defmacro $ (what)
  "quoted arg form of doctor-$"

(defun make-doctor-variables ()
  (make-local-variable 'typos)
  (setq typos
	(mapcar (function (lambda (x)
			    (put (car x) 'doctor-correction  (doctor-cadr x))
			    (put (doctor-cadr x) 'doctor-expansion (doctor-caddr x))
			    (car x)))
		'((theyll they\'ll (they will))
		  (theyre they\'re (they are))
		  (hes he\'s (he is))
		  (he7s he\'s (he is))

	(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"

			"..."
			'(// bak))))
   ((memq (car sent) '(do has have how when where who why))
    (doctor-type ($ qlist)))
   ;;   ((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)(setq sent (doctor-shorten sent)))

		 (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 3))
		      (doctor-type '(are you ($ afraidof) that \?)))
		     ((zerop (random 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.

	   (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))

(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)

(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))))))

47322:8a11a2109567

;; See also the file etc/CENSORSHIP in the Emacs distribution
;; for a discussion of why and how this file was censored, and the
;; political implications of the issue.

;;; Code:

(defun // (x) x)

(defmacro $ (what)
  "quoted arg form of doctor-$"

(defun make-doctor-variables ()
  (make-local-variable 'typos)
  (setq typos
	(mapcar (function (lambda (x)
			    (put (car x) 'doctor-correction  (cadr x))
			    (put (cadr x) 'doctor-expansion (car (cddr x)))
			    (car x)))
		'((theyll they\'ll (they will))
		  (theyre they\'re (they are))
		  (hes he\'s (he is))
		  (he7s he\'s (he is))

	(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 (cadr sent) abusewords))
    (setq found (cadr sent))
    (doctor-type ($ abuselst)))
   ((eq (car sent) 'whatmeans)
    (doctor-def (cadr sent)))
   ((equal sent '(parse))
    (doctor-type (list  'subj '= subj ",  "
			'verb '= verb "\n"
			'object 'phrase '= obj ","
			'noun 'form '=  object "\n"

			"..."
			'(// bak))))
   ((memq (car sent) '(do has have how when where who why))
    (doctor-type ($ qlist)))
   ;;   ((eq (car sent) 'forget)
   ;;    (set (cadr sent) nil)
   ;;    (doctor-type '(($ isee)($ please)
   ;;     ($ continue)\.)))
   (t
    (if (doctor-defq sent) (doctor-define sent found))
    (if (> (length sent) 12)(setq sent (doctor-shorten sent)))

		 (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 (cadr sent) 'not))
	       (cond ((zerop (random 3))
		      (doctor-type '(are you ($ afraidof) that \?)))
		     ((zerop (random 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
				     (cddr sent)
				     \?))))
	     (doctor-go (doctor-wherego sent))))))))

;; Things done to process sentences once read.

	   (t (intern (concat foo "s"))))))

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

(defun doctor-getnoun (x)
  (cond ((null x)(setq object 'something))

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

(defun doctor-vowelp (x)

(defun doctor-desire ()
  (let ((foo (memq found sent)))
    (cond ((< (length foo) 2)
	   (doctor-go (doctor-build (doctor-meaning found) 1)))
	  ((memq (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 (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))))))