;;; -*- LISP -*-
;;; COMRD: A library that implements a completing reader.
;;; Written by KMP some time ago, (obviously before # readmacro
;;; and defmacro were in use in maclisp), moved to LIBDOC by GJC
;;; as this is of general use as a command reader for
;;; interactive programs.
;;; The simplest and most common call will be
;;; (completing-read "prompt-> " '(foo bar baz bomb))

(herald comrd)

(DECLARE (SPECIAL COMPLETING-READER-OBJECT-HEADER)
	 (*LEXPR *COMPLETING-READ-OPTIONS
		 *COMPLETING-READ-PROMPT
		 *COMPLETING-READ-INSTREAM
		 *COMPLETING-READ-OUTSTREAM
		 *COMPLETING-READ-AMBIGUITY-ERROR
		 *COMPLETING-READ-NULL-ERROR
		 *COMPLETING-READ-COMPLETION-CHARS
		 *COMPLETING-READ-RETURN-CHARS
		 *COMPLETING-READ-CASE-CONVERT
		 *COMPLETING-READ-LAST-CASE
		 *COMPLETING-READ-OVERRUBOUT-RETURN
		 *COMPLETING-READ-CHARS-READ))

(SSTATUS TTYINT 23. NIL) ; Turn off ^W as a tty interrupt
(SSTATUS TTYINT 21. NIL) ; Turn off ^U as a tty interrupt

(EVAL-WHEN (EVAL COMPILE)
  (OR (GET 'TTY 'VERSION)
      (LOAD (CASEQ (STATUS OPSYS)
	      ((ITS) '((DSK LIBLSP) TTY))
	      (T '((LISP)TTY))))))

(DEFUN LAMBDA MACRO (FORM) (LIST 'FUNCTION FORM))

;;; *COMPLETING-READ and *COMPLETING-READ1
;;;
;;; *COMPLETING-READ prints a newline and a prompt.
;;; *COMPLETING-READ1 starts in cold (this is good for if completion
;;;   has been done and user rubs back out into the read)
;;;
;;; Args are:
;;;
;;;  PROMPT: What to type out as a prompt if anything.
;;;  CHARS-PENDING: What characters have already been read (won't echo).
;;;  INSTREAM: Where to read more chars from.
;;;  OUTSTREAM: Where to do type-out to.
;;;  AMBIGUITY-ERROR: If T, then beep instead of return if result is ambiguous.
;;;  NULL-ERROR: If T, then beep instead of return if result is null.
;;;  COMPLETION-CHARS: List of fixnums for chars that show completion.
;;;  RETURN-CHARS: List of fixnums for chars that return value(s).
;;;  CASE-CONVERT: If T, then lowercase stuff input gets canonicalized.
;;;  OVER-RUBOUT-RETURN-FLAG: Should form return if over-rubout?
;;;			      If non-NIL returns OVER-RUBOUT for too many
;;;			      rubouts, WORD-RUBOUT for ^W, and LINE-RUBOUT 
;;;			      for ^U.
;;;
;;; Returns a list whose CAR is the list of characters read and the
;;; CDR of which is the set of still-possible completions at the end of the
;;; read.

(DEFUN *COMPLETING-READ (PROMPT OPTIONS INSTREAM OUTSTREAM
				AMBIGUITY-ERROR NULL-ERROR
				COMPLETION-CHARS RETURN-CHARS
				CASE-CONVERT OVER-RUBOUT-RETURN-FLAG)
       (TERPRI OUTSTREAM)
       (PRINC PROMPT OUTSTREAM)
       (*COMPLETING-READ1 PROMPT OPTIONS () INSTREAM OUTSTREAM
			  AMBIGUITY-ERROR NULL-ERROR
			  COMPLETION-CHARS RETURN-CHARS
			  CASE-CONVERT OVER-RUBOUT-RETURN-FLAG))

(DEFUN *COMPLETING-READ1 (PROMPT OPTIONS CHARS-PENDING INSTREAM OUTSTREAM
				 AMBIGUITY-ERROR NULL-ERROR
				 COMPLETION-CHARS RETURN-CHARS
				 CASE-CONVERT OVER-RUBOUT-RETURN-FLAG)
       (LET ((COMPLETION-OBJECT (*COMPLETING-READ-OBJECT
				 OPTIONS
				 PROMPT
				 INSTREAM
				 OUTSTREAM
				 AMBIGUITY-ERROR
				 NULL-ERROR
				 COMPLETION-CHARS
				 RETURN-CHARS
				 CASE-CONVERT
				 OVER-RUBOUT-RETURN-FLAG)))
	    (MAPC (LAMBDA (X) (*COMPLETING-READ-PUSH-COMPLETION
			       X
			       COMPLETION-OBJECT))
		  CHARS-PENDING)
	    (*CATCH 'COMPLETING-READ-EXIT
		    (DO-WITH-TTY-OFF
		     (DO ()
			 (NIL)
			 (*COMPLETING-READ-TYI COMPLETION-OBJECT))))))

;;; (COMPLETING-READ <prompt> <options>)
;;; I/O default is to/from tty
;;; ambiguous or null response acceptable
;;; return or space causes return
;;; altmode causes completion
;;; no initial character
;;;
;;; Sample:  (COMPLETING-READ '> '(THIS THAT THOSE))
;;;

(DEFUN COMPLETING-READ (PROMPT OPTIONS)
       (CDR (*COMPLETING-READ PROMPT OPTIONS TYI TYO
			      T T
			      '(27.) '(13. 32.)
			      T NIL)))

(DEFUN *COMPLETING-READ-SOFT-TYI (COMPLETION CHAR)
       (LET ((OUTSTREAM (*COMPLETING-READ-OUTSTREAM COMPLETION)))
	    (TYO CHAR OUTSTREAM)
	    (*COMPLETING-READ-PUSH-COMPLETION CHAR COMPLETION)))

(DEFUN *COMPLETING-READ-CASE-FUNCTION (CHAR)
       (COND ((AND (> CHAR 96.) (< CHAR 123.))
	      '*COMPLETING-READ-LOWERCASIFY)
	     (T
	      '*COMPLETING-READ-UPPERCASIFY)))

(DEFUN *COMPLETING-READ-TYI (COMPLETION)
       (LET ((INSTREAM         (*COMPLETING-READ-INSTREAM COMPLETION))
	     (OUTSTREAM        (*COMPLETING-READ-OUTSTREAM COMPLETION)))
	    (LET ((CHAR (TYI INSTREAM)))
		 (COND ((= CHAR 12.)
			(CURSORPOS 'C OUTSTREAM)
			(*COMPLETING-READ-REDISPLAY-LINE COMPLETION))
		       ((= CHAR 18.)
			(*COMPLETING-READ-REDISPLAY-LINE COMPLETION))
		       ((MEMBER CHAR '(63. 2120.))
			(*COMPLETING-READ-DISPLAY-OPTIONS COMPLETION)
			(*COMPLETING-READ-REDISPLAY-LINE COMPLETION))
		       ((MEMBER CHAR (*COMPLETING-READ-COMPLETION-CHARS
				      COMPLETION))
			(*COMPLETING-READ-ATTEMPT-COMPLETION COMPLETION))
		       ((MEMBER CHAR (*COMPLETING-READ-RETURN-CHARS
				      COMPLETION))
			(*COMPLETING-READ-RETURN COMPLETION CHAR))
		       ((= CHAR 23.)
			(PRINC '|/| TYO)
			(COND
			 ((*COMPLETING-READ-OVERRUBOUT-RETURN COMPLETION)
			  (*THROW 'COMPLETING-READ-EXIT 'WORD-RUBOUT))
			 (T
			  (*COMPLETING-READ-RESET-COMPLETION COMPLETION)
			  (*COMPLETING-READ-REDISPLAY-LINE COMPLETION))))
		       ((= CHAR 21.)
			(PRINC '|/| TYO)
			(COND
			 ((*COMPLETING-READ-OVERRUBOUT-RETURN COMPLETION)
			  (*THROW 'COMPLETING-READ-EXIT 'LINE-RUBOUT))
			 (T
			  (*COMPLETING-READ-RESET-COMPLETION COMPLETION)
			  (*COMPLETING-READ-REDISPLAY-LINE COMPLETION))))
		       ((= CHAR 127.)
			(LET ((CHAR
			       (*COMPLETING-READ-POP-COMPLETION COMPLETION)))
			     (COND (CHAR
				    (COND ((MEMQ 'RUBOUT
						 (STATUS FILEM OUTSTREAM))
					   (RUBOUT CHAR OUTSTREAM))
					  (T
					   (TYO 92. OUTSTREAM)
					   (TYO CHAR OUTSTREAM))))
				   ((*COMPLETING-READ-OVERRUBOUT-RETURN
				     COMPLETION)
				    (*THROW 'COMPLETING-READ-EXIT
					    'OVER-RUBOUT)))))
		       (T
			(TYO CHAR (*COMPLETING-READ-OUTSTREAM COMPLETION))
			(*COMPLETING-READ-LAST-CASE
			 COMPLETION
			 (*COMPLETING-READ-CASE-FUNCTION CHAR))
			(*COMPLETING-READ-PUSH-COMPLETION CHAR COMPLETION))))))

(DEFUN *COMPLETING-READ-REDISPLAY-LINE (COMPLETION)
       (LET ((OUTSTREAM (*COMPLETING-READ-OUTSTREAM COMPLETION)))
	    (CURSORPOS 'A OUTSTREAM)
	    (PRINC (*COMPLETING-READ-PROMPT COMPLETION) OUTSTREAM)
	    (DO ((L (REVERSE (*COMPLETING-READ-CHARS-READ COMPLETION))
		    (CDR L))
		 (CASE-FUN (*COMPLETING-READ-LAST-CASE COMPLETION)))
		((NULL L))
		(TYO (FUNCALL CASE-FUN (CAR L)) OUTSTREAM))))

(DEFUN *COMPLETING-READ-RETURN (COMPLETION CHAR)
       (LET ((OPTIONS (CAR (*COMPLETING-READ-OPTIONS COMPLETION)))
	     (NUMBER-OF-CHARS)
	     (CHARS))
	    (COND ((OR (AND (NULL OPTIONS)
			    (NOT (*COMPLETING-READ-NULL-ERROR COMPLETION)))
		       (= (LENGTH OPTIONS) 1.)
		       (NOT (*COMPLETING-READ-AMBIGUITY-ERROR COMPLETION)))
		   (COND ((AND (NOT (= CHAR 13.))
			       (= (LENGTH OPTIONS) 1.))
			  (*COMPLETING-READ-SHOW-COMPLETION COMPLETION)))
		   (TYO CHAR (*COMPLETING-READ-OUTSTREAM COMPLETION))
		   (*THROW 'COMPLETING-READ-EXIT
			   (CONS (CONS
				  CHAR
				  (*COMPLETING-READ-CHARS-READ COMPLETION))
				 OPTIONS))))
	    (SETQ NUMBER-OF-CHARS
		  (LENGTH (SETQ CHARS
				(*COMPLETING-READ-CHARS-READ COMPLETION))))
	    (MAPC (LAMBDA (X)
			  (COND ((= (FLATC X) NUMBER-OF-CHARS)
				 (TYO CHAR
				      (*COMPLETING-READ-OUTSTREAM COMPLETION))
				 (*THROW 'COMPLETING-READ-EXIT
					 (LIST (CONS CHAR CHARS) X)))))
		  OPTIONS)
	    (TYO 7. (*COMPLETING-READ-OUTSTREAM COMPLETION))
	    (*COMPLETING-READ-ATTEMPT-COMPLETION COMPLETION)))

(DEFUN *COMPLETING-READ-DISPLAY-OPTIONS (COMPLETION)
       (LET ((OUTSTREAM (*COMPLETING-READ-OUTSTREAM COMPLETION))
	     (OPTIONS (CAR (*COMPLETING-READ-OPTIONS COMPLETION))))
	    (CURSORPOS 'A OUTSTREAM)
	    (COND ((NOT OPTIONS)
		   (PRINC '|No options match.| OUTSTREAM))
		  ((= (LENGTH OPTIONS) 1.)
		   (PRINC '|Unambiguous match: | OUTSTREAM)
		   (PRINC (CAR OPTIONS) OUTSTREAM))
		  (T
		   (PRINC '|Options are: | OUTSTREAM)
		   (PRINC (CAR OPTIONS) OUTSTREAM)
		   (DO ((L (CDR OPTIONS) (CDR L)))
		       ((NULL L))
		       (PRINC '|, | OUTSTREAM)
		       (COND ((> (+ (FLATC (CAR L)) (CHARPOS OUTSTREAM)) 67.)
			      (TERPRI OUTSTREAM)
			      (TYO 9. OUTSTREAM)))
		       (PRINC (CAR L) OUTSTREAM))))))

(DEFUN *COMPLETING-READ-ATTEMPT-COMPLETION (COMPLETION)
       (LET ((OUTSTREAM       (*COMPLETING-READ-OUTSTREAM  COMPLETION))
	     (OPTIONS    (CAR (*COMPLETING-READ-OPTIONS    COMPLETION)))
	     (LEN (1+ (LENGTH (*COMPLETING-READ-CHARS-READ COMPLETION)))))
	    (COND ((NULL OPTIONS)
		   (TYO 7. OUTSTREAM))
		  (T
		   (DO ((I LEN (1+ I))
			(CASE-FUN (*COMPLETING-READ-LAST-CASE COMPLETION))
			(END (FLATC (CAR OPTIONS))))
		       ((OR (> I END)
			    (NOT (*COMPLETING-READ-MATCH-ALL OPTIONS I)))
			(COND ((= I LEN)
			       (TYO 7. OUTSTREAM))))
		       (*COMPLETING-READ-SOFT-TYI
			COMPLETION
			(FUNCALL CASE-FUN (GETCHARN (CAR OPTIONS) I))))))))
							    
(DEFUN *COMPLETING-READ-SHOW-COMPLETION (COMPLETION)
       (LET ((OPTION (CAAR (*COMPLETING-READ-OPTIONS COMPLETION)))
	     (LEN (1+ (LENGTH (*COMPLETING-READ-CHARS-READ COMPLETION)))))
	    (DO ((I LEN (1+ I))
		 (CASE-FUN (*COMPLETING-READ-LAST-CASE COMPLETION))
		 (END (FLATC OPTION)))
		((> I END))
		(*COMPLETING-READ-SOFT-TYI
		 COMPLETION
		 (FUNCALL CASE-FUN (GETCHARN OPTION I))))))

(DEFUN *COMPLETING-READ-MATCH-ALL (OPTIONS I)
       (DO ((C (GETCHARN (CAR OPTIONS) I))
	    (O (CDR OPTIONS) (CDR O)))
	   ((NULL O) T)
	   (COND ((NOT (= C (GETCHARN (CAR O) I)))
		  (RETURN NIL)))))

(EVAL-WHEN (EVAL LOAD)
	(SETQ COMPLETING-READER-OBJECT-HEADER
	      (MAKNAM '(/# C O M P L E T I O N))))

(DEFUN *COMPLETING-READ-OBJECT? (X)
       (AND (NOT (ATOM X))
	    (EQ (CAR X) COMPLETING-READER-OBJECT-HEADER)))

(DEFUN *COMPLETING-READ-OBJECT (OPTIONS PROMPT INSTREAM OUTSTREAM
					AMBIGUITY-ERROR NULL-ERROR
					COMPLETION-CHARS RETURN-CHARS
					CASE-CONVERT OVER-RUBOUT-RETURN-FLAG)
       (HUNK COMPLETING-READER-OBJECT-HEADER
	     (NCONS OPTIONS) ; Options stack
	     PROMPT          ; How to prompt
	     INSTREAM        ; Where to get input from
	     OUTSTREAM       ; Where to output echo
	     AMBIGUITY-ERROR ; Is ambiguity an error?
	     NULL-ERROR      ; Is null choice an error?
	     COMPLETION-CHARS; Chars that complete 
	     RETURN-CHARS    ; Chars that cause a return
	     CASE-CONVERT    ; Should lowercase chars convert?
	     (LAMBDA (X) X)  ; What case to do completions in 
	     OVER-RUBOUT-RETURN-FLAG   ; Return if over-rubout occurs?
	     ()              ; Stack of chars read
	     ))

(DEFUN *COMPLETING-READ-OPTIONS X
       (COND ((= X 1.) (CXR 2. (ARG 1.)))
	     (T (RPLACX 2. (ARG 1.) (ARG 2.)))))

(DEFUN *COMPLETING-READ-PROMPT X
       (COND ((= X 1.) (CXR 3. (ARG 1.)))
	     (T (RPLACX 3. (ARG 1.) (ARG 2.)))))

(DEFUN *COMPLETING-READ-INSTREAM X
       (COND ((= X 1.) (CXR 4. (ARG 1.)))
	     (T (RPLACX 4. (ARG 1.) (ARG 2.)))))

(DEFUN *COMPLETING-READ-OUTSTREAM X
       (COND ((= X 1.) (CXR 5. (ARG 1.)))
	     (T (RPLACX 5. (ARG 1.) (ARG 2.)))))

(DEFUN *COMPLETING-READ-AMBIGUITY-ERROR X
       (COND ((= X 1.) (CXR 6. (ARG 1.)))
	     (T (RPLACX 6. (ARG 1.) (ARG 2.)))))

(DEFUN *COMPLETING-READ-NULL-ERROR X
       (COND ((= X 1.) (CXR 7. (ARG 1.)))
	     (T (RPLACX 7. (ARG 1.) (ARG 2.)))))

(DEFUN *COMPLETING-READ-COMPLETION-CHARS X
       (COND ((= X 1.) (CXR 8. (ARG 1.)))
	     (T (RPLACX 8. (ARG 1.) (ARG 2.)))))

(DEFUN *COMPLETING-READ-RETURN-CHARS X
       (COND ((= X 1.) (CXR 9. (ARG 1.)))
	     (T (RPLACX 9. (ARG 1.) (ARG 2.)))))

(DEFUN *COMPLETING-READ-CASE-CONVERT X
       (COND ((= X 1.) (CXR 10. (ARG 1.)))
	     (T (RPLACX 10. (ARG 1.) (ARG 2.)))))

(DEFUN *COMPLETING-READ-LAST-CASE X
       (COND ((= X 1.) (CXR 11. (ARG 1.)))
	     (T (RPLACX 11. (ARG 1.) (ARG 2.)))))

(DEFUN *COMPLETING-READ-OVERRUBOUT-RETURN X
       (COND ((= X 1.) (CXR 12. (ARG 1.)))
	     (T (RPLACX 12. (ARG 1.) (ARG 2.)))))

(DEFUN *COMPLETING-READ-CHARS-READ X
       (COND ((= X 1.) (CXR 0. (ARG 1.)))
	     (T (RPLACX 0. (ARG 1.) (ARG 2.)))))

(DEFUN *COMPLETING-READ-RESET-COMPLETION (OBJECT)
       (*COMPLETING-READ-OPTIONS    OBJECT
				    (LAST (*COMPLETING-READ-OPTIONS OBJECT)))
       (*COMPLETING-READ-CHARS-READ OBJECT ()))

(DEFUN *COMPLETING-READ-PUSH-COMPLETION (CHAR OBJECT)
       (LET ((OPTS  (*COMPLETING-READ-OPTIONS    OBJECT))
	     (CHARS (*COMPLETING-READ-CHARS-READ OBJECT)))
	    (COND ((*COMPLETING-READ-CASE-CONVERT OBJECT)
		   (SETQ CHAR (*COMPLETING-READ-UPPERCASIFY CHAR))))
	    (*COMPLETING-READ-OPTIONS OBJECT
				      (CONS
				       (*COMPLETING-READ-PROCESS-OPTIONS
					CHAR
					(CAR OPTS)
					(1+ (LENGTH CHARS)))
				       OPTS))
	    (*COMPLETING-READ-CHARS-READ OBJECT (CONS CHAR CHARS))))

(DEFUN *COMPLETING-READ-UPPERCASIFY (X)
       (COND ((AND (> X 96.) (< X 123.)) (- X 32.))
	     (T X)))

(DEFUN *COMPLETING-READ-LOWERCASIFY (X)
       (COND ((AND (> X 64.) (< X 91.)) (+ X 32.))
	     (T X)))

(DEFUN *COMPLETING-READ-POP-COMPLETION (OBJECT)
       (LET ((CHARS (*COMPLETING-READ-CHARS-READ OBJECT)))
	    (COND (CHARS
		   (*COMPLETING-READ-OPTIONS
		    OBJECT
		    (CDR (*COMPLETING-READ-OPTIONS OBJECT)))
		   (*COMPLETING-READ-CHARS-READ OBJECT (CDR CHARS))
		   (CAR CHARS))
		  (T
		   NIL))))

(DEFUN *COMPLETING-READ-PROCESS-OPTIONS (CHAR OPTIONS N)
       (DO ((L OPTIONS (CDR L))
	    (NEW-L ()))
	   ((NULL L) (NREVERSE NEW-L))
	   (COND ((= (GETCHARN (CAR L) N) CHAR)
		  (PUSH (CAR L) NEW-L)))))

;;; (COMPLETING-READ-LINE (<prompt1> <option1[1]> <option1[2]> ...)
;;;			  (<prompt2> <option2[1]> <option2[2]> ...) ...)
;;; Prints <prompt1> and reads words on a single line returning NIL if
;;; over-rubout and (<option1-choice> <option2-choice> ... <optionN-choice>)
;;; if sucessful. <prompt2> ... <promptN> are only used if the user types
;;; <CR> to terminate the option before that. If he types <space> instead
;;; he will not be prompted. Ambiguous or null responses are not allowed.

(DEFUN (COMPLETING-READ-LINE MACRO) (X)
       `(*COMPLETING-READ-LINE1 ',(CDR X)))

(DEFUN *COMPLETING-READ-LINE1 (PROMPT-ALIST)
       (CURSORPOS 'A TYO)
       (*CATCH 'COMPLETING-READ-LINE-EXIT
	       (*COMPLETING-READ-LINE1-AUX (CAAR PROMPT-ALIST)
					   PROMPT-ALIST
					   NIL
					   T)))

(DEFUN *COMPLETING-READ-LINE1-AUX (PROMPT PROMPT-ALIST VALUES PROMPTFLAG)
       (COND ((NULL PROMPT-ALIST)
	      (*THROW 'COMPLETING-READ-LINE-EXIT
		      (NREVERSE VALUES)))
	     (T
	      (COND (PROMPTFLAG (PRINC (CAAR PROMPT-ALIST) TYO)))
	      (DO ((VAL)
		   (CHARS NIL))
		  (NIL)
		  (SETQ VAL
			(*COMPLETING-READ1 PROMPT		; Prompt
					   (CDAR PROMPT-ALIST)  ; Options
					   CHARS		; Chars read
					   TYI			; Instream
					   TYO			; Outstream
					   T			; Ambiguity 
					   T			; Null 
					   '(27.)		; Completion
					   '(32. 13.)		; Return chars
					   T			; Case
					   T))			; Over-rubout
		  (COND ((EQ VAL 'OVER-RUBOUT)
			 (RETURN NIL))
			((EQ VAL 'LINE-RUBOUT)
			 (*THROW 'COMPLETING-READ-LINE-EXIT NIL))
			((EQ VAL 'WORD-RUBOUT)
			 (CURSORPOS 'A TYO)
			 (PRINC PROMPT TYO)
			 (RETURN NIL)))
		  (SETQ CHARS (REVERSE (CAR VAL)))
		  (*COMPLETING-READ-LINE1-AUX
		   (MAKNAM (NCONC (EXPLODEN PROMPT) CHARS))
		   (CDR PROMPT-ALIST)
		   (CONS (CADR VAL) VALUES)
		   (= (CAAR VAL) 13.))
		  (SETQ CHARS (REVERSE (CDAR VAL)))
		  (COND ((= (CAAR VAL) 13.)
			 (CURSORPOS 'A TYO)
			 (PRINC PROMPT TYO)
			 (MAPC (LAMBDA (X) (TYO X TYO)) CHARS))
			(T
			 (COND ((MEMQ 'RUBOUT (STATUS FILEM TYO))
				(CURSORPOS 'X TYO))
			       (T
				(PRINC '|\ | TYO)))))))))

(SSTATUS FEATURE COMPLETING-READER-PACKAGE)