;;
;;  LMORPH,  edited version of MORPHO, part of SHRDLU
;;

(declare (genprefix morpho))

(defun etaoin nil
  (prog (word newword char altn already-blging-newwrd wrd last next
	 y word1 x rd poss)
   thru (setq sent (setq word (setq punct (setq poss nil))))
        (print 'READY)
	(terpri)
	(and mobyread (ioc q))
   char (cond ((equal (tyipeek) 24.) (readch) (ert) (go thru)))
	(cond ((equal (tyipeek)  3.)
	       (or (and mobyread (end-of-file-condition))
		   (bug etaoin: about to read eof))))
	(setq char
          (cond ((greaterp 123. (setq char (tyi)) 96.)  (- char 32.))
	  	((greaterp  91. char 64.)               char)
                (t char))
          char (ascii char))
        (cond ((eq char '/) (go word))
              ((memq char altmode)
               (setq char (ascii (uppercase-ify-char (tyi))))
               (cond ((memq char altmode)
                      (ert)
                      (go thru))
                     ((eq char 'C)
                      (tyo 12.)
                      (go do))
                     ((eq char 'R) 
                      (terpri)
                      (go do))
                     ((and (eq char 'S) savesent)
                      (setq sent  (car savesent))
                      (setq punct (cdr savesent))
                      (%)
                      (return sent))
                     ((eq char 'N)
                      (setq newword (not newword)
                            altn    (not altn))
                      (go char))
                     ((eq char 'Q)
                      (ioc q)
                      (setq ignore nil)
                      (go thru))
                     ((eq char 'M)
                      (ioc q)
                      (setq ignore   nil
                            mobyread t)
                      (go thru))
                     ((eq char 'I)
                      (setq ignore t)
                      (ioc q)
                      (go thru))
                     ((go thru))))
              ((eq char rubout)
               (cond (word
                      (princ (car word))
                      (setq word (cdr word)))
                     (sent
                      (print (car sent))
                      (setq sent (cdr sent))))
               (go char))
              ((eq char carret)
               (go word))
              ((memq char puncl)
               (setq punct char)
               (and word (go word))
               (go func)))
        (and
         (or (and (eq char '")
		  (not already-blging-newrd)
		  (setq newword (setq already-blging-newrd t))
		  (go char))
	     (and (eq char '")
		  already-blging-newrd
		  (not (setq already-blging-newrd nil))
		  (go word))
	     (numberp char)
	     (and (eq char '=)
		  (null word))
	     (memq char vowel)
	     (memq char conso))
	 (setq word (cons char word)))
	(go char)
  do    (print 'READY)
        (terpri)
	(mapc #'(lambda (x) (print2 x))  (reverse sent))
	(princ '/ )
	(mapc #'princ                    (reverse word))
	(go char)
  word  (cond ((null word)
	       (go char))
	      ((equal word '(p l e h))
	       (help)
	       (go thru))
	      ((and (setq wrd (errset (readlist (reverse word))))
		    (numberp (setq wrd (car wrd))))
	       (setq sent (cons wrd sent))
	       (buildword wrd
			  (or (and (zerop (sub1 wrd))
				   '(num ns))
			      '(num))
			  (list 'num wrd)
			  nil))
	      ((null wrd)
	       (setq wrd (reverse word))
	       (go no))
	      ((get wrd 'features))
	      ((setq x (get wrd 'irregular))
	       (buildword wrd
			  (mod (get (car x) 'features)
			       (cdr x))
			  (sm x)
			  (car x)))
	      ((eq (car (last word)) '=)
	       (buildword wrd
			  (cond ((memq '"" word)    ; XXX
				 '(propn ns poss))
				('(propn ns)))
			  '((propn t))
			  nil))
	      ((go cut)))
        (go wrd)
  cut   (cond ((sta word '(T "" N))                ; XXX
	       (setq rd (cdddr word))
	       (setq word (cons '* word))
	       (go try))
	      ((sta word '(S ""))
	       (setq word (cddr word))
	       (setq poss wrd)
	       (go word))
	      ((sta word '(""))
	       (setq word (cdr word))
	       (setq poss wrd)
	       (go word))
	      ((sta word '(Y L))
	       (setq rd (cddr word))
	       (go ly))
	      ((sta word '(G N I))
	       (setq rd (cdddr word)))
	      ((sta word '(D E))
	       (setq rd (cddr word)))
	      ((sta word '(N E))
	       (setq rd (cddr word)))
	      ((sta word '(R E))
	       (setq rd (cddr word)))
	      ((sta word '(T S E))
	       (setq rd (cdddr word)))
	      ((sta word '(S))
	       (setq rd (cdr word))
	       (go sib))
	      (t (go no)))
        (setq last (car rd))
	(setq next (cadr rd))
	(cond ((and (memq last conso)
		    (not (memq last liquid))
		    (eq last next))
	       (setq rd (cdr rd)))
	      ((eq last 'I)
	       (setq rd (cons 'Y (cdr rd))))
	      ((or (and (memq last conso)
			(memq next vowel)
			(not (eq next 'E))
			(memq (caddr rd) conso))
		   (and (memq last liquid)
			(memq next conso)
			(not (memq next liquid)))
		   (and (eq last 'H)
			(eq next 'T))
		   (and (memq last '(C G S J V Z))
			(or (memq next liquid)
			    (and (memq next vowel)
				 (memq (caddr rd) vowel)))))
	       (setq rd (cons 'E rd))))
	(go try)
    ly  (cond (