;;; -*- Mode:LISP; Package:ZWEI; Readtable:T; Base:10 -*-
;;; ** (c) Copyright 1980 Massachusetts Institute of Technology **
;;;  This file contains basic text manipulation functions for ZWEI. 

;>> this file is full of kludgey wired-in knowledge about art-strings and art-fat-strings.

;;; This file provides the following functions:
;;; INSERT INSERT-INTERVAL DELETE-INTERVAL COPY-INTERVAL

;;; Internal function for inserting and deleting.
(DEFUN SET-LINE-LENGTH (LINE LENGTH)
  (LET ((CURRENT-SIZE (ARRAY-LENGTH LINE)))
    (WHEN (> LENGTH CURRENT-SIZE)
      (ADJUST-ARRAY-SIZE LINE (MAX LENGTH (FIX (* (MAX CURRENT-SIZE 30.) 1.3s0)))))
    (SETF (LINE-LENGTH LINE) LENGTH)))

;;; Change the type of an array, used to turn ordinary lines into 16-bit ones
(DEFUN SET-LINE-ARRAY-TYPE (LINE ARRAY-TYPE)
  "Change the array type of LINE to ARRAY-TYPE, preserving the contents and leader.
ARRAY-TYPE should be ART-STRING or ART-FAT-STRING."
  (LET ((NEW-LINE (CREATE-LINE ARRAY-TYPE (ARRAY-LENGTH LINE) (LINE-NODE LINE))))
    (COPY-ARRAY-CONTENTS-AND-LEADER LINE NEW-LINE)
    (STRUCTURE-FORWARD LINE NEW-LINE)))

;;; Make something into a string
(DEFUN ASSURE-STRING (STRING)
  "Coerce STRING into a string, or a fat-string if given a number >= CHAR-CODE-LIMIT"
;character lossage
  (IF (CHARACTERP STRING) (SETQ STRING (CHAR-INT STRING)))
  (COND ((ARRAYP STRING) STRING)
	((AND (NUMBERP STRING) ( STRING CHAR-CODE-LIMIT))
	 (LET ((NEW-STRING (MAKE-ARRAY 1 :TYPE 'ART-FAT-STRING)))
	   (SETF (CHAR NEW-STRING 0) STRING)
	   NEW-STRING))
	(T (STRING STRING))))

;>> this should be a little smarter about line breaks.
;>> If we insert a newline at position two of a line, perhaps a
;>> better strategy than leaving the old line with just one character in it
;>> and consing up a whole new array for the n-2 characters left, would be to
;>> put the short part of the line in a new, shorter string and shift the rest
;>> of the line backwards. I should do some metering.
;>> For example, we --REALLY-- lose big doing something like replacing all the
;>> linefeeds in a file with newlines when the file had no linebreaks in it
;>> originally -- can get this sort of lossage cftping of un*x hosts, etc

;;; Insert the STRING at the BP.
(DEFUN INSERT (BP STRING &OPTIONAL (START 0) END
	       &AUX LINE INDEX LINE-LENGTH FIRST-NEWLINE FIRST-LINE LAST-LINE)
  "Insert a copy of STRING, or the part of it from START to END, into text at BP.
STRING can actually be a string or a character.
START and END are allowed only with strings.
BP is left pointing before the inserted text, unless it is of type :MOVES.
The value is a BP pointing after the inserted text."
  (AND (NOT *BATCH-UNDO-SAVE*) *UNDO-SAVE-SMALL-CHANGES*
       (UNDO-SAVE-NEW-SMALL-CHANGE BP BP))
  (MUNG-BP-INTERVAL BP)
  (SETQ LINE (BP-LINE BP)
	INDEX (BP-INDEX BP)
	LINE-LENGTH (LINE-LENGTH LINE))
;character lossage
  (IF (FIXNUMP STRING) (SETQ STRING (INT-CHAR STRING)))
  (COND ((ARRAYP STRING)
	 (OR END (SETQ END (ARRAY-ACTIVE-LENGTH STRING)))
	 (SETQ FIRST-NEWLINE (%STRING-SEARCH-CHAR #/NEWLINE STRING START END))
	 (COND ((NULL FIRST-NEWLINE)
		;; The string doesn't have any newlines in it.
		(INSERT-WITHIN-LINE LINE INDEX STRING START END))
	       (T
		;; First, construct the "last" line, which is made up of the last
		;; line of the STRING followed by the part of LINE after INDEX.
		;; The copy the first line of STRING into LINE.
		(LET* ((LAST-NEWLINE (STRING-REVERSE-SEARCH-CHAR #/NEWLINE STRING
								 END START))
		       (ARRAY-TYPE (IF (EQ (ARRAY-TYPE STRING) 'ART-FAT-STRING)
				       'ART-FAT-STRING (ARRAY-TYPE LINE)))
		       (LCHARS (- END LAST-NEWLINE 1)))
		  (COND ((AND (= LAST-NEWLINE (1- END))
			      (ZEROP INDEX))
			 ;; Inserting stuff ending with CR at front of line
			 ;; implies we can just shove down the old line
			 (SETQ LAST-LINE LINE)
			 ;; But then we can't use it as the first line.
			 (SETQ FIRST-LINE (CREATE-LINE ARRAY-TYPE
						       (- FIRST-NEWLINE START)
						       (BP-NODE BP)))
			 (SETF (LINE-PREVIOUS FIRST-LINE) (LINE-PREVIOUS LINE))
			 (AND (LINE-PREVIOUS LINE)
			      (SETF (LINE-NEXT (LINE-PREVIOUS LINE)) FIRST-LINE))
			 (COPY-ARRAY-PORTION STRING START FIRST-NEWLINE
					     FIRST-LINE 0 (ARRAY-LENGTH FIRST-LINE))
			 ;; Transfer bps from the front of LINE to FIRST-LINE.
			 (DOLIST (BP (LINE-BP-LIST LINE))
			   (AND (ZEROP (BP-INDEX BP))
				(EQ (BP-STATUS BP) ':NORMAL)
				(MOVE-BP BP FIRST-LINE 0))))
			(T
			 ;; Otherwise, keep the beginning of the line we are inserting in,
			 ;; and make a new line for the tail end of the string.
			 (SETQ FIRST-LINE LINE)
			 (SETQ LAST-LINE (CREATE-LINE ARRAY-TYPE
						      (+ LCHARS (- LINE-LENGTH INDEX))
						      (BP-NODE BP)))
			 ;; Copy the last line of STRING into LAST-LINE.
			 (COPY-ARRAY-PORTION STRING (1+ LAST-NEWLINE) END
					     LAST-LINE 0 LCHARS)
			 ;; Copy the part of LINE after INDEX into LAST-LINE
			 (COPY-ARRAY-PORTION LINE INDEX LINE-LENGTH
					     LAST-LINE LCHARS (ARRAY-LENGTH LAST-LINE))
			 ;; Figure out whether LINE is being changed at all.
			 (OR (AND (= FIRST-NEWLINE START)
				  (= INDEX LINE-LENGTH))
			     (MUNG-LINE LINE))
			 ;; Copy the first line of STRING into LINE.
			 (SET-LINE-LENGTH LINE (+ INDEX (- FIRST-NEWLINE START)))
			 (OR (EQ ARRAY-TYPE (ARRAY-TYPE LINE))
			     (SET-LINE-ARRAY-TYPE LINE 'ART-FAT-STRING))
			 (COPY-ARRAY-PORTION STRING START FIRST-NEWLINE
					     LINE INDEX (LINE-LENGTH LINE))
			 ;; Relocate buffer pointers.
			 (DOLIST (BP (LINE-BP-LIST LINE))
			   (LET ((I (BP-INDEX BP)))
			     (COND ((OR (> I INDEX)
					(AND (= I INDEX)
					     (EQ (BP-STATUS BP) ':MOVES)))
				    (MOVE-BP BP LAST-LINE (+ (- I INDEX) LCHARS))))))))
		  (DO ((PREV-LINE FIRST-LINE THIS-LINE)
		       (THIS-LINE)
		       (PREV-NEWLINE FIRST-NEWLINE NEWLINE)
		       (NEWLINE)
		       (THE-LINE-BEYOND (LINE-NEXT LINE)))
		      (NIL)
		    (COND ((= PREV-NEWLINE LAST-NEWLINE)
			   ;; We are at the end.
			   (AND THE-LINE-BEYOND
				(SETF (LINE-PREVIOUS THE-LINE-BEYOND) LAST-LINE))
			   (SETF (LINE-NEXT LAST-LINE) THE-LINE-BEYOND)
			   (SETF (LINE-NEXT PREV-LINE) LAST-LINE)
			   (SETF (LINE-PREVIOUS LAST-LINE) PREV-LINE)
			   (RETURN NIL)))
		    (SETQ NEWLINE (%STRING-SEARCH-CHAR #/NEWLINE STRING
						       (1+ PREV-NEWLINE) END))
		    (LET ((LENGTH (- NEWLINE PREV-NEWLINE 1)))
		      (SETQ THIS-LINE (CREATE-LINE (ARRAY-TYPE STRING) LENGTH (BP-NODE BP)))
		      (COPY-ARRAY-PORTION STRING (1+ PREV-NEWLINE) NEWLINE
					  THIS-LINE 0 LENGTH)
		      (SETF (LINE-NEXT PREV-LINE) THIS-LINE)
		      (SETF (LINE-PREVIOUS THIS-LINE) PREV-LINE)))
		  (CREATE-BP LAST-LINE LCHARS)))))
	;; These are for INSERT of a non-string
	((EQ STRING #/NEWLINE)
	 ;; Breaking a line.
	 (COND ((ZEROP INDEX)
		;; Shove down the old line if inserting a CR at its front
		(SETQ FIRST-LINE (CREATE-LINE 'ART-STRING 0 (BP-NODE BP)))
		(SETF (LINE-PREVIOUS FIRST-LINE) (LINE-PREVIOUS LINE))
		(AND (LINE-PREVIOUS LINE)
		     (SETF (LINE-NEXT (LINE-PREVIOUS LINE)) FIRST-LINE))
		(SETF (LINE-NEXT FIRST-LINE) LINE)
		(SETF (LINE-PREVIOUS LINE) FIRST-LINE)
		;; Transfer bps from the front of LINE to FIRST-LINE.
		(DOLIST (BP (LINE-BP-LIST LINE))
		  (AND (ZEROP (BP-INDEX BP))
		       (EQ (BP-STATUS BP) ':NORMAL)
		       (MOVE-BP BP FIRST-LINE 0)))
		(CREATE-BP LINE 0))
	       (T
		;; Otherwise, keep the beginning of the line we are inserting in,
		;; and make a new line for the tail end of the string.
		(SETQ LAST-LINE (CREATE-LINE (ARRAY-TYPE LINE) (- LINE-LENGTH INDEX)
					     (BP-NODE BP)))
		(SETF (LINE-NEXT LAST-LINE) (LINE-NEXT LINE))
		(AND (LINE-NEXT LINE)
		     (SETF (LINE-PREVIOUS (LINE-NEXT LINE)) LAST-LINE))
		(SETF (LINE-NEXT LINE) LAST-LINE)
		(SETF (LINE-PREVIOUS LAST-LINE) LINE)
		;; Copy the part of LINE after INDEX into LAST-LINE
		(COPY-ARRAY-PORTION LINE INDEX LINE-LENGTH
				    LAST-LINE 0 (ARRAY-LENGTH LAST-LINE))
		;; Figure out whether LINE is being changed at all.
		(OR (= INDEX LINE-LENGTH)
		    (MUNG-LINE LINE))
		;; Truncate LINE
		(SET-LINE-LENGTH LINE INDEX)
		;; Relocate buffer pointers.
		(DOLIST (BP (LINE-BP-LIST LINE))
		  (LET ((I (BP-INDEX BP)))
		    (COND ((OR (> I INDEX)
			       (AND (= I INDEX)
				    (EQ (BP-STATUS BP) ':MOVES)))
			   (MOVE-BP BP LAST-LINE (- I INDEX))))))
		(CREATE-BP LAST-LINE 0))))
	;; Insert ordinary character -- code simplified from INSERT-WITHIN-LINE
	((CHARACTERP STRING)
	 (AND (GETF (LINE-PLIST LINE) ':DIAGRAM) (BARF "Diagram line"))
	 (SET-LINE-LENGTH LINE (1+ LINE-LENGTH))
	 (IF (AND ( STRING CHAR-CODE-LIMIT)
		  (NEQ (ARRAY-TYPE LINE) 'ART-FAT-STRING))
	     (SET-LINE-ARRAY-TYPE LINE 'ART-FAT-STRING))
	 ;; Move the characters ahead of the inserting forward.
	 (DO ((LF (1- LINE-LENGTH) (1- LF))
	      (LT LINE-LENGTH (1- LT)))
	     ((< LF INDEX))
	   (SETF (CHAR LINE LT) (CHAR LINE LF)))
	 ;; Insert the new characters into the line.
	 (SETF (CHAR LINE INDEX) STRING)
	 ;; Relocate buffer pointers.
	 (DOLIST (BP (LINE-BP-LIST LINE))
	   (LET ((I (BP-INDEX BP)))
	     (IF (OR (> I INDEX)
		     (AND (= I INDEX)
			  (EQ (BP-STATUS BP) ':MOVES)))
		 (SETF (BP-INDEX BP) (1+ I)))))
	 (MUNG-LINE LINE)
	 (CREATE-BP LINE (1+ INDEX)))
	;; Inserting something random
	(T (INSERT BP (STRING STRING) START END))))

(DEFUN INSERT-MOVING (BP STRING &OPTIONAL (START 0) END)
  "Insert STRING at BP, and relocate BP to point after the inserted text.
STRING can be a string or a character.
The value is a temporary buffer pointer also pointing after the inserted text
but not EQ to BP."
  (LET ((NBP (INSERT BP STRING START END)))
    (MOVE-BP BP NBP)
    NBP))

;;; First arg is a BP.  Second is an interval, or second&third are an ordered range.
;;; Insert the stuff from the interval at the BP.
(DEFUN INSERT-INTERVAL (AT-BP FROM-BP &OPTIONAL TO-BP IN-ORDER-P)
  "Insert a copy of an interval into text at AT-BP.
Either pass the interval to insert as the second argument,
or pass a pair of BPs that delimit the interval.
AT-BP is left pointing before the inserted text unless it is of type :MOVES.
The value is a BP pointing after the inserted text."
  (AND (NOT *BATCH-UNDO-SAVE*) *UNDO-SAVE-SMALL-CHANGES*
       (UNDO-SAVE-NEW-SMALL-CHANGE AT-BP AT-BP))
  (MUNG-BP-INTERVAL AT-BP)
  (GET-INTERVAL FROM-BP TO-BP IN-ORDER-P)
  (LET ((AT-LINE (BP-LINE AT-BP))
	(AT-INDEX (BP-INDEX AT-BP))
	(FROM-LINE (BP-LINE FROM-BP))
	(FROM-INDEX (BP-INDEX FROM-BP))
	(TO-LINE (BP-LINE TO-BP))
	(TO-INDEX (BP-INDEX TO-BP)))
    (IF (EQ FROM-LINE TO-LINE)
	;; Insert within AT-LINE.
	(INSERT-WITHIN-LINE AT-LINE AT-INDEX FROM-LINE FROM-INDEX TO-INDEX)
      (LET ((AT-LINE-LENGTH (LINE-LENGTH AT-LINE))
	    (FROM-LINE-LENGTH (LINE-LENGTH FROM-LINE))
	    (ARRAY-TYPE (IF (OR (EQ (ARRAY-TYPE TO-LINE) 'ART-FAT-STRING)
				(EQ (ARRAY-TYPE FROM-LINE) 'ART-FAT-STRING))
			    'ART-FAT-STRING
			  (ARRAY-TYPE AT-LINE)))
	    FIRST-LINE LAST-LINE)
	(COND ((AND (ZEROP TO-INDEX)
		    (ZEROP AT-INDEX))
	       ;;Inserting stuff ending with CR at front of line
	       ;;implies we can just shove down the old line
	       (SETQ LAST-LINE AT-LINE)
	       ;; But then we can't use it as the first line.
	       (SETQ FIRST-LINE (CREATE-LINE ARRAY-TYPE (- FROM-LINE-LENGTH FROM-INDEX)
					     (BP-NODE AT-BP)))
	       (SETF (LINE-PREVIOUS FIRST-LINE) (LINE-PREVIOUS AT-LINE))
	       (AND (LINE-PREVIOUS AT-LINE)
		    (SETF (LINE-NEXT (LINE-PREVIOUS AT-LINE)) FIRST-LINE))
	       (COPY-ARRAY-PORTION FROM-LINE FROM-INDEX FROM-LINE-LENGTH
				   FIRST-LINE 0 (- FROM-LINE-LENGTH FROM-INDEX))
	       (SETF (LINE-PLIST FIRST-LINE) (LINE-PLIST FROM-LINE))
	       ;; Transfer bps from the front of AT-LINE to FIRST-LINE.
	       (DOLIST (BP (LINE-BP-LIST AT-LINE))
		 (AND (ZEROP (BP-INDEX BP))
		      (EQ (BP-STATUS BP) ':NORMAL)
		      (MOVE-BP BP FIRST-LINE 0))))
	      (T
	       ;; Otherwise, keep the beginning of the line we are inserting in,
	       ;; and make a new line for the tail end of the string.
	       (SETQ FIRST-LINE AT-LINE)
	       (SETQ LAST-LINE
		     (CREATE-LINE ARRAY-TYPE (+ TO-INDEX (- AT-LINE-LENGTH AT-INDEX))
				  (BP-NODE AT-BP)))
	       ;; Copy the first part of TO-LINE into the LAST-LINE.
	       (COPY-ARRAY-PORTION TO-LINE 0 TO-INDEX LAST-LINE 0 TO-INDEX)
	       ;; Figure out whether AT-LINE is being changed at all.
	       (OR (AND (ZEROP FROM-LINE-LENGTH)
			(= AT-INDEX (LINE-LENGTH AT-LINE)))
		   (MUNG-LINE AT-LINE))
	       ;; Copy the second part of AT-LINE to LAST-LINE.
	       (COPY-ARRAY-PORTION AT-LINE AT-INDEX AT-LINE-LENGTH
				   LAST-LINE TO-INDEX
				   (+ (- AT-LINE-LENGTH AT-INDEX) TO-INDEX))
	       ;; Copy FROM-LINE into AT-LINE.
	       (SET-LINE-LENGTH AT-LINE (+ AT-INDEX (- FROM-LINE-LENGTH FROM-INDEX)))
	       (DO ((FF FROM-INDEX (1+ FF))
		    (AT AT-INDEX (1+ AT))
		    (FATP (EQ (ARRAY-TYPE AT-LINE) 'ART-FAT-STRING))
		    (CH))
		   (( FF FROM-LINE-LENGTH))
		 (UNLESS (OR (< (SETQ CH (CHAR FROM-LINE FF)) CHAR-CODE-LIMIT) FATP)
		   (SET-LINE-ARRAY-TYPE AT-LINE 'ART-FAT-STRING)
		   (SETQ FATP T))
		 (SETF (CHAR AT-LINE AT) CH))
	       ;; Relocate buffer pointers.
	       (DOLIST (BP (LINE-BP-LIST AT-LINE))
		 (LET ((I (BP-INDEX BP)))
		   (IF (OR (> I AT-INDEX)
			   (AND (= I AT-INDEX)
				(EQ (BP-STATUS BP) ':MOVES)))
		       (MOVE-BP BP LAST-LINE (+ (- I AT-INDEX) TO-INDEX)))))))
	(DO ((PREV-LINE FIRST-LINE THIS-LINE)
	     (THIS-LINE)
	     (NODE (BP-NODE AT-BP))
	     (THE-LINE-BEYOND (LINE-NEXT AT-LINE))
	     (ORIGINAL-LINE (LINE-NEXT FROM-LINE) (LINE-NEXT ORIGINAL-LINE)))
	    ((EQ ORIGINAL-LINE TO-LINE)
	     (AND THE-LINE-BEYOND
		  (SETF (LINE-PREVIOUS THE-LINE-BEYOND) LAST-LINE))
	     (SETF (LINE-NEXT LAST-LINE) THE-LINE-BEYOND)
	     (SETF (LINE-NEXT PREV-LINE) LAST-LINE)
	     (SETF (LINE-PREVIOUS LAST-LINE) PREV-LINE))
	  (SETQ THIS-LINE (COPY-LINE ORIGINAL-LINE NODE))
	  (SETF (LINE-NEXT PREV-LINE) THIS-LINE)
	  (SETF (LINE-PREVIOUS THIS-LINE) PREV-LINE))
	(CREATE-BP LAST-LINE TO-INDEX)))))

(DEFUN INSERT-INTERVAL-MOVING (BP FIRST-BP &OPTIONAL LAST-BP IN-ORDER-P)
  "Insert a copy of an interval into text at AT-BP, relocating AT-BP to point after it.
Either pass the interval to insert as the second argument,
or pass a pair of BPs that delimit the interval.
The value is AT-BP, as modified."
  (LET ((NBP (INSERT-INTERVAL BP FIRST-BP LAST-BP IN-ORDER-P)))
    (MOVE-BP BP NBP)))

(DEFUN INSERT-THING (BP THING)
  "Insert a copy of the string, character or interval THING at BP.
BP is left pointing before the inserted text, unless it is of type :MOVES.
The value is a BP pointing after the inserted text."
  (IF (OR (STRINGP THING) (NUMBERP THING) (SYMBOLP THING))
      (INSERT BP THING)
    ;; This is a kludge, to prevent getting bad data into the mini-buffer
    ;; there may be a more general solution, i am not sure.
    (AND (EQ (BP-TOP-LEVEL-NODE BP) *INTERVAL*)
	 (NULL (SEND *WINDOW* :FONT-ALIST))
	 (DO ((LINE (BP-LINE (INTERVAL-FIRST-BP THING)) (LINE-NEXT LINE)))
	     ((NULL LINE))
	   (SET-LINE-ARRAY-TYPE LINE 'ART-STRING)))
    (INSERT-INTERVAL BP THING NIL T)))

;;; Delete the text between FROM-BP and TO-BP.  FROM-BP and TO-BP must be in order.
;;; Return a BP to the place from which text was deleted.
(DEFUN DELETE-INTERVAL (FROM-BP &OPTIONAL TO-BP IN-ORDER-P &AUX KEPT-LINE)
  "Delete the text of an interval from all intervals that contain it.
Either pass the interval to delete, or pass a pair of BPs that delimit the interval.
Whatever intervals contain the lines containing this text
will be modified by this operation."
  (GET-INTERVAL FROM-BP TO-BP IN-ORDER-P)
  (AND (NOT *BATCH-UNDO-SAVE*) *UNDO-SAVE-SMALL-CHANGES*
       (UNDO-SAVE-NEW-SMALL-CHANGE FROM-BP TO-BP))
  (MUNG-BP-INTERVAL FROM-BP)
  (LET ((FROM-LINE (BP-LINE FROM-BP))
	(FROM-INDEX (BP-INDEX FROM-BP))
	(TO-LINE (BP-LINE TO-BP))
	(TO-INDEX (BP-INDEX TO-BP)))
    (COND ((EQ FROM-LINE TO-LINE)
	   (COND ((= TO-INDEX FROM-INDEX))
		 ((< TO-INDEX FROM-INDEX)
		  (FERROR NIL "The BPs ~S and ~S were not in order." FROM-BP TO-BP))
		 (T
		  (LET ((LINE-LENGTH (LINE-LENGTH FROM-LINE))
			(NDEL (- TO-INDEX FROM-INDEX)))
		    (DO ((FL TO-INDEX (1+ FL))
			 (TL FROM-INDEX (1+ TL)))
			(( FL LINE-LENGTH))
		      (SETF (CHAR FROM-LINE TL) (CHAR FROM-LINE FL)))
		    (SET-LINE-LENGTH FROM-LINE (- LINE-LENGTH NDEL))
		    ;; Relocate buffer pointers.
		    (DOLIST (BP (LINE-BP-LIST FROM-LINE))
		      (LET ((I (BP-INDEX BP)))
			(COND (( I TO-INDEX)
			       (SETF (BP-INDEX BP) (- I NDEL)))
			      (( I FROM-INDEX)
			       (SETF (BP-INDEX BP) FROM-INDEX)))))
		    (MUNG-LINE FROM-LINE)))))
	  (T
	   (MUNG-BP-INTERVAL TO-BP)		;May be in another node
	   (COND ((AND (ZEROP TO-INDEX) (ZEROP FROM-INDEX))
		  ;; If deleting all of from-line and none of to-line,
		  ;; we don't need to touch to-line at all.
		  (SETQ KEPT-LINE TO-LINE)
		  (SETF (GETF (LINE-PLIST TO-LINE) 'PRECEDING-LINES-DELETED-TICK) (TICK))
		  (SETF (LINE-TICK FROM-LINE) 'DELETED))
		 (T
		  ;; Copy characters from end of TO-LINE to replace end of FROM-LINE.
		  (SETQ KEPT-LINE FROM-LINE)
		  (SETF (LINE-TICK TO-LINE) 'DELETED)
		  (LET ((TO-LENGTH (LINE-LENGTH TO-LINE)))
		    (OR (AND (= TO-INDEX TO-LENGTH)
			     (= FROM-INDEX (LINE-LENGTH FROM-LINE)))
			(MUNG-LINE FROM-LINE))
		    (SET-LINE-LENGTH FROM-LINE (+ FROM-INDEX (- TO-LENGTH TO-INDEX)))
		    (DO ((FTL TO-INDEX (1+ FTL))
			 (TFL FROM-INDEX (1+ TFL))
			 (FATP (EQ (ARRAY-TYPE FROM-LINE) 'ART-FAT-STRING))
			 (CH))
			(( FTL TO-LENGTH))
		      (UNLESS (OR (< (SETQ CH (CHAR TO-LINE FTL)) CHAR-CODE-LIMIT) FATP)
			(SET-LINE-ARRAY-TYPE FROM-LINE 'ART-FAT-STRING)
			(SETQ FATP T))
		      (SETF (CHAR FROM-LINE TFL) CH)))))
	   ;; Relocate BPs on the FROM-LINE.
	   (DOLIST (BP (LINE-BP-LIST FROM-LINE))
	     (MOVE-BP BP KEPT-LINE (MIN (BP-INDEX BP) FROM-INDEX)))
	   ;; Relocate BPs on the TO-LINE.
	   (DOLIST (BP (LINE-BP-LIST TO-LINE))
	     (MOVE-BP BP KEPT-LINE
		      (+ FROM-INDEX (MAX 0 (- (BP-INDEX BP) TO-INDEX)))))
	   ;; Loop over intermedidiate lines, relocating bps.
	   (DO ((LINE (LINE-NEXT FROM-LINE) (LINE-NEXT LINE)))
	       ((EQ LINE TO-LINE)
		;; We have reached the TO-LINE.
		;; Splice out all lines FROM-LINE to TO-LINE inclusive except KEPT-LINE.
		(LET ((LINE-BEFORE (LINE-PREVIOUS FROM-LINE))
		      (LINE-AFTER (LINE-NEXT TO-LINE)))
		  (SETF (LINE-NEXT KEPT-LINE) LINE-AFTER)
		  (SETF (LINE-PREVIOUS KEPT-LINE) LINE-BEFORE)
		  (AND LINE-BEFORE (SETF (LINE-NEXT LINE-BEFORE) KEPT-LINE))
		  (AND LINE-AFTER (SETF (LINE-PREVIOUS LINE-AFTER) KEPT-LINE))))
	     (OR LINE
		 (FERROR NIL "The BPs ~S and ~S were not in order." FROM-BP TO-BP))
	     (SETF (LINE-TICK LINE) 'DELETED)
	     (DOLIST (BP (LINE-BP-LIST LINE))
	       (MOVE-BP BP KEPT-LINE FROM-INDEX))))))
  (COPY-BP FROM-BP))

;;; This is an internal function of INSERT and INSERT-INTERVAL
(DEFUN INSERT-WITHIN-LINE (LINE INDEX STRING FROM TO)
  (AND (GETF (LINE-PLIST LINE) ':DIAGRAM) (BARF "Diagram line"))
  (COND ((EQ STRING LINE)
	 (SETQ STRING (SUBSTRING STRING FROM TO)
	       TO (- TO FROM)
	       FROM 0)))
  (LET ((LINE-LENGTH (LINE-LENGTH LINE))
	(STRING-LENGTH (- TO FROM)))
    (LET ((NEW-LINE-LENGTH (+ LINE-LENGTH STRING-LENGTH)))
      (SET-LINE-LENGTH LINE NEW-LINE-LENGTH)
      (OR (EQ (ARRAY-TYPE STRING) 'ART-STRING) (EQ (ARRAY-TYPE LINE) 'ART-FAT-STRING)
	  (SET-LINE-ARRAY-TYPE LINE 'ART-FAT-STRING))
      ;; Move the characters ahead of the inserting forward.
      (DO ((LF (1- LINE-LENGTH) (1- LF))
	   (LT (1- NEW-LINE-LENGTH) (1- LT)))
	  ((< LF INDEX))
	(SETF (CHAR LINE LT) (CHAR LINE LF)))
      ;; Insert the new characters into the line.
      (COPY-ARRAY-PORTION STRING FROM TO LINE INDEX (+ INDEX STRING-LENGTH))
      ;; Relocate buffer pointers.
      (DOLIST (BP (LINE-BP-LIST LINE))
	(LET ((I (BP-INDEX BP)))
	  (IF (OR (> I INDEX)
		  (AND (= I INDEX)
		       (EQ (BP-STATUS BP) ':MOVES)))
	      (SETF (BP-INDEX BP) (+ I STRING-LENGTH)))))
      (MUNG-LINE LINE)
      (CREATE-BP LINE (+ INDEX STRING-LENGTH)))))

(DEFUN INSERT-LINE-WITH-LEADER (LINE AT-LINE)
  "Insert LINE into *INTERVAL* before AT-LINE.
LINE should have a leader of the proper size.  It is actually spliced in."
  (LET ((BP (CREATE-BP AT-LINE 0)))
    (AND (NOT *BATCH-UNDO-SAVE*) *UNDO-SAVE-SMALL-CHANGES*
	 (UNDO-SAVE-NEW-SMALL-CHANGE BP BP))
    (MUNG-BP-INTERVAL BP))
  (LET ((PREV (LINE-PREVIOUS AT-LINE)))
    (COND (PREV
           (SETF (LINE-NEXT PREV) LINE)
           (SETF (LINE-PREVIOUS LINE) PREV))))
  (SETF (LINE-NEXT LINE) AT-LINE)
  (SETF (LINE-PREVIOUS AT-LINE) LINE)
  (SETF (LINE-NODE LINE) (LINE-NODE AT-LINE))
  (SETF (LINE-TICK LINE) *TICK*)
  ;; Now hack the BPs
  (DOLIST (BP (LINE-BP-LIST AT-LINE))
    (WHEN (EQ (BP-STATUS BP) ':NORMAL)
      (SETF (LINE-BP-LIST AT-LINE) (DELQ BP (LINE-BP-LIST AT-LINE)))
      (PUSH BP (LINE-BP-LIST LINE))
      (SETF (BP-LINE BP) LINE))))

;;; This is an internal function of INSERT-INTERVAL
(DEFUN COPY-LINE (LINE NODE)
  (LET ((LEN (LINE-LENGTH LINE)))
    (LET ((NEW-LINE (CREATE-LINE (ARRAY-TYPE LINE) LEN NODE)))
      (COPY-ARRAY-CONTENTS LINE NEW-LINE)
      (SETF (LINE-PLIST NEW-LINE) (LINE-PLIST LINE))
      NEW-LINE)))

;;; This takes either an interval or a pair of BPs, and returns
;;; an interval with the same characters.
(DEFUN COPY-INTERVAL (FROM-BP &OPTIONAL TO-BP IN-ORDER-P &OPTIONAL INTO-INTERVAL)
  "Given an interval, construct a new interval whose text is a copy of the old.
The interval to copy can be specified as an interval object or
as a pair of BPs that delimit the interval.
If INTO-INTERVAL is specified, it is an interval to copy the text into."
  (GET-INTERVAL FROM-BP TO-BP IN-ORDER-P)
  (SETQ INTO-INTERVAL (MAKE-NODE *TICK*))
  (LET ((FROM-LINE (BP-LINE FROM-BP))
	(FROM-INDEX (BP-INDEX FROM-BP))
	(TO-LINE (BP-LINE TO-BP))
	(TO-INDEX (BP-INDEX TO-BP)))
    (COND ((EQ FROM-LINE TO-LINE)
	   (LET ((LEN (- TO-INDEX FROM-INDEX)))
	     (LET ((LINE (CREATE-LINE (ARRAY-TYPE FROM-LINE) LEN INTO-INTERVAL)))
	       (DO ((FLF FROM-INDEX (1+ FLF))
		    (LT 0 (1+ LT)))
		   (( LT LEN))
		 (SETF (CHAR LINE LT) (CHAR FROM-LINE FLF)))
	       (AND (ZEROP FROM-INDEX) (= TO-INDEX (LINE-LENGTH FROM-LINE))
		    (SETF (LINE-PLIST LINE) (LINE-PLIST FROM-LINE)))
	       (SETF (INTERVAL-FIRST-BP INTO-INTERVAL) (CREATE-BP LINE 0 :NORMAL))
	       (SETF (INTERVAL-LAST-BP INTO-INTERVAL) (CREATE-BP LINE LEN :MOVES)))))
	  (T
	   (LET ((FROM-LINE-LENGTH (LINE-LENGTH FROM-LINE)))
	     (LET ((FIRST-LINE (CREATE-LINE (ARRAY-TYPE FROM-LINE)
					    (- FROM-LINE-LENGTH FROM-INDEX)
					    INTO-INTERVAL))
		   (LAST-LINE (CREATE-LINE (ARRAY-TYPE TO-LINE) TO-INDEX INTO-INTERVAL)))
	       ;; Copy text from FROM-LINE to FIRST-LINE.
	       (DO ((FRF FROM-INDEX (1+ FRF))
		    (FIT 0 (1+ FIT)))
		   (( FRF FROM-LINE-LENGTH))
		 (SETF (CHAR FIRST-LINE FIT) (CHAR FROM-LINE FRF)))
	       (AND (ZEROP FROM-INDEX) (SETF (LINE-PLIST FIRST-LINE) (LINE-PLIST FROM-LINE)))
	       ;; Copy text from TO-LINE to LAST-LINE.
	       (DO ((I 0 (1+ I)))
		   (( I TO-INDEX))
		 (SETF (CHAR LAST-LINE I) (CHAR TO-LINE I)))
	       (AND (= TO-INDEX (LINE-LENGTH TO-LINE))
		    (SETF (LINE-PLIST LAST-LINE) (LINE-PLIST TO-LINE)))
	       (DO ((PREV-LINE FIRST-LINE THIS-LINE)
		    (THIS-LINE)
		    (ORIGINAL-LINE (LINE-NEXT FROM-LINE) (LINE-NEXT ORIGINAL-LINE)))
		   ((EQ ORIGINAL-LINE TO-LINE)
		    (SETF (LINE-NEXT PREV-LINE) LAST-LINE)
		    (SETF (LINE-PREVIOUS LAST-LINE) PREV-LINE)
		    (SETF (INTERVAL-FIRST-BP INTO-INTERVAL) (CREATE-BP FIRST-LINE 0 ':NORMAL))
		    (SETF (INTERVAL-LAST-BP INTO-INTERVAL) (CREATE-BP LAST-LINE TO-INDEX ':MOVES)))
		 (SETQ THIS-LINE (COPY-LINE ORIGINAL-LINE INTO-INTERVAL))
		 (SETF (LINE-NEXT PREV-LINE) THIS-LINE)
		 (SETF (LINE-PREVIOUS THIS-LINE) PREV-LINE)))))))
  INTO-INTERVAL)

;;; Make a string whose text is that of the interval.
(DEFUN STRING-INTERVAL (FROM-BP &OPTIONAL TO-BP IN-ORDER-P REMOVE-FONTS-P)
  "Return a string whose text is a copy of the specified interval.
If REMOVE-FONTS-P is non-NIL, all font information is discarded
 and the value is always ART-STRING.
The interval to copy can be specified as an interval object or
as a pair of BPs that delimit the interval."
  (GET-INTERVAL FROM-BP TO-BP IN-ORDER-P)
  (LET ((FROM-LINE (BP-LINE FROM-BP))
	(FROM-INDEX (BP-INDEX FROM-BP))
	(TO-LINE (BP-LINE TO-BP))
	(TO-INDEX (BP-INDEX TO-BP))
	STRING)
    (SETQ STRING (MAKE-ARRAY (COUNT-CHARS FROM-BP TO-BP)
			     :TYPE (IF REMOVE-FONTS-P ART-STRING (ARRAY-TYPE FROM-LINE))))
    (COND ((EQ FROM-LINE TO-LINE)
	   ;; Within a line.  Copy the characters.
	   (DO ((LF FROM-INDEX (1+ LF))
		(ST 0 (1+ ST)))
	       (( LF TO-INDEX))
	     (SETF (CHAR STRING ST) (CHAR FROM-LINE LF))))
	  (T
	   (LET ((ST 0))
	     ;; Copy from the first line.
	     (DO ((FLF FROM-INDEX (1+ FLF))
		  (LEN (LINE-LENGTH FROM-LINE)))
		 (( FLF LEN))
	       (SETF (CHAR STRING ST) (CHAR FROM-LINE FLF))
	       (INCF ST))
	     (SETF (CHAR STRING ST) #/NEWLINE)
	     (INCF ST)
	     ;; Copy from intermediate lines.
	     (DO ((LINE (LINE-NEXT FROM-LINE) (LINE-NEXT LINE)))
		 ((EQ LINE TO-LINE))
	       (DO ((LF 0 (1+ LF))
		    (LEN (LINE-LENGTH LINE)))
		   (( LF LEN))
		 (SETF (CHAR STRING ST) (CHAR LINE LF))
		 (INCF ST))
	       (SETF (CHAR STRING ST) #/NEWLINE)
	       (INCF ST))
	     ;; Copy from the last line.
	     (DO ((TLF 0 (1+ TLF)))
		 (( TLF TO-INDEX))
	       (SETF (CHAR STRING ST) (CHAR TO-LINE TLF))
	       (INCF ST)))))
    STRING))

;;;Insert n copies of a character
(DEFUN INSERT-CHARS (BP CHAR N)
  "Insert N copies of CHAR at BP.
BP is left pointing before the inserted text, unless it is of type :MOVES.
The value is a BP pointing after the inserted text."
  (INSERT BP (MAKE-ARRAY N :TYPE (IF (ZEROP (CHAR-BITS CHAR))
				     'ART-STRING
				   'ART-FAT-STRING)
			 :INITIAL-ELEMENT CHAR)))