;;
;;  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 ((and (memq (car rd) vowel)
		    (not (eq (car rd) 'E))
		    (memq (cadr rd) conso))
	       (setq rd (cons 'E rd))))
        (cond ((memq 'ADJ
		     (get (setq root (readlist (reverse rd)))
			  'FEATURES))
	       (buildword wrd '(ADV VBAD) nil root)
	       (go wrd)))
	(go no)
    sib (setq last (car rd))
        (setq next (cadr rd))
	(cond ((not (eq last 'E)))
	      ((eq next 'I)
	       (setq rd (cons 'Y (cddr rd))))
	      ((eq next 'X)
	       (setq rd (cdr rd)))
	      ((and (eq next 'H)
		    (not (eq (caddr rd) 'T)))
	       (setq rd (cdr rd)))
	      ((and (memq next '(S Z))
		    (eq next (caddr rd)))
	       (setq rd (cddr rd))))
    try (cond ((or (setq features
			 (get (setq root (readlist (reverse rd)))
			      'FEATURES))
		   (and (setq x (get root 'IRREGULAR))
			(setq features
			      (mod (get (setq root (car x)) 'FEATURES)
				   (cdr x)))))
	       (buildword wrd (mod features (get (car word) 'MOD))
			  (get root 'SEMANTICS)
			  root))
	      ((eq (car rd) 'E)
	       (setq rd (cdr rd))
	       (go try))
	      ((go no)))
    wrd (setq sent
	      (cond (poss ((or (memq 'NOUN (setq features
						 (get wrd 'FEATURES)))
			       (memq 'PROPN features))
			   (buildword poss
				      (append (meet features)
					      (get 'POSS 'ELIM))
				      '(POSS))
			   (get wrd 'SEMANTICS)
			   ;; root)
			   (cons poss sent))
			  ((buildword 'S             ; XXX
				      '(VB BE V3PS PRES)
				      (get 'BE 'SEMANTICS)
				      'BE)
			   (cons 'S (cons wrd sent)))))  ; XXX
	      ((cons wrd sent))))
   punc (cond
	 (punct (cond ((and (eq punct '?) (null sent))
		       (help)
		       (go thru))
		      ((memq punct final)
		       (return (car (setq savesent
					  (cons (reverse sent) punct)))))
		      ((setq sent (cons punct sent))))))
        (setq punct nil)
        (setq word (setq poss nil))
        (go char)
     no (cond (newword (buildword wrd
				  '(NOUN NS)
				  '((NOUN (SMNEWNOUN))
				    (PROPN (SMNEWPROPN)))
				  wrd)
		       (or altn (setq newword nil))
		       (go punc)))
        (terpri)
        (say *SORRY I DON/'T KNOW THE WORD "") ; XXX
        (princ wrd)
        (princ '/ ""/.) ; XXX
        (terpri)
        (say PLEASE TYPE <LF> AND CONTINUE THE SENTENCE/.)
   nogo (or (equal (tyi) 10.) (go nogo))
        (setq punct nil word nil)
        (go do)))

(defun propname (x) (eq (car (explode x)) '=))

(defun bcwl fexpr (a)
  (mapc
   '(lambda (x)
      (mapc
       '(lambda (y)
	  (buildword
	   (intern (maknam (nconc (explode (car x))
				  (cons '-
					(explode (car y))))))
	   (cons 'combination (cadr y))
	   (caddr y)
	   (list (car x) (car y))))
       (cdr x)))
   a)
  t)

(defun buildword (word features semantics root)
  (putprop word features 'features)
  (putprop word (or smn semantics) 'semantics)
  (and root (putprop word root 'root))
  word)

(defun buildwordlist fexpr (a)
s words
  (mapc '(lambda (x)
s optional
         (print (buildword (car x) (cadr x) (caddr x)
			   (and (cdddr x) (cadddr x)))))
	a))

(setq carret '/ )

(defun etnew nil
  (and (eq (car word) '"") ; XXX
       (eq (car (last word)) '"") ; XXX
       (setq wrd (readlist (cdr (reverse (cdr word)))))
       (buildword wrd '(NOUN NS) '((NOUN (NEWWORD))) NIL)))

(setq final '(/. ? !))

(setq conso '(B C D F G H J K L M N P Q R S T V W X Z))

(setq puncl '(/. ? : /; " !))

(setq rubout (ascii 127.))

(defprop undefined
  (lambda nil (prog2 (princ (word n)) (ert undefined)))
  expr)

(defun uppercase-ify-char (char)
  (cond ((greaterp 123. char 96.) (- char 32.))