; File: EDIT.LSP  (C)		01/06/86	   Soft Warehouse, Inc.


(LOOP (PRIN1 (QUOTE *)) (EVAL (READ)) ((NULL RDS)) )

(SETQ *CASE-IGNORE* NIL)

(DEFUN EDIT (*FILE-NAME*
    *BASE-ROW* *BASE-COL* *ROWS* *COLUMNS*
    *ABOVE-POINT* *BELOW-POINT* *LEFT-POINT* *RIGHT-POINT*
    *CURSOR-ROW* *CURSOR-COL* *POINT-ROW* *POINT-COL*
    *START-ROW* *START-COL* *END-ROW* *END-COL*
    *LAST-ROW* *LAST-COL* *FIND-ROW* *FIND-COL*
    *TEMP-ROW* *TEMP-COL* *FIND-STRG* *REPL-STRG*
    *EVAL-ROW* *DELETED-TEXT* *PAGE-ROWS*
    *SCREEN* *FULL-WINDOW* *WINDOW-SHAPE* *INSERT*
    *STAT-RC* *STAT-END* *STAT-ROW* *STAT-COL* *STAT-INS* *STAT-WINDOW*
    *UNPACKED* *TEXT-DIRTY* CHAR *AUTO-NEWLINE* READ-CHAR RDS )
  (SETQ *FULL-WINDOW* (MAKE-WINDOW)
	*INSERT* T
	*WINDOW-SHAPE* 'F)
  (MAKE-SCREEN)
  ( ((IDENTITY *FILE-NAME*))
    (SETQ *FILE-NAME* (INPUTFILE)) )
  (SETQ *FIND-STRG* *NUL-STRG* *REPL-STRG* *NUL-STRG*)
  (COPY-CHAR-TYPE (ASCII 27) 'A)
  (UNWIND-PROTECT (LOOP
    ( ((NULL *FILE-NAME*)
	(LOOP
	  (CLEAR-STAT)
	  (SETQ CHAR (PROMPT-READ-CHAR '(E P S L Q)
			" Edit, Print, Screen, Lisp, Quit: "))
	  ((EQ CHAR 'Q))
	  ( ((EQ CHAR 'E)
	      (SETQ *FILE-NAME* (PROMPT-FILE " Edit file: ")) )
	    ((EQ CHAR 'P)
	      (PRINT-FILE (PROMPT-FILE " Print file: ")) )
	    ((EQ CHAR 'S)
	      (WINDOW-SHAPE-AUX) )
	    ((EQ CHAR 'L)
	      (EVAL-LISP) ) )
	  ((AND *FILE-NAME* (NEQ *FILE-NAME* *NUL-STRG*))) ) ) )
    ((EQ CHAR 'Q))
    (SETQ *BELOW-POINT* NIL *ABOVE-POINT* NIL	;Clear before read
	*BELOW-POINT* (READ-FILE *FILE-NAME*)
	*CURSOR-ROW* 0 *CURSOR-COL* 0
	*POINT-ROW* 0 *POINT-COL* 0
	*UNPACKED* NIL *TEXT-DIRTY*)
    (MARK-LAST)
    (MARK-FIND)
    (MARK-TEMP)
    (MARK-START)
    (MARK-END)
    (CATCH 'QUIT-EDIT (LOOP
      (UPDATE-SCRN)
      (SET-CURSOR *CURSOR-ROW* *CURSOR-COL*)
      (SETQ CHAR (READ-CHAR))
      ( ((GET CHAR 'EDIT-CHAR)
	  (FUNCALL (GET CHAR 'EDIT-CHAR) CHAR) )
	((<= 32 (ASCII CHAR) 126)
	  (ADD-CHAR CHAR) ) ) ) )
    (WRS (FIND "EDIT$.TMP" (OPENFILES) 'FINDSTRING))
    (WRS) )
  (COPY-CHAR-TYPE (ASCII 27) (ASCII 27))	;Restore ESC interrupts
  (APPLY 'MAKE-WINDOW *FULL-WINDOW*)
  (SET-CURSOR (SUB1 (CADDR *FULL-WINDOW*)) 0) ) )

(DEFUN EDIT-PAIR (CHAR
    EDIT-CHAR NUM )
  (STAT-WINDOW)
  (PRINC '\^)
  (PRINC (SETQ EDIT-CHAR (ASCII (+ (ASCII CHAR) 64))))
  (EDIT-WINDOW)
  (SETQ CHAR 60)		;Prompt display delay time
  (LOOP
    (SETQ NUM 30)
    ((LISTEN))
    (LOOP
      ((ZEROP (DECQ NUM))) )
    ((ZEROP (DECQ CHAR))
      ((GET EDIT-CHAR 'PROMPT)
	(CLEAR-STAT)
	(PRINC (GET EDIT-CHAR 'PROMPT))
	(SETQ NUM) ) ) )
  (SETQ CHAR (STRING-UPCASE (READ-CHAR)))
  (IF (< (ASCII CHAR) 32)
	(SETQ CHAR (ASCII (+ (ASCII CHAR) 64))) )
  ( ((NULL NUM)
      (PRINC CHAR) )
    (STAT-WINDOW)
    (SET-CURSOR 0 2)
    (PRINC CHAR) )
  (EDIT-WINDOW)
  (IF (GET CHAR EDIT-CHAR)
      (FUNCALL (GET CHAR EDIT-CHAR) CHAR) )
  ((NULL NUM))
  (STAT-WINDOW)
  (SPACES 3)
  (EDIT-WINDOW) )

(DEFUN EVAL-LISP ()
  (EVAL-EXPN '(DRIVER)) )

(DEFUN EVAL-EXPN (EXPN
    READ-CHAR RECLAIM *AUTO-NEWLINE* RDS WRS )
  (EVAL-WINDOW)
  (SETQ READ-CHAR T  RECLAIM T  *AUTO-NEWLINE* T)
  (COPY-CHAR-TYPE (ASCII 27) (ASCII 27))	;Restore interrupts
  (PRINT (CATCH NIL (EVAL EXPN)))
  (COPY-CHAR-TYPE (ASCII 27) 'A)		;Disable interrupts
  (SETQ *EVAL-ROW* (ROW)
	*AUTO-NEWLINE*)
  (IF (OR (EQ *WINDOW-SHAPE* 'F)
	  (NEQ 2 (CSMEMORY 855)) )		;IBM PC test
      (MAKE-SCREEN) )
  (EDIT-WINDOW) )


;	* * *   Cursor line movement functions   * * *

(DEFUN UP-LINE ()		;Move up a line
  ((ZEROP *POINT-ROW*))
  (JUMP-POSN (SUB1 *POINT-ROW*) *POINT-COL*) )

(DEFUN DOWN-LINE ()		;Move down a line
  (JUMP-POSN (ADD1 *POINT-ROW*) *POINT-COL*) )

(DEFUN TOP-ROW ()		;Move to top row
  ((ZEROP *CURSOR-ROW*))
  (MARK-LAST)
  (JUMP-POSN (- *POINT-ROW* *CURSOR-ROW*) *POINT-COL*) )

(DEFUN BOTTOM-ROW ()		;Move to bottom row
  ((EQ *CURSOR-ROW* (- *ROWS* 2)))
  (MARK-LAST)
  (JUMP-POSN (+ *POINT-ROW* (- *ROWS* *CURSOR-ROW*) -2) *POINT-COL*) )

(DEFUN SCROLL-DOWN-LINE ()	;Scroll text down a line
  ((EQ *POINT-ROW* *CURSOR-ROW*))
  (SCRN-DOWN 0)
  ((EQ *CURSOR-ROW* (- *ROWS* 2))
    (POINT-TO-ROW (SUB1 *POINT-ROW*)) )
  (INCQ *CURSOR-ROW*) )

(DEFUN SCROLL-UP-LINE ()	;Scroll text up a line
  (SCRN-UP 0)
  ((ZEROP *CURSOR-ROW*)
    (POINT-TO-ROW (ADD1 *POINT-ROW*)) )
  (DECQ *CURSOR-ROW*) )

(DEFUN SCROLL-DOWN-SCRN ()	;Scroll text down a screenful
  (MARK-LAST)
  ((< (- *POINT-ROW* *CURSOR-ROW*) *PAGE-ROWS*)
    (JUMP-POSN (MAX 0 (- *POINT-ROW* *PAGE-ROWS*)) *POINT-COL*) )
  (POINT-TO-ROW (- *POINT-ROW* *PAGE-ROWS*)) )

(DEFUN SCROLL-UP-SCRN ()	;Scroll text up a screenful
  (MARK-LAST)
  (POINT-TO-ROW (+ *POINT-ROW* *PAGE-ROWS*)) )

(DEFUN START-TEXT ()		;Move to start of text
  (MARK-LAST)
  (JUMP-POSN 0 0) )

(DEFUN END-TEXT ()		;Move to end of text
  (MARK-LAST)
  (PACK-LINE)
  (JUMP-POSN (+ *POINT-ROW* (LENGTH *BELOW-POINT*)) 0) )

(DEFUN DOWN-LINE-INDENT (	;Move down a line and indent
    COL NUM )
  (MARK-LAST)
  (LEFT-END)
  (DOWN-LINE)
  (UNPACK-LINE)
  ((AND (NULL *RIGHT-POINT*) (NOT (EQ (CAR *ABOVE-POINT*) *NUL-STRG*)))
    (SETQ *RIGHT-POINT* (UNPACK (CAR *ABOVE-POINT*))
	  NUM (* 2 (- (COUNT *LPAR* *RIGHT-POINT*) (COUNT *RPAR* *RIGHT-POINT*)))
	  COL (POSITION-IF 'NON-WHITESPACE *RIGHT-POINT*))
    (IF (MINUSP NUM) (SETQ COL (MAX 0 (+ COL NUM))
			   NUM 0) )
    (IF (ZEROP COL)
	  (SETQ *RIGHT-POINT*)
	  (RPLACD (NTHCDR (SUB1 COL) *RIGHT-POINT*)) )
    (JUMP-POSN *POINT-ROW* COL)
    (LOOP
      ((ZEROP NUM))
      (ADD-CHAR *BLANK*)
      (DECQ NUM) ) )
  ((SETQ COL (POSITION-IF 'NON-WHITESPACE *RIGHT-POINT*))
    (JUMP-POSN *POINT-ROW* COL) ) )

(DEFUN JUMP-LAST (
    ROW COL )
  (SETQ ROW *POINT-ROW* COL *POINT-COL*)
  (JUMP-POSN *LAST-ROW* *LAST-COL*)
  (SETQ *LAST-ROW* ROW *LAST-COL* COL) )

(DEFUN MARK-LAST ()
  (SETQ *LAST-ROW* *POINT-ROW* *LAST-COL* *POINT-COL*) )


;	* * *   Cursor column movement functions   * * *

(DEFUN LEFT-CHAR ()		;Move left a character & PREDICATE
  ((ZEROP *POINT-COL*)
    ((ZEROP *POINT-ROW*) NIL)
    (UP-LINE)
    (RIGHT-END)
    T )
  (JUMP-POSN *POINT-ROW* (SUB1 *POINT-COL*))
  T )

(DEFUN RIGHT-CHAR ()		;Move right a character
  (UNPACK-LINE)
  ((BLANK-LINE *RIGHT-POINT*)
    (LEFT-END)
    (DOWN-LINE) )
  (JUMP-POSN *POINT-ROW* (ADD1 *POINT-COL*)) )

(DEFUN LEFT-END ()		;Move to left end
  ((ZEROP *POINT-COL*))
  (JUMP-POSN *POINT-ROW* 0) )

(DEFUN RIGHT-END ()		;Move to right end
  (UNPACK-LINE)
  (JUMP-POSN *POINT-ROW* (+ *POINT-COL* (LENGTH (TRIM-LINE *RIGHT-POINT*)))) )

(DEFUN LEFT-TAB ()		;Move left to tab stop
  (LOOP
    (LEFT-CHAR)
    ((ZEROP (REM *POINT-COL* 8))) ) )

(DEFUN LEFT-WORD (		;Move left a word & PREDICATE
    COL )
  ((ZEROP *POINT-COL*)
    (LEFT-CHAR) )
  (LEFT-CHAR)
  ((ZEROP *POINT-COL*))
  (UNPACK-LINE)
  ((OR (NULL *RIGHT-POINT*) (WHITESPACE (CAR *RIGHT-POINT*)))
    ((WORD-DELIMITER (CAR *LEFT-POINT*))
      ((NON-WHITESPACE (CAR *LEFT-POINT*))
	(LEFT-CHAR) )
      ((SETQ COL (POSITION-IF 'NON-WHITESPACE *LEFT-POINT*))
	(JUMP-POSN *POINT-ROW* (- *POINT-COL* COL)) )
      (LEFT-END) )
    ((SETQ COL (POSITION-IF 'WORD-DELIMITER *LEFT-POINT*))
      (JUMP-POSN *POINT-ROW* (- *POINT-COL* COL)) )
    (LEFT-END) )
  ((SETQ COL (POSITION-IF 'WORD-DELIMITER *LEFT-POINT*))
    (JUMP-POSN *POINT-ROW* (- *POINT-COL* COL)) )
  (LEFT-END) )

(DEFUN RIGHT-WORD (		;Move right a word
    COL NUM )
  (UNPACK-LINE)
  ((BLANK-LINE *RIGHT-POINT*)
    (LEFT-END)
    (DOWN-LINE)
    (UNPACK-LINE)
    ((SETQ COL (POSITION-IF 'NON-WHITESPACE *RIGHT-POINT*))
      (JUMP-POSN *POINT-ROW* COL) )
    (RIGHT-END) )
  ((AND (SETQ COL (POSITION-IF 'WORD-DELIMITER (CDR *RIGHT-POINT*)))
	(SETQ NUM (POSITION-IF 'NON-WHITESPACE
			       (NTHCDR COL (CDR *RIGHT-POINT*)))))
    (JUMP-POSN *POINT-ROW* (+ *POINT-COL* COL NUM 1)) )
  (RIGHT-END) )


;	* * *   Text insertion functions   * * *

(DEFUN ADD-CHAR (CHAR		;Add new character to line
    SCREEN )
  (UNPACK-LINE)
  ( ((NULL *RIGHT-POINT*)
      (SETQ *TEXT-DIRTY* T
	    *RIGHT-POINT* (LIST CHAR)) )
    ((NULL *INSERT*)
      ((EQ (CAR *RIGHT-POINT*) CHAR))
      (SETQ *TEXT-DIRTY* T)
      (RPLACA *RIGHT-POINT* CHAR) )
    (SETQ *TEXT-DIRTY* T)
    (ADJUST-COL 1)
    (SETQ *RIGHT-POINT* (ADJUST-TAB (ADD1 *POINT-COL*) *RIGHT-POINT*))
    (PUSH CHAR *RIGHT-POINT*) )
  (SET-CURSOR *CURSOR-ROW* *CURSOR-COL*)
  (WRITE-STRING CHAR)
  (SETQ SCREEN (NTHCDR *CURSOR-ROW* *SCREEN*))
  (IF (ATOM (CAR SCREEN))
	(RPLACA SCREEN (NCONC (UNPACK (CAR SCREEN))
		(MAKE-LIST (- *COLUMNS* (LENGTH (CAR SCREEN))) *BLANK*))) )
  (RPLACA (NTHCDR *CURSOR-COL* (CAR SCREEN)) CHAR)
  (JUMP-POSN *POINT-ROW* (ADD1 *POINT-COL*)) )

(DEFUN ESCAPE-CHAR (		;Add escape character
    CHAR )
  ((EQ (SETQ CHAR (READ-CHAR)) *TAB*)
    (LOOP
      ((EQ (REM *POINT-COL* 8) 7)
	(ADD-CHAR *TAB*) )
      (ADD-CHAR *BLANK*) ) )
  (ADD-CHAR CHAR) )

(DEFUN INSERT-LINE ()		;Insert a new line
  (SETQ *TEXT-DIRTY* T)
  (UNPACK-LINE)
  (ADJUST-ROW 1)
  (PUSH (PACK (ADJUST-TAB 0 *RIGHT-POINT*)) *BELOW-POINT*)
  (SETQ *RIGHT-POINT*)
  ((ZEROP *POINT-COL*)
    (SCRN-DOWN *CURSOR-ROW*) )
  (SCRN-DOWN (ADD1 *CURSOR-ROW*)) )

(DEFUN NEW-LINE ()		;Move to left end and down a line
  ( ((NULL *INSERT*))
    (INSERT-LINE) )
  (LEFT-END)
  (DOWN-LINE) )

(DEFUN RIGHT-TAB ()		;Move right to tab stop
  ((NULL *INSERT*)
    (UNPACK-LINE)
    (LOOP
      ((BLANK-LINE *RIGHT-POINT*)
	(LOOP
	  ((EQ (REM *POINT-COL* 8) 7)
	    (ADD-CHAR *TAB*) )
	  (ADD-CHAR *BLANK*) ) )
      (JUMP-POSN *POINT-ROW* (ADD1 *POINT-COL*))
      ((ZEROP (REM *POINT-COL* 8))) ) )
  (LOOP
    ((EQ (REM *POINT-COL* 8) 7)
      (ADD-CHAR *TAB*) )
    (ADD-CHAR *BLANK*) ) )

(DEFUN INSERT-MODE ()		;Toggle INSERT/REPLACE mode
  (SETQ *INSERT* (NOT *INSERT*))
  (SETQ *STAT-INS*) )


;	* * *   Text deletion functions   * * *

(DEFUN DEL-RIGHT-CHAR ()		;Delete character under cursor
  (UNPACK-LINE)
  ((BLANK-LINE *RIGHT-POINT*)
    (DEL-CRLF) )
  (DEL-CHAR) )

(DEFUN DEL-LEFT-CHAR ()		;Delete character to left of cursor
  (UNPACK-LINE)
  ((LEFT-CHAR)
    (UNPACK-LINE)
    ((NULL *RIGHT-POINT*)
      (DEL-CRLF) )
    (DEL-CHAR) ) )

(DEFUN DEL-RIGHT-END ()		;Delete right end of line
  (UNPACK-LINE)
  ((NULL *RIGHT-POINT*))
  (SETQ *TEXT-DIRTY* T
	*RIGHT-POINT*) )

(DEFUN DEL-LEFT-END (		;Delete left end of line
    COL )
  ((ZEROP *POINT-COL*))
  (SETQ *TEXT-DIRTY* T
	COL *POINT-COL*)
  (LEFT-END)
  (UNPACK-LINE)
  (SETQ *RIGHT-POINT* (ADJUST-TAB *POINT-COL* (NTHCDR COL *RIGHT-POINT*))) )

(DEFUN DEL-RIGHT-WORD ()	;Delete word under cursor
  (UNPACK-LINE)
  ((BLANK-LINE *RIGHT-POINT*)
    (DEL-CRLF) )
  ((WHITESPACE (CAR *RIGHT-POINT*))
    (LOOP
      (DEL-CHAR)
      ((NON-WHITESPACE (CAR *RIGHT-POINT*))) ) )
  ((WORD-DELIMITER (CAR *RIGHT-POINT*))
    (DEL-CHAR) )
  (LOOP
    ((WORD-DELIMITER (CAR *RIGHT-POINT*))
      ((OR (ZEROP *POINT-COL*) (WHITESPACE (CAR *LEFT-POINT*)))
	(LOOP
	  ((NULL *RIGHT-POINT*))
	  ((NON-WHITESPACE (CAR *RIGHT-POINT*)))
	  ((AND (EQ *TAB* (FIND *BLANK* *RIGHT-POINT* 'NEQ))
	      (< (POSITION *TAB* *RIGHT-POINT*) (- 8 (REM *POINT-COL* 8)))))
	  (ADJUST-COL -1)
	  (SETQ *RIGHT-POINT*
			(ADJUST-TAB *POINT-COL* (CDR *RIGHT-POINT*))) ) ) )
    (DEL-CHAR)
    ((NULL *RIGHT-POINT*)) ) )

(DEFUN DEL-LEFT-WORD ()		;Delete word left of cursor
  ((AND (ZEROP *POINT-ROW*) (ZEROP *POINT-COL*)))
  (UNPACK-LINE)
  (LEFT-WORD)
  (DEL-RIGHT-WORD) )

(DEFUN DEL-LINE ()		;Delete entire line
  (LEFT-END)
  (PACK-LINE)
  ((NULL *BELOW-POINT*))
  (SETQ *TEXT-DIRTY* T)
  (ADJUST-ROW -1)
  (SCRN-UP *CURSOR-ROW*)
  ((EQ (CAR *BELOW-POINT*) *NUL-STRG*)
    (POP *BELOW-POINT*) )
  (SETQ *DELETED-TEXT* (LIST (POP *BELOW-POINT*) *NUL-STRG*)) )

(DEFUN DEL-CRLF ()
  ((NULL *BELOW-POINT*))
  ((ZEROP *POINT-COL*)
    (DEL-LINE) )
  (SETQ *TEXT-DIRTY* T)
  (ADJUST-ROW-COL *POINT-COL*)
  (ADJUST-ROW -1)
  (SCRN-UP (ADD1 *CURSOR-ROW*))
  (SETQ *RIGHT-POINT* (ADJUST-TAB *POINT-COL* (UNPACK (POP *BELOW-POINT*)))) )

(DEFUN DEL-CHAR ()
  (SETQ *TEXT-DIRTY* T)
  ((AND (EQ *TAB* (FIND *BLANK* *RIGHT-POINT* 'NEQ))
	(< (POSITION *TAB* *RIGHT-POINT*) (- 8 (REM *POINT-COL* 8))))
    (ADJUST-COL (- -1 (POSITION *TAB* *RIGHT-POINT*)))
    (SETQ *RIGHT-POINT* (ADJUST-TAB *POINT-COL*
				    (CDR (MEMBER *TAB* *RIGHT-POINT*)))) )
  (ADJUST-COL -1)
  (SETQ *RIGHT-POINT* (ADJUST-TAB *POINT-COL* (CDR *RIGHT-POINT*))) )


;	* * *   Search and replace functions   * * *

 (DEFUN FIND-STRG ()		;Find string
  (SETQ *FIND-STRG* (PROMPT-READ-LINE " Find string: ")
	*REPL-STRG* *FIND-STRG*)
  (FIND-NEXT) )

(DEFUN REPL-STRG ()		;Find and replace string once
  (SETQ *FIND-STRG* (PROMPT-READ-LINE " Find string: ")
	*REPL-STRG* (PROMPT-READ-LINE " Replace with: "))
  (FIND-NEXT) )

(DEFUN REPL-ALL ()		;Find and replace string all
  (LOOP
    ((NULL (FIND-NEXT))) ) )

(DEFUN FIND-NEXT (		;Find (and replace) next string & PREDICATE
    TEXT ROW COL )
  (EDIT-WINDOW)
  ((EQ *FIND-STRG* *NUL-STRG*) NIL)
  (MARK-FIND)
  (UNPACK-LINE)
  ((SETQ COL (IF *CASE-IGNORE*
	(FINDSTRING (STRING-UPCASE *FIND-STRG*)
		    (STRING-UPCASE (PACK (CDR *RIGHT-POINT*))))
	(FINDSTRING *FIND-STRG* (PACK (CDR *RIGHT-POINT*)))))
    (JUMP-POSN *POINT-ROW* (+ *POINT-COL* COL 1))
    (REPL-NEXT) )
  (SETQ TEXT *BELOW-POINT*
	ROW *POINT-ROW*)
  (LOOP
    ((NULL TEXT)
      (END-TEXT) NIL )
    (INCQ ROW)
    ((SETQ COL (IF *CASE-IGNORE*
	(FINDSTRING (STRING-UPCASE *FIND-STRG*) (STRING-UPCASE (POP TEXT)))
	(FINDSTRING *FIND-STRG* (POP TEXT))))
      (JUMP-POSN ROW COL)
      (REPL-NEXT) ) ) )

(DEFUN REPL-NEXT (		;Find and replace next string & PREDICATE
    TEXT-LINE *BLINK* CHAR)
  ((EQ *FIND-STRG* *REPL-STRG*) NIL)
  (UPDATE-SCRN)
  (CLEAR-STAT)
  (WRITE-STRING " Replace string (Y/N/Q)")
  (SETQ *BLINK* T)
  (PRINC '?)
  (SETQ *BLINK*)
  (EDIT-WINDOW)
  ((EQ (SETQ CHAR (STRING-UPCASE (READ-CHAR))) 'Q) NIL)
  ((NEQ CHAR 'Y))
  (SETQ *TEXT-DIRTY* T)
  (UNPACK-LINE)
  (ADJUST-COL (- (LENGTH *REPL-STRG*) (LENGTH *FIND-STRG*)))
  (SETQ *RIGHT-POINT* (ADJUST-TAB *POINT-COL* (NCONC (UNPACK *REPL-STRG*)
			     (NTHCDR (LENGTH *FIND-STRG*) *RIGHT-POINT*))))
  (JUMP-POSN *POINT-ROW* (+ *POINT-COL* (LENGTH *REPL-STRG*))) )

(DEFUN JUMP-FIND ()
  (MARK-LAST)
  (JUMP-POSN *FIND-ROW* *FIND-COL*) )

(DEFUN MARK-FIND ()
  (SETQ *FIND-ROW* *POINT-ROW* *FIND-COL* *POINT-COL*) )


;	* * *   Block operation functions   * * *

(DEFUN MARK-START ()
  (SETQ *START-ROW* *POINT-ROW* *START-COL* *POINT-COL*) )

(DEFUN JUMP-START ()
  (MARK-LAST)
  (JUMP-POSN *START-ROW* *START-COL*) )

(DEFUN MARK-END ()
  (SETQ *END-ROW* *POINT-ROW* *END-COL* *POINT-COL*) )

(DEFUN JUMP-END ()
  (MARK-LAST)
  (JUMP-POSN *END-ROW* *END-COL*) )

(DEFUN MARK-TEMP ()
  (SETQ *TEMP-ROW* *POINT-ROW* *TEMP-COL* *POINT-COL*) )

(DEFUN JUMP-TEMP ()
  (POINT-TO-POSN *TEMP-ROW* *TEMP-COL*) )

(DEFUN WRITE-BLOCK ()
  (WRITE-FILE (PROMPT-FILE " Write file: ") (TEXT-BLOCK)) )

(DEFUN READ-BLOCK ()
  (INSERT-TEXT (READ-FILE (PROMPT-FILE " Read file: "))) )

(DEFUN UNDELETE ()		;Undo last command
  (INSERT-TEXT *DELETED-TEXT*) )

(DEFUN MOVE-BLOCK ()		;Move block to point
  (INSERT-TEXT (DEL-BLOCK-AUX)) )

(DEFUN COPY-BLOCK ()		;Copy block to point
  (INSERT-TEXT (TEXT-BLOCK)) )

(DEFUN DEL-BLOCK ()		;Delete block
  (IF (OR (> *POINT-ROW* *START-ROW*)
	  (AND (EQ *POINT-ROW* *START-ROW*) (> *POINT-COL* *START-COL*)))
	(JUMP-START) )
  (DEL-BLOCK-AUX) )

(DEFUN DEL-BLOCK-AUX (
    TEXT *SCROLL-FLAG* )
  (SETQ TEXT (GET-BLOCK))
  ((OR (NULL TEXT) (EQUAL TEXT (LIST *NUL-STRG*)))
    (JUMP-TEMP)
    TEXT )
  (SETQ *DELETED-TEXT* TEXT)
  ( ((EQ *START-ROW* *END-ROW*))
    (DEL-RIGHT-END)
    (SETQ *BELOW-POINT* (NTHCDR (- *END-ROW* *START-ROW* 1) *BELOW-POINT*))
    (ADJUST-ROW (- *START-ROW* *END-ROW* -1))
    (DEL-RIGHT-CHAR) )
  (LOOP
    ((>= *START-COL* *END-COL*))
    (DEL-RIGHT-CHAR) )
  (JUMP-TEMP)
  TEXT )

(DEFUN TEXT-BLOCK ()		;Text in block
  (PROG1 (GET-BLOCK) (JUMP-TEMP)) )

(DEFUN GET-BLOCK (
    TEXT )
  (MARK-TEMP)
  (POINT-TO-POSN *START-ROW* *START-COL*)
  (PACK-LINE)
  ((SETQ TEXT (FIRSTN (- *END-ROW* *START-ROW* -1) *BELOW-POINT*))
    (IF (< (LENGTH TEXT) (- *END-ROW* *START-ROW* -1))
	(NCONC TEXT (LIST *NUL-STRG*)) )
    (RPLACA (LAST TEXT) (IF (ZEROP *END-COL*) *NUL-STRG*
		 (SUBSTRING (CAR (LAST TEXT)) 0 (SUB1 *END-COL*))) )
    (RPLACA TEXT (PACK (ADJUST-TAB 0
		 (UNPACK (SUBSTRING (CAR TEXT) *START-COL*)))))
    TEXT ) )

(DEFUN INSERT-TEXT (TEXT	;Insert text at cursor
    *SCROLL-FLAG* )
  ((NULL TEXT))
  (UNPACK-LINE)
  (SETQ *RIGHT-POINT* (ADJUST-TAB *POINT-COL*
		(NCONC (UNPACK (CAR (LAST TEXT))) *RIGHT-POINT*)))
  (INSERT-LINE)
  (SETQ *BELOW-POINT* (NCONC (BUTLAST TEXT) *BELOW-POINT*))
  (ADJUST-ROW (SUB1 (LENGTH TEXT)))
  (DEL-RIGHT-CHAR) )


;	* * *   LISP movement functions   * * *

(DEFUN LEFT-UP-LIST ()		;Move left and up list
  (LEFT-LIST)
  (LEFT-LIST) )

(DEFUN LEFT-SEXP (		;Move cursor left S-expression
    CHAR LINE TEXT ROW COL )
  (PACK-LINE)
  (SETQ LINE (CAR *BELOW-POINT*)  TEXT *ABOVE-POINT*
	ROW *POINT-ROW*  COL *POINT-COL*)
  (LOOP
    ((NULL (SETQ CHAR (GET-LAST-CHAR)))
      (JUMP-POSN 0 0) )
    ((EQ CHAR *LPAR*)
      (JUMP-POSN ROW COL) )
    ((EQ CHAR *RPAR*)
      ((MATCHING-LPAR 1)
	(JUMP-POSN ROW COL) )
      (JUMP-POSN 0 0) )
    ((NON-WHITESPACE CHAR)
      (LOOP
	((ZEROP COL)
	  (JUMP-POSN ROW COL) )
	((MEMBER (GET-LAST-CHAR) *ATOM-DELIMITER*)
	  (JUMP-POSN ROW (ADD1 COL)) ) ) ) ) )

(DEFUN LEFT-LIST (		;Move cursor left list
    LINE TEXT ROW COL )
  (PACK-LINE)
  (SETQ LINE (CAR *BELOW-POINT*)  TEXT *ABOVE-POINT*
	ROW *POINT-ROW*  COL *POINT-COL*)
  ((MATCHING-LPAR 1)
    (JUMP-POSN ROW COL) )
  (JUMP-POSN 0 0) )

(DEFUN MATCHING-LPAR (NUM LISTEN
    CHAR )
  (LOOP
    ((NULL (SETQ CHAR (GET-LAST-CHAR))) NIL)
    ( ((EQ *SINGLE-ESCAPE* (CHAR LINE (SUB1 COL))))
      ((EQ CHAR *LPAR*)
	(DECQ NUM) )
      ((EQ CHAR *RPAR*)
	(INCQ NUM) )
      ((EQ CHAR *MULTIPLE-ESCAPE*)
	(LOOP
	  ((NULL (SETQ CHAR (GET-LAST-CHAR))))
	  ((AND (EQ CHAR *MULTIPLE-ESCAPE*)
		(NEQ *SINGLE-ESCAPE* (CHAR LINE (SUB1 COL))))) ) )
      ((EQ CHAR \")
	(LOOP
	  ((NULL (SETQ CHAR (GET-LAST-CHAR))))
	  ((AND (EQ CHAR \")
		(NEQ *SINGLE-ESCAPE* (CHAR LINE (SUB1 COL))))) ) ) )
    ((NULL CHAR) NIL)
    ((ZEROP NUM))
    ((AND LISTEN (LISTEN)) NIL) ) )

(DEFUN GET-LAST-CHAR ()		;Get last character & PREDICATE
  (LOOP
    ((PLUSP COL)
      ((CHAR LINE (DECQ COL)))
      (GET-LAST-CHAR) )
    ((NULL TEXT) NIL)
    ((MINUSP (DECQ ROW)) NIL)
    (SETQ LINE (POP TEXT)
	  COL (LENGTH LINE)) ) )


(DEFUN RIGHT-UP-LIST ()		;Move right and up list
  (RIGHT-LIST)
  (RIGHT-LIST) )

(DEFUN RIGHT-DOWN-LIST ()	;Move right and down list
  (LOOP
    (UNPACK-LINE)
    ((EQ (CAR *RIGHT-POINT*) *LPAR*)
      (RIGHT-CHAR) )
    ((EQ (CAR *RIGHT-POINT*) *RPAR*))
    ((NULL (RIGHT-SEXP))) ) )

(DEFUN RIGHT-SEXP (		;Move cursor right S-expression & PREDICATE
    CHAR LINE TEXT ROW COL )
  (PACK-LINE)
  (SETQ LINE (CAR *BELOW-POINT*)  TEXT (CDR *BELOW-POINT*)
	ROW *POINT-ROW*  COL *POINT-COL*)
  (LOOP
    ((NULL (SETQ CHAR (GET-NEXT-CHAR)))
      (JUMP-POSN ROW (SUB1 COL)) NIL)
    ((EQ CHAR *RPAR*)
      (SKIP-WS) )
    ((EQ CHAR *LPAR*)
      ((MATCHING-RPAR 1)
	(SKIP-WS) )
      (JUMP-POSN ROW (SUB1 COL)) NIL)
    ((NON-WHITESPACE CHAR)
      (LOOP
	((NULL (CHAR LINE COL))
	  (JUMP-POSN ROW COL) )
	(SETQ CHAR (GET-NEXT-CHAR))
	((OR (EQ CHAR *LPAR*) (EQ CHAR *RPAR*))
	  (JUMP-POSN ROW (SUB1 COL)) )
	((WHITESPACE CHAR)
	  (SKIP-WS) ) ) ) ) )

(DEFUN RIGHT-LIST (		;Move cursor right list
    LINE TEXT ROW COL )
  (PACK-LINE)
  (SETQ LINE (CAR *BELOW-POINT*)  TEXT (CDR *BELOW-POINT*)
	ROW *POINT-ROW*  COL *POINT-COL*)
  ((MATCHING-RPAR 1)
    (SKIP-WS) )
  (JUMP-POSN ROW (SUB1 COL)) )

(DEFUN MATCHING-RPAR (NUM LISTEN
    CHAR )
  (LOOP
    ((AND LISTEN (LISTEN)) NIL)
    ((NULL (SETQ CHAR (GET-NEXT-CHAR))) NIL)
    ( ((EQ CHAR *RPAR*)
	(DECQ NUM) )
      ((EQ CHAR *LPAR*)
	(INCQ NUM) )
      ((EQ CHAR *SINGLE-ESCAPE*)
	(SETQ CHAR (GET-NEXT-CHAR)) )
      ((EQ CHAR *MULTIPLE-ESCAPE*)
	(LOOP
	  ((NULL (SETQ CHAR (GET-NEXT-CHAR))))
	  ((EQ CHAR *MULTIPLE-ESCAPE*))
	  (IF (EQ CHAR *SINGLE-ESCAPE*) (GET-NEXT-CHAR)) ) )
      ((EQ CHAR \")
	(LOOP
	  ((NULL (SETQ CHAR (GET-NEXT-CHAR))))
	  ((EQ CHAR \"))
	  (IF (EQ CHAR *SINGLE-ESCAPE*) (GET-NEXT-CHAR)) ) )
      ((EQ CHAR \;)
	((NULL TEXT)
	  (SETQ CHAR) )
	(INCQ ROW)
	(SETQ LINE (POP TEXT)
	      COL 0) ) )
    ((NULL CHAR) NIL)
    ((AND LISTEN (EQ ROW *ROWS*)) NIL)
    ((ZEROP NUM)) ) )

(DEFUN SKIP-WS (		;Skip whitespace characters
    CHAR )
  (LOOP
    ((NULL (SETQ CHAR (GET-NEXT-CHAR)))
      (JUMP-POSN ROW (SUB1 COL)) )
    ((NON-WHITESPACE CHAR)
      (JUMP-POSN ROW (SUB1 COL)) ) ) )

(DEFUN GET-NEXT-CHAR ()		;Get next character & PREDICATE
  (LOOP
    ((CHAR LINE COL (INCQ COL)))
    ((NULL TEXT) NIL)
    (INCQ ROW)
    (SETQ LINE (POP TEXT)
	  COL 0) ) )


(DEFUN THIS-DEFN (		;Move cursor to start of this defun
    TEXT ROW )
  (PACK-LINE)
  ((AND (NOT (ZEROP *POINT-COL*)) *BELOW-POINT*
	(NEQ (CHAR (CAR *BELOW-POINT*) 0) '\;)
	(NON-WHITESPACE (CHAR (CAR *BELOW-POINT*) 0)))
    (LEFT-END) )
  (SETQ TEXT *ABOVE-POINT*
	ROW *POINT-ROW* )
  (LOOP
    ((NULL TEXT))
    (DECQ ROW)
    ((AND (NEQ (CAR TEXT) *NUL-STRG*)
	  (NEQ (CHAR (CAR TEXT) 0) '\;)
	  (NON-WHITESPACE (CHAR (CAR TEXT) 0))))
    (POP TEXT) )
  (JUMP-POSN ROW 0) )

(DEFUN NEXT-DEFN (		;Move cursor to start of next defun
    TEXT ROW )
  (PACK-LINE)
  ((NULL *BELOW-POINT*))
  (SETQ TEXT (CDR *BELOW-POINT*)
	ROW *POINT-ROW* )
  (LOOP
    (INCQ ROW)
    ((NULL TEXT))
    ((AND (NEQ (CAR TEXT) *NUL-STRG*)
	  (NEQ (CHAR (CAR TEXT) 0) '\;)
	  (NON-WHITESPACE (CHAR (CAR TEXT) 0))))
    (POP TEXT) )
  (JUMP-POSN ROW 0) )

(DEFUN DEL-SEXP ()		;Delete S-expression
  (MARK-START)
  (RIGHT-SEXP)
  (MARK-END)
  (DEL-BLOCK) )

(DEFUN DEL-DEFN ()		;Delete defun
  (LEFT-END)
  (UNPACK-LINE)
  ( ((AND (NEQ (CAR *RIGHT-POINT*) '\;)
	  (NON-WHITESPACE (CAR *RIGHT-POINT*))))
    (THIS-DEFN) )
  (DEL-SEXP) )

(DEFUN EVAL-SEXP (		;Eval S-expression
    TEXT *SCROLL-FLAG* )
  (MARK-START)
  (RIGHT-SEXP)
  (MARK-END)
  (JUMP-POSN *START-ROW* *START-COL*)
  (SETQ TEXT (TEXT-BLOCK))
  ((OR (NULL TEXT) (EQUAL TEXT (LIST *NUL-STRG*))))
  (WRS "EDIT$.TMP" T)
  (MAPC 'WRITE-LINE TEXT)
  (WRITE-BYTE 26)
  (WRITEPTR 0)
  (SETQ WRS)
  (RDS "EDIT$.TMP")
  (READPTR 0)
  (SETQ TEXT (READ))
  (RDS)
  (EVAL-EXPN TEXT) )


;	* * *   Cursor movement primitives   * * *

(DEFUN JUMP-POSN (ROW COL	;Move cursor & point to ROW and COL
    TOP-ROW )			;Returns a nonNIL value
  ( ((EQ ROW *POINT-ROW*))		;Move cursor to ROW
    (SETQ TOP-ROW (- *POINT-ROW* *CURSOR-ROW*))
    ((< ROW TOP-ROW)
      ((>= ROW (- TOP-ROW (SHIFT *ROWS* -2)))
	(SETQ *CURSOR-ROW* 0
	      TOP-ROW (- TOP-ROW ROW))
	(LOOP
	  (SCRN-DOWN 0)
	  ((ZEROP (DECQ TOP-ROW))) ) )
      (SETQ *CURSOR-ROW* (SHIFT *ROWS* -1)) )
    ((<= ROW (+ TOP-ROW *ROWS* -2))
      (SETQ *CURSOR-ROW* (- ROW TOP-ROW)) )
    ((<= ROW (+ TOP-ROW *ROWS* (SHIFT *ROWS* -2)))
      (SETQ *CURSOR-ROW* (- *ROWS* 2)
	    TOP-ROW (- ROW *CURSOR-ROW* TOP-ROW))
      (LOOP
	(SCRN-UP 0)
	((ZEROP (DECQ TOP-ROW))) ) )
    (SETQ *CURSOR-ROW* (SHIFT *ROWS* -1)) )
  (IF (> *CURSOR-ROW* ROW) (SETQ *CURSOR-ROW* ROW))
  ( ((EQ COL *POINT-COL*))		;Move cursor to COL
    ((< COL (- *POINT-COL* *CURSOR-COL*))
      (SETQ *CURSOR-COL* (+ (REM COL 8) (* 8 (TRUNCATE *COLUMNS* 32)))) )
    ((>= COL (+ (- *POINT-COL* *CURSOR-COL*) *COLUMNS*))
      (SETQ *CURSOR-COL* (+ (REM COL 8) (* 24 (TRUNCATE *COLUMNS* 32)))) )
    (INCQ *CURSOR-COL* (- COL *POINT-COL*)) )
  (IF (> *CURSOR-COL* COL) (SETQ *CURSOR-COL* COL))
  (POINT-TO-POSN ROW COL)
  'T )

(DEFUN POINT-TO-POSN (ROW COL)		;Move point to ROW and COL
  (POINT-TO-ROW ROW)
  (POINT-TO-COL COL) )

(DEFUN POINT-TO-ROW (ROW		;Move point to ROW
    LST1 LST2 )
  ((EQ ROW *POINT-ROW*))
  (PACK-LINE)
  ((< *POINT-ROW* ROW)
    (SETQ LST1 *BELOW-POINT*
	  LST2 (NTHCDR (- ROW *POINT-ROW* 1) LST1))
    ((NULL LST2)
      (SETQ *ABOVE-POINT* (MAKE-LIST
			(- ROW *POINT-ROW* (LENGTH *BELOW-POINT*))
			*NUL-STRG* (NREVERSE *BELOW-POINT* *ABOVE-POINT*))
	    *POINT-ROW* ROW
	    *BELOW-POINT*) )
    (SETQ *BELOW-POINT* (CDR LST2))
    (RPLACD LST2)
    (SETQ *ABOVE-POINT* (NREVERSE LST1 *ABOVE-POINT*)
	  *POINT-ROW* ROW) )
  (SETQ LST1 *ABOVE-POINT*
	LST2 (NTHCDR (- *POINT-ROW* ROW 1) LST1)
	*ABOVE-POINT* (CDR LST2))
  (RPLACD LST2)
  (SETQ *BELOW-POINT* (TRIM-TEXT (NREVERSE LST1 *BELOW-POINT*))
	*POINT-ROW* ROW) )

(DEFUN POINT-TO-COL (COL		;Move point to COL
    LST1 LST2 )
  ((EQ COL *POINT-COL*))
  ((NOT *UNPACKED*)
    (SETQ *POINT-COL* COL) )
  ((< *POINT-COL* COL)
    (SETQ LST1 *RIGHT-POINT*
	  LST2 (NTHCDR (- COL *POINT-COL* 1) LST1))
    ((NULL LST2)
      (SETQ *LEFT-POINT* (MAKE-LIST
			(- COL *POINT-COL* (LENGTH *RIGHT-POINT*))
			*BLANK* (NREVERSE *RIGHT-POINT* *LEFT-POINT*))
	    *POINT-COL* COL
	    *RIGHT-POINT*) )
    (SETQ *RIGHT-POINT* (CDR LST2))
    (RPLACD LST2)
    (SETQ *LEFT-POINT* (NREVERSE LST1 *LEFT-POINT*)
	  *POINT-COL* COL) )
  (SETQ LST1 *LEFT-POINT*
	LST2 (NTHCDR (- *POINT-COL* COL 1) LST1)
	*LEFT-POINT* (CDR LST2))
  (RPLACD LST2)
  (SETQ *RIGHT-POINT* (NREVERSE LST1 *RIGHT-POINT*)
	*POINT-COL* COL) )

(DEFUN SCRN-UP (ROW
    SCREEN )
  ((AND *SCROLL-FLAG* (SET-CURSOR ROW 0) (DELETE-LINES 1))
    (NCONC *SCREEN* (CONS *NUL-STRG*))
    (SETQ SCREEN (NTHCDR ROW *SCREEN*))
    (RPLACA SCREEN (CADR SCREEN))
    (RPLACD SCREEN (CDDR SCREEN)) ) )

(DEFUN SCRN-DOWN (ROW
    SCREEN )
  ((AND *SCROLL-FLAG* (SET-CURSOR ROW 0) (INSERT-LINES 1))
    (SETQ SCREEN (NTHCDR ROW *SCREEN*))
    (RPLACD SCREEN (CONS (CAR SCREEN) (CDR SCREEN)))
    (RPLACA SCREEN *NUL-STRG*)
    (NBUTLAST *SCREEN*) ) )

(DEFUN UNPACK-LINE ()
  ((IDENTITY *UNPACKED*))
  (SETQ *UNPACKED* T)
  (IF *BELOW-POINT*
	(SETQ *RIGHT-POINT* (UNPACK (POP *BELOW-POINT*)))
	(SETQ *RIGHT-POINT*) )
  ((ZEROP *POINT-COL*)
    (SETQ *LEFT-POINT*) )
  ((< (LENGTH *RIGHT-POINT*) *POINT-COL*)
    (SETQ *LEFT-POINT* (MAKE-LIST (- *POINT-COL* (LENGTH *RIGHT-POINT*))
				  *BLANK* (NREVERSE *RIGHT-POINT*))
	  *RIGHT-POINT*) )
  (SETQ *LEFT-POINT* *RIGHT-POINT*)
  ((LAMBDA (LST)
	(SETQ *RIGHT-POINT* (CDR LST))
	(RPLACD LST) )
    (NTHCDR (SUB1 *POINT-COL*) *RIGHT-POINT*))
  (SETQ *LEFT-POINT* (NREVERSE *LEFT-POINT*)) )

(DEFUN PACK-LINE ()
  ((NOT *UNPACKED*))
  (SETQ *UNPACKED*)
  (SETQ *RIGHT-POINT* (TRIM-LINE (NREVERSE *LEFT-POINT* *RIGHT-POINT*)))
  ((OR *BELOW-POINT* *RIGHT-POINT*)
    (PUSH (PACK *RIGHT-POINT*) *BELOW-POINT*) ) )

(DEFUN ADJUST-ROW (ROW)
  ( ((> *LAST-ROW* *POINT-ROW*)
      (INCQ *LAST-ROW* ROW) ) )
  ( ((> *FIND-ROW* *POINT-ROW*)
      (INCQ *FIND-ROW* ROW) ) )
  ( ((> *TEMP-ROW* *POINT-ROW*)
      (INCQ *TEMP-ROW* ROW) ) )
  ( ((> *START-ROW* *POINT-ROW*)
      (INCQ *START-ROW* ROW) ) )
  ((> *END-ROW* *POINT-ROW*)
    (INCQ *END-ROW* ROW) ) )

(DEFUN ADJUST-ROW-COL (COL
    *POINT-COL* )
  (SETQ *POINT-COL* -1)
  (INCQ *POINT-ROW*)
  (ADJUST-COL COL)
  (DECQ *POINT-ROW*) )

(DEFUN ADJUST-COL (COL)
  (AND (EQ *LAST-ROW* *POINT-ROW*) (> *LAST-COL* *POINT-COL*)
    (INCQ *LAST-COL* COL) )
  (AND (EQ *FIND-ROW* *POINT-ROW*) (> *FIND-COL* *POINT-COL*)
    (INCQ *FIND-COL* COL) )
  (AND (EQ *TEMP-ROW* *POINT-ROW*) (> *TEMP-COL* *POINT-COL*)
    (INCQ *TEMP-COL* COL) )
  (AND (EQ *START-ROW* *POINT-ROW*) (> *START-COL* *POINT-COL*)
    (INCQ *START-COL* COL) )
  (AND (EQ *END-ROW* *POINT-ROW*) (> *END-COL* *POINT-COL*)
    (INCQ *END-COL* COL) ) )

(DEFUN ADJUST-TAB (TAB TEXT-LINE	;Ensure TABs lie on a tab column
    COL )
  ((SETQ COL (POSITION *TAB* TEXT-LINE))
    (SETQ TAB (- 7 (REM TAB 8)))
    (LOOP
      ((EQ TAB (REM COL 8))
	TEXT-LINE )
      ((ZEROP COL)
	(MAKE-LIST TAB *BLANK* TEXT-LINE) )
      ((NEQ *BLANK* (NTH (SUB1 COL) TEXT-LINE))
	(RPLACD (NTHCDR (SUB1 COL) TEXT-LINE)
		(MAKE-LIST (REM (+ 8 (- TAB (REM COL 8))) 8) *BLANK*
				(NTHCDR COL TEXT-LINE)))
	TEXT-LINE )
      (RPLACD (RPLACA (NTHCDR (SUB1 COL) TEXT-LINE) *TAB*)
	      (NTHCDR COL (CDR TEXT-LINE)))
      (DECQ COL) ) )
  TEXT-LINE )


;	* * *   Screen update functions   * * *

(DEFUN UPDATE-SCRN (
    ROW ABOVE-POINT BELOW-POINT SCREEN )
  ( ((IDENTITY *STAT-WINDOW*))
    (CLEAR-STAT)
    (SPACES 4)
    (PRINC *FILE-NAME*)
    (SPACES (- (TRUNCATE *COLUMNS* 2) 8 (COLUMN)))
    (WRITE-STRING "  R:C")
    (SETQ *STAT-RC* (ADD1 (COLUMN)) *STAT-END* *STAT-RC* *STAT-WINDOW* T)
    (EDIT-WINDOW) )
  ((LISTEN))
  (IF (> *CURSOR-COL* *POINT-COL*) (SETQ *CURSOR-COL* *POINT-COL*))
  (IF (> *CURSOR-ROW* *POINT-ROW*) (SETQ *CURSOR-ROW* *POINT-ROW*))
  (SET-CURSOR *CURSOR-ROW* *CURSOR-COL*)
  (SETQ ABOVE-POINT *ABOVE-POINT*  BELOW-POINT *BELOW-POINT*)
  ( ((NOT *UNPACKED*)
      (UPDATE-AUX2 *CURSOR-ROW* BELOW-POINT)
      (POP BELOW-POINT) )
    (SETQ SCREEN (NTHCDR *CURSOR-ROW* *SCREEN*))
    (IF (ATOM (CAR SCREEN))
	(RPLACA SCREEN (NCONC (UNPACK (CAR SCREEN))
		(MAKE-LIST (- *COLUMNS* (LENGTH (CAR SCREEN))) *BLANK*))) )
    (SETQ SCREEN (CAR SCREEN))
    (UPDATE-AUX1 *CURSOR-COL* '+ *RIGHT-POINT*
		 (NTHCDR *CURSOR-COL* SCREEN))
    ((LISTEN)
      (RETURN) )
    (SETQ SCREEN (NREVERSE SCREEN))
    (UPDATE-AUX1 (SUB1 *CURSOR-COL*) '- *LEFT-POINT*
		 (NTHCDR (- *COLUMNS* *CURSOR-COL*) SCREEN))
    (NREVERSE SCREEN) )
  (SETQ ROW 0)
  (LOOP
    ((LISTEN))
    (INCQ ROW)
    ( ((>= (+ *CURSOR-ROW* ROW) *ROWS*))
      (UPDATE-AUX2 (+ *CURSOR-ROW* ROW) BELOW-POINT)
      (POP BELOW-POINT) )
    ( ((< *CURSOR-ROW* ROW))
      (UPDATE-AUX2 (- *CURSOR-ROW* ROW) ABOVE-POINT)
      (POP ABOVE-POINT) )
    ((AND (< *CURSOR-ROW* ROW) (>= (+ *CURSOR-ROW* ROW) *ROWS*))
      (UPDATE-STAT) ) ) )

(DEFUN UPDATE-AUX1 (COL +- TEXT-LINE LINE
    NUM )
  (LOOP
    ((NOT (SETQ NUM (MISMATCH LINE TEXT-LINE))))
    ((NULL (SETQ LINE (NTHCDR NUM LINE))))
    (SETQ TEXT-LINE (NTHCDR NUM TEXT-LINE))
    (INCQ COL (FUNCALL +- NUM))
    ((NULL TEXT-LINE)
      (LOOP
	((NULL (SETQ NUM (POSITION-IF 'NON-WHITESPACE LINE))))
	(SET-CURSOR *CURSOR-ROW* (INCQ COL (FUNCALL +- NUM)))
	(SETQ LINE (NTHCDR NUM LINE))
	(RPLACA LINE (WRITE-STRING *BLANK*))
	((LISTEN))
	(INCQ COL (FUNCALL +- 1))
	(POP LINE) ) )
    (SET-CURSOR *CURSOR-ROW* COL)
    (RPLACA LINE (WRITE-STRING (CAR TEXT-LINE)))
    ((LISTEN))
    (INCQ COL (FUNCALL +- 1))
    (POP LINE)
    (POP TEXT-LINE) ) )

(DEFUN UPDATE-AUX2 (ROW TEXT-LINE
    SCREEN )
  (SETQ SCREEN (NTHCDR ROW *SCREEN*))
  (IF (CONSP (CAR SCREEN))
      (RPLACA SCREEN (PACK (TRIM-LINE (CAR SCREEN)))))
  (SETQ TEXT-LINE (IF TEXT-LINE
		(SUBSTRING (CAR TEXT-LINE) (- *POINT-COL* *CURSOR-COL*)
			(+ (- *POINT-COL* *CURSOR-COL*) *COLUMNS* -1))
		*NUL-STRG*))
  ((EQ (CAR SCREEN) TEXT-LINE))
  (SET-CURSOR ROW 0)
  (SPACES (- (LENGTH (CAR SCREEN)) (LENGTH (WRITE-STRING TEXT-LINE))))
  (RPLACA SCREEN TEXT-LINE) )

(DEFUN UPDATE-STAT (
    )
  ( ((AND *STAT-INS* (EQ *STAT-ROW* *POINT-ROW*) (EQ *STAT-COL* *POINT-COL*))
      (SET-CURSOR *CURSOR-ROW* *CURSOR-COL*) )
    (STAT-WINDOW)
    ( ((IDENTITY *STAT-INS*))
      (SETQ *STAT-INS* T)
      (SET-CURSOR 0 (- *COLUMNS* 8))
      ((NOT *INSERT*)
	(WRITE-STRING "Replace") )
      (SETQ *HIGH-INTENSITY* T)
      (WRITE-STRING "Insert ")
      (SETQ *HIGH-INTENSITY*) )
    (SETQ *STAT-ROW* *POINT-ROW* *STAT-COL* *POINT-COL*)
    (SET-CURSOR 0 *STAT-RC*)
    (PRINC (ADD1 *STAT-ROW*))
    (WRITE-STRING '":")
    (PRINC (ADD1 *STAT-COL*))
    (SETQ *STAT-END* (PROG1 (COLUMN) (SPACES (- *STAT-END* (COLUMN)))))
    (EDIT-WINDOW) )

  ((NOT *BLINK-PAREN*))
  ((NOT *UNPACKED*)
    ((NULL *BELOW-POINT*))
    ((EQ (CHAR (CAR *BELOW-POINT*) *POINT-COL*) *LPAR*)
      (BLINK-RPAR (CAR *BELOW-POINT*) (CDR *BELOW-POINT*)) )
    ((EQ (CHAR (CAR *BELOW-POINT*) *POINT-COL*) *RPAR*)
      (BLINK-LPAR (CAR *BELOW-POINT*) *ABOVE-POINT*) ) )
  ((EQ (CAR *RIGHT-POINT*) *LPAR*)
    (BLINK-RPAR (PACK* (PACK *LEFT-POINT*) (PACK *RIGHT-POINT*))
	*BELOW-POINT*) )
  ((EQ (CAR *RIGHT-POINT*) *RPAR*)
    (SETQ *LEFT-POINT* (NREVERSE *LEFT-POINT*))
    (BLINK-LPAR (PACK *LEFT-POINT*) *ABOVE-POINT*)
    (SETQ *LEFT-POINT* (NREVERSE *LEFT-POINT*)) ) )

(DEFUN BLINK-RPAR (LINE TEXT
    ROW COL )
  (SETQ ROW *CURSOR-ROW*  COL *POINT-COL*)
  ((MATCHING-RPAR 0 T)
    (DECQ COL)
    (BLINK-CHAR *RPAR*) ) )

(DEFUN BLINK-LPAR (LINE TEXT
    ROW COL )
  (SETQ ROW *CURSOR-ROW*  COL *POINT-COL*)
  ((MATCHING-LPAR 1 T)
    (BLINK-CHAR *LPAR*) ) )

(DEFUN BLINK-CHAR (CHAR
    *BLINK* )
  (SETQ COL (- COL (- *POINT-COL* *CURSOR-COL*)))
  ((< -1 COL *COLUMNS*)
    (SETQ *BLINK* T)
    (SET-CURSOR ROW COL)
    (PRINC CHAR)
    (SET-CURSOR *CURSOR-ROW* *CURSOR-COL*)
    (LOOP
      ((LISTEN)) )
    (SETQ *BLINK*)
    (SET-CURSOR ROW COL)
    (PRINC CHAR) ) )

(DEFUN WINDOW-SHAPE ()
  (START-TEXT)
  (WINDOW-SHAPE-AUX)
  (JUMP-LAST) )

(DEFUN WINDOW-SHAPE-AUX (
    CHAR )
  (CLEAR-STAT)
  (SETQ CHAR (PROMPT-READ-CHAR '(F V H | |) " Full, Vertical, Horizontal: "))
  ((EQ CHAR '| |))
  (MAKE-WINDOW-SHAPE)
  (CLEAR-SCREEN)
  (SETQ *WINDOW-SHAPE* CHAR)
  (MAKE-SCREEN) )

(DEFUN MAKE-SCREEN (
    ROW COL MAXROW MAXCOL)
  (MAKE-WINDOW-SHAPE)
  (SETQ ROW (CAR (MAKE-WINDOW))
	COL (CADR (MAKE-WINDOW))
	MAXROW (CADDR (MAKE-WINDOW))
	MAXCOL (CADDDR (MAKE-WINDOW))
	*BASE-ROW* (+ ROW 3)  *BASE-COL* (ADD1 COL)
	*ROWS* (- MAXROW 4)  *COLUMNS* (- MAXCOL 2)
	*SCREEN* (MAKE-LIST *ROWS* *NUL-STRG*)
	*PAGE-ROWS* (CEILING (* *ROWS* 4) 5)
	*EVAL-ROW* 0
	*STAT-WINDOW* NIL
	*HIGH-INTENSITY*)
  (DECQ MAXROW)
  (DECQ MAXCOL)
  (CLEAR-SCREEN)
  (WRITE-BYTE *NWCORNER*)
  (WRITE-BYTE *HBORDER* (SUB1 MAXCOL))
  (WRITE-BYTE *NECORNER*)
  (SETQ ROW 1)
  (LOOP
    (SET-CURSOR ROW 0)
    ((EQ ROW MAXROW))
    (WRITE-BYTE *VBORDER*)
    (SET-CURSOR ROW MAXCOL)
    (WRITE-BYTE *VBORDER*)
    (INCQ ROW) )
  (WRITE-BYTE *SWCORNER*)
  (WRITE-BYTE *HBORDER* (SUB1 MAXCOL))
  (WRITE-BYTE *SECORNER*)
  (SET-CURSOR 2 0)
  (WRITE-BYTE *LTBORDER*)
  (WRITE-BYTE *HBORDER* (SUB1 MAXCOL))
  (WRITE-BYTE *RTBORDER*) )

(DEFUN MAKE-WINDOW-SHAPE ()
  ((EQ *WINDOW-SHAPE* 'V)
    (MAKE-WINDOW (CAR *FULL-WINDOW*)
		 (+ (CADR *FULL-WINDOW*) (CEILING (CADDDR *FULL-WINDOW*) 2))
		 (CADDR *FULL-WINDOW*)
		 (FLOOR (CADDDR *FULL-WINDOW*) 2)) )
  ((EQ *WINDOW-SHAPE* 'H)
    (MAKE-WINDOW (CAR *FULL-WINDOW*)
		 (CADR *FULL-WINDOW*)
		 (+ (FLOOR (CADDR *FULL-WINDOW*) 2) 3)
		 (CADDDR *FULL-WINDOW*)) )
  (APPLY 'MAKE-WINDOW *FULL-WINDOW*) )

(DEFUN CLEAR-STAT ()
  (STAT-WINDOW)
  (SETQ *STAT-WINDOW* NIL *STAT-ROW* NIL *STAT-COL* NIL *STAT-INS*)
  (CLEAR-SCREEN) )

(DEFUN STAT-WINDOW ()
  (MAKE-WINDOW (- *BASE-ROW* 2) *BASE-COL* 1 *COLUMNS*)
  (SETQ *HIGH-INTENSITY*) )

(DEFUN EDIT-WINDOW ()
  (MAKE-WINDOW *BASE-ROW* *BASE-COL* *ROWS* *COLUMNS*)
  (SETQ *HIGH-INTENSITY* T)
  (SET-CURSOR *CURSOR-ROW* *CURSOR-COL*) )

(DEFUN EVAL-WINDOW ()
  (SETQ *HIGH-INTENSITY*)
  ((OR (EQ *WINDOW-SHAPE* 'F)
       (NEQ 2 (CSMEMORY 855)) )		;IBM PC test
    (APPLY 'MAKE-WINDOW *FULL-WINDOW*)
    (SET-CURSOR (SUB1 (CADDR *FULL-WINDOW*)) 0) )
  ((EQ *WINDOW-SHAPE* 'V)
    (MAKE-WINDOW (CAR *FULL-WINDOW*)
		 (CADR *FULL-WINDOW*)
		 (CADDR *FULL-WINDOW*)
		 (SUB1 *BASE-COL*))
    (SET-CURSOR *EVAL-ROW* 0) )
  (MAKE-WINDOW (+ *ROWS* 4)
	       (CADR *FULL-WINDOW*)
	       (- (CADDR *FULL-WINDOW*) *ROWS* 4)
	       (CADDDR *FULL-WINDOW*))
  (SET-CURSOR *EVAL-ROW* 0) )

;	* * *   Save edited file functions   * * *

(DEFUN QUIT-EDIT ()
  ((NOT *TEXT-DIRTY*)
    (SETQ *FILE-NAME*)
    (THROW 'QUIT-EDIT) )
  (CLEAR-STAT)
  ((PROMPT-Y/N (PACK* " Abandon " *FILE-NAME* '"?"))
    (SETQ *FILE-NAME*)
    (THROW 'QUIT-EDIT) ) )

(DEFUN SAVE-FILE ()
  (SAVE-EDIT)
  (SETQ *FILE-NAME*)
  (THROW 'QUIT-EDIT) )

(DEFUN SAVE-EDIT (
    *SCROLL-FLAG* )
  (SETQ *SCROLL-FLAG*)
  (START-TEXT)
  (PACK-LINE)
  ((WRITE-FILE *FILE-NAME* (TRIM-TEXT *BELOW-POINT*))
    (SETQ *TEXT-DIRTY*)
    (JUMP-LAST) )
  (JUMP-LAST) )


;	* * *   File I/O operation functions   * * *

(DEFUN READ-FILE (FILE-NAME
    LST ECHO )
  ((EQ FILE-NAME *NUL-STRG*) NIL)
  ((RDS FILE-NAME)
    (CLEAR-STAT)
    (WRITE-STRING " Reading ")
    (WRITE-STRING (INPUTFILE))
    (READPTR 0)
    (LOOP
      ((NOT (LISTEN)))
      (PUSH (READ-LINE) LST) )
    ( ((EQ *FILE-NAME* FILE-NAME)
	(SETQ *FILE-NAME* (INPUTFILE)) ) )
    (RDS)
    (NREVERSE LST) ) )

(DEFUN WRITE-FILE (FILE-NAME TEXT
    LINELENGTH ECHO )
  ((EQ FILE-NAME *NUL-STRG*) NIL)
  (LOOP
    ((NULL (WRS FILE-NAME)) NIL)
    (SETQ WRS)
    (CLEAR-STAT)
    (WRITE-STRING " Saving ")
    (WRITE-STRING (OUTPUTFILE))
    (SETQ WRS T)
    (WRITEPTR 0)
    ((CATCH "Disk Full" (MAPC 'WRITE-LINE TEXT) (WRITE-BYTE 26))
      (WRS) T)
    (WRITEPTR 0)
    (WRS)
    (CLEAR-STAT)
    (WRS (FIND "EDIT$.TMP" (OPENFILES) 'FINDSTRING))
    (WRS)
    ((OPENFILES) NIL)
    ((NOT (PROMPT-Y/N " Disk full; retry on new disk?")) NIL) ) )

(DEFUN PRINT-FILE (FILE-NAME
    ROW LINE WRS LINELENGTH )
  ((EQ FILE-NAME *NUL-STRG*))
  ((RDS FILE-NAME)
    (SETQ ROW 0)
    (LOOP
      (CLEAR-STAT)
      (WRITE-STRING (PACK* " Printing " (INPUTFILE) ", press key to stop "))
      (LOOP
	(SETQ RDS NIL WRS)
	((LISTEN)
	  (READ-CHAR)
	  (CLEAR-STAT)
	  ((PROMPT-Y/N (PACK* " Printing " (INPUTFILE) ", quit?"))
	    (RDS)
	    (RETURN) ) )
	(SETQ RDS T WRS 'PRINT)
	((NOT (LISTEN))
	  (PAGE-NUMBER (- *PAGE-LINES* (REM (+ ROW 5) *PAGE-LINES*)))
	  (RDS)
	  (RETURN) )
	( ((ZEROP (REM ROW *PAGE-LINES*))
	    (INCQ ROW)
	    (TERPRI) ) )
	(WRITE-BYTE 32 5)
	( ((FINDSTRING (ASCII 12) (SETQ LINE (READ-LINE)))
	    (PAGE-NUMBER (- *PAGE-LINES* (REM (+ ROW 5) *PAGE-LINES*)))
	    (SETQ LINE (PACK (DELETE (ASCII 12) (UNPACK LINE))))
	    ((EQ LINE *NUL-STRG*))
	    (WRITE-LINE LINE)
	    (INCQ ROW) )
	  (WRITE-LINE LINE)
	  (INCQ ROW)
	  ( ((ZEROP (REM (+ ROW 7) *PAGE-LINES*))
	      (PAGE-NUMBER 2) ) ) ) ) ) )
  (CLEAR-SCREEN)
  (WRITE-STRING FILE-NAME)
  (WRITE-STRING " not found")
  (RECLAIM) )

(DEFUN PAGE-NUMBER (NUM)
  ((ZEROP (REM ROW *PAGE-LINES*)))
  (TERPRI NUM)
  (SPACES 36)
  (PRINC '-)
  (PRINC (CEILING ROW *PAGE-LINES*))
  (PRINC '-)
  (TERPRI 5)
  (INCQ ROW (+ NUM 5)) )

(DEFUN PROMPT-Y/N (PROMPT)
  (EQ (PROMPT-READ-CHAR '(Y N | |) (PACK* PROMPT " (Y/N) ")) 'Y) )

(DEFUN PROMPT-READ-CHAR (LST PROMPT
    READ-CHAR RDS WRS )
  (WRITE-STRING PROMPT)
  (PRINC (LOOP
    ((FIND (STRING-UPCASE (READ-CHAR)) LST)) )) )

(DEFUN PROMPT-FILE (PROMPT
    FILE-NAME )
  (SETQ FILE-NAME (STRING-UPCASE (PROMPT-READ-LINE PROMPT)))
  ((OR (EQ FILE-NAME *NUL-STRG*) (FINDSTRING '\. FILE-NAME)) FILE-NAME)
  (PACK* FILE-NAME '\. *DEFAULT-TYPE*) )

(DEFUN PROMPT-READ-LINE (PROMPT
    READ-CHAR RDS WRS )
  (CLEAR-STAT)
  (WRITE-STRING PROMPT)
  (SETQ READ-CHAR T)
  (CLEAR-INPUT)
  (READ-LINE) )

(DEFUN TRIM-TEXT (TEXT)
  (NREVERSE (MEMBER *NUL-STRG* (NREVERSE TEXT) 'NEQ)) )

(DEFUN TRIM-LINE (LINE)
  (NREVERSE (MEMBER-IF 'NON-WHITESPACE (NREVERSE LINE))) )

(DEFUN BLANK-LINE (LINE)
  (NOTANY 'NON-WHITESPACE LINE) )

(DEFUN WORD-DELIMITER (CHAR)
  (MEMBER CHAR *WORD-DELIMITER*) )

(DEFUN WHITESPACE (CHAR)
  (MEMBER CHAR *WHITESPACE*) )

(DEFUN NON-WHITESPACE (CHAR)
  (NOT (MEMBER CHAR *WHITESPACE*)) )

(SETQ	*BLANK* '" "
	*BLINK-PAREN* 'T
	*DEFAULT-TYPE* 'LSP
	*MULTIPLE-ESCAPE* '\|
	*NUL-STRG* '""
	*PAGE-LINES* 66
	*LPAR* '\(
	*RPAR* '\)
	*SINGLE-ESCAPE* '\\
	*TAB* (ASCII 9)
	*WHITESPACE* (LIST *BLANK* *TAB*)
	*ATOM-DELIMITER* (LIST* *LPAR* *RPAR* *WHITESPACE*)
	*WORD-DELIMITER* (LIST* '\, '\: '\; *ATOM-DELIMITER*)

	*VBORDER* (ASCII '\|)	;Generic MS-DOS border
	*HBORDER* (ASCII '\-)
	*NWCORNER* (ASCII *BLANK*)
	*NECORNER* (ASCII *BLANK*)
	*SWCORNER* (ASCII *BLANK*)
	*SECORNER* (ASCII *BLANK*)
	*LTBORDER* (ASCII '\|)
	*RTBORDER* (ASCII '\|) )

(IF (EQ 2 (CSMEMORY 855)) (PROGN	;IBM PC check

(SETQ	*VBORDER* 179			;IBM PC border
	*HBORDER* 205
	*NWCORNER* 213
	*NECORNER* 184
	*SWCORNER* 212
	*SECORNER* 190
	*LTBORDER* 198
	*RTBORDER* 181)

(PUT (ASCII 255) 'EDIT-CHAR 'EXTENDED)

(DEFUN EXTENDED (
    CHAR )
  (SETQ CHAR (READ-CHAR))
  ((GET CHAR 'EXTENDED)
    (APPLY (GET CHAR 'EXTENDED)) ) )
	))

(DEFUN AUTO-EDIT ()
  (EDIT)
  (SYSTEM) )

(PROGN
  (RDS)
  (TERPRI 2)
  (IF (EQ 'W (PROMPT-READ-CHAR '(W E)
		"Make editor Wordstar-like or EMACS-like? (W/E) "))
      (PROGN

;	* * *	WordStar like editor   * * *

(MAPC '(LAMBDA (PAIR) (PUT (ASCII (- (ASCII (CAR PAIR)) 64))
			'EDIT-CHAR (CADR PAIR))) '(
(A LEFT-WORD)
;B
(C SCROLL-UP-SCRN)
(D RIGHT-CHAR)
(E UP-LINE)
(F RIGHT-WORD)
(G DEL-RIGHT-CHAR)
(H LEFT-CHAR)
(I RIGHT-TAB)
(J DOWN-LINE-INDENT)
(K EDIT-PAIR)
(L FIND-NEXT)
(M NEW-LINE)
(N INSERT-LINE)
(O EDIT-PAIR)
(P ESCAPE-CHAR)
(Q EDIT-PAIR)
(R SCROLL-DOWN-SCRN)
(S LEFT-CHAR)
(T DEL-RIGHT-WORD)
(U UNDELETE)
(V INSERT-MODE)
(W SCROLL-DOWN-LINE)
(X DOWN-LINE)
(Y DEL-LINE)
(Z SCROLL-UP-LINE)
(\[ EDIT-PAIR) ) )

(PUT (ASCII 127) 'EDIT-CHAR DEL-LEFT-CHAR)


(MAPC '(LAMBDA (PAIR) (PUT (CAR PAIR) 'Q (CADR PAIR))) '(
(A REPL-STRG)
(B JUMP-START)
(C END-TEXT)
(D RIGHT-END)
(E TOP-ROW)
(F FIND-STRG)
(I LEFT-TAB)
(K JUMP-END)
(L REPL-ALL)
(P JUMP-LAST)
(R START-TEXT)
(S LEFT-END)
(T DEL-LEFT-WORD)
(V JUMP-FIND)
(W WINDOW-SHAPE)
(X BOTTOM-ROW)
(Y DEL-RIGHT-END) ) )

(PUT (ASCII 127) 'Q 'DEL-LEFT-END)


(PUT 'K 'PROMPT " A-abandon D-save S-save/reedit: ")

(MAPC '(LAMBDA (PAIR) (PUT (CAR PAIR) 'K (CADR PAIR))) '(
(A QUIT-EDIT)
(B MARK-START)
(C COPY-BLOCK)
(D SAVE-FILE)
(K MARK-END)
(Q QUIT-EDIT)
(R READ-BLOCK)
(S SAVE-EDIT)
(V MOVE-BLOCK)
(W WRITE-BLOCK)
(Y DEL-BLOCK) ) )


(PUT 'O 'PROMPT " BLOCK: Bgn End Mov Cop Del Rd Wr: ")

(MAPC '(LAMBDA (PAIR) (PUT (CAR PAIR) 'O (CADR PAIR))) '(
(B MARK-START)
(C COPY-BLOCK)
(D DEL-BLOCK)
(E MARK-END)
(M MOVE-BLOCK)
(R READ-BLOCK)
(W WRITE-BLOCK) ) )


(PUT '\[ 'PROMPT " List structure editing command: ")

(MAPC '(LAMBDA (PAIR) (PUT (CAR PAIR) '\[ (CADR PAIR))) '(
(\! EVAL-SEXP)
(A LEFT-LIST)
(C NEXT-DEFN)
(D RIGHT-SEXP)
(E LEFT-UP-LIST)
(F RIGHT-LIST)
(L EVAL-LISP)
(R THIS-DEFN)
(S LEFT-SEXP)
(T DEL-SEXP)
(X RIGHT-DOWN-LIST)
(Y DEL-DEFN)
(Z RIGHT-UP-LIST) ) )


(IF (EQ 2 (CSMEMORY 855))		;IBM PC check
(PROGN

(MAPC '(LAMBDA (PAIR) (PUT (CAR PAIR) 'EXTENDED (CADR PAIR))) '(
(G TOP-ROW)			; Home
(H UP-LINE)			; Up arrow
(I SCROLL-DOWN-SCRN)		; PgUp
(K LEFT-CHAR)			; <--
(M RIGHT-CHAR)			; -->
(O BOTTOM-ROW)			; End
(P DOWN-LINE)			; Down arrow
(Q SCROLL-UP-SCRN)		; PgDn
(R INSERT-MODE)			; Ins
(S DEL-LEFT-CHAR)		; Del
(\s LEFT-WORD)			; Ctrl <--
(\t RIGHT-WORD)			; Ctrl -->
(\u END-TEXT)			; Ctrl-End
(\v RIGHT-LIST)			; Ctrl-PgDn
(\w START-TEXT) ) )		; Ctrl-Home

(MAPC '(LAMBDA (PAIR) (PUT (ASCII (CAR PAIR)) 'EXTENDED (CADR PAIR))) '(
(18 LEFT-UP-LIST)		; Alt-E
(19 THIS-DEFN)			; Alt-R
(20 DEL-SEXP)			; Alt-T
(21 DEL-DEFN)			; Alt-Y
(30 LEFT-LIST)			; Alt-A
(31 LEFT-SEXP)			; Alt-S
(32 RIGHT-SEXP)			; Alt-D
(33 RIGHT-LIST)			; Alt-F
(38 EVAL-LISP)			; Alt-L
(44 RIGHT-UP-LIST)		; Alt-Z
(45 RIGHT-DOWN-LIST)		; Alt-X
(46 NEXT-DEFN)			; Alt-C
(120 EVAL-SEXP)			; Alt-! or Alt-1
(132 LEFT-LIST) ) )		; Ctrl-PgUp



) ) ) (PROGN

;	* * *	EMACS like editor   * * *

(DEFUN DEL-RIGHT-LINE ()	;Delete right end of line or NEWLINE
  (UNPACK-LINE)
  ((BLANK-LINE *RIGHT-POINT*)
    (DEL-CRLF) )
  (DEL-RIGHT-END) )

(MAPC '(LAMBDA (PAIR) (PUT (ASCII (- (ASCII (CAR PAIR)) 64))
			'EDIT-CHAR (CADR PAIR))) '(
(@ MARK-START)
(A LEFT-END)
(B LEFT-CHAR)
;C
(D DEL-RIGHT-CHAR)
(E RIGHT-END)
(F RIGHT-CHAR)
;G
(H DEL-LEFT-CHAR)
(I RIGHT-TAB)
(J DOWN-LINE-INDENT)
(K DEL-RIGHT-LINE)
(L FIND-NEXT)
(M NEW-LINE)
(N DOWN-LINE)
(O INSERT-LINE)
(P UP-LINE)
(Q ESCAPE-CHAR)
;R
(S FIND-STRG)
;T
(U EDIT-PAIR)
(V SCROLL-UP-SCRN)
(W DEL-BLOCK)
(X EDIT-PAIR)
(Y UNDELETE)
(Z EDIT-PAIR) ) )

(PUT (ASCII 127) 'EDIT-CHAR DEL-LEFT-WORD)


(MAPC '(LAMBDA (PAIR) (PUT (CAR PAIR) 'X (CADR PAIR))) '(
(< START-TEXT)
(> END-TEXT)
(\% REPL-STRG)
(\2 WINDOW-SHAPE)
(A QUIT-EDIT)
(B LEFT-WORD)
(D DEL-RIGHT-WORD)
(F RIGHT-WORD)
(I INSERT-MODE)
(K DEL-LEFT-END)
(L REPL-ALL)
(R READ-BLOCK)
(S SAVE-EDIT)
(V SCROLL-DOWN-SCRN)
(W WRITE-BLOCK) ) )


(PUT 'U 'PROMPT " BLOCK: Bgn End Mov Cop Del: ")

(MAPC '(LAMBDA (PAIR) (PUT (CAR PAIR) 'U (CADR PAIR))) '(
(B MARK-START)
(C COPY-BLOCK)
(D DEL-BLOCK)
(E MARK-END)
(M MOVE-BLOCK) ) )


(PUT 'Z 'PROMPT " List structure editing command: ")

(MAPC '(LAMBDA (PAIR) (PUT (CAR PAIR) 'Z (CADR PAIR))) '(
(\! EVAL-LISP)
(\( LEFT-UP-LIST)
(\) RIGHT-UP-LIST)
(\[ THIS-DEFN)
(\] NEXT-DEFN)
(B LEFT-SEXP)
(D RIGHT-DOWN-LIST)
(E EVAL-SEXP)
(F RIGHT-SEXP)
(K DEL-SEXP)
(N RIGHT-LIST)
(P LEFT-LIST) ) )


(IF (EQ 2 (CSMEMORY 855))		;IBM PC check
(PROGN

(MAPC '(LAMBDA (PAIR) (PUT (CAR PAIR) 'EXTENDED (CADR PAIR))) '(
(G START-TEXT)			; Home
(H UP-LINE)			; Up arrow
(I SCROLL-DOWN-SCRN)		; PgUp
(K LEFT-CHAR)			; <--
(M RIGHT-CHAR)			; -->
(O END-TEXT)			; End
(P DOWN-LINE)			; Down arrow
(Q SCROLL-UP-SCRN)		; PgDn
(R INSERT-LINE)			; Ins
(S DEL-RIGHT-CHAR)		; Del
(\s LEFT-WORD)			; Ctrl <--
(\t RIGHT-WORD)			; Ctrl -->
(\u END-TEXT)			; Ctrl-End
(\v RIGHT-LIST)			; Ctrl-PgDn
(\w START-TEXT) ) )		; Ctrl-Home

(MAPC '(LAMBDA (PAIR) (PUT (ASCII (CAR PAIR)) 'EXTENDED (CADR PAIR))) '(
(17 WRITE-BLOCK)		; Alt-W
(19 READ-BLOCK)			; Alt-R
(23 INSERT-MODE)		; Alt-I
(30 QUIT-EDIT)			; Alt-A
(31 SAVE-EDIT)			; Alt-S
(32 DEL-RIGHT-WORD)		; Alt-D
(33 RIGHT-WORD)			; Alt-F
(37 DEL-LEFT-END)		; Alt-K
(47 SCROLL-DOWN-SCRN)		; Alt-V
(48 LEFT-WORD)			; Alt-B
(120 EVAL-SEXP)			; Alt-! or Alt-1
(124 REPL-STRG)			; Alt-%
(132 LEFT-LIST) ) )		; Ctrl-PgUp

) ) ) )

  (TERPRI 2)
  (IF (PROMPT-Y/N
	"Make editor start automatically when the SYS file is loaded?")
      (SETQ DRIVER 'AUTO-EDIT) )
  (TERPRI 2)
  (WRITE-LINE "To save the muLISP editor as a fast loading SYS file on")
  (WRITE-LINE "the diskette in <drive>, enter a command of the form:")
  (TERPRI)
  (WRITE-LINE "          (SAVE 'drive:EDIT)")
  (TERPRI 2)
)