From a94eb7b0377d3d9fe74261d6977280cf1c1f1302 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 5 Oct 1993 23:05:56 +0000
Subject: [PATCH] Major rewrite of text property mechanism.  New implementation
 uses red/black trees for properties within intervals, and uses red/black
 balancing algorithm for intervals.  Interface to editor is simplified, as is
 the interface to the undo mechanism.  The redisplay code no longer uses the
 internals of the implementation, but instead uses standard external entries. 
 Adjacent intervals are now merged together when their property sets are the
 same; property data are compared for equality using EQV?.

---
 v7/src/edwin/bufwfs.scm |   29 +-
 v7/src/edwin/edwin.pkg  |   15 +-
 v7/src/edwin/txtprp.scm | 1251 +++++++++++++++++++--------------------
 v7/src/edwin/undo.scm   |   36 +-
 4 files changed, 629 insertions(+), 702 deletions(-)

diff --git a/v7/src/edwin/bufwfs.scm b/v7/src/edwin/bufwfs.scm
index 51293476c..ecb8a5c81 100644
--- a/v7/src/edwin/bufwfs.scm
+++ b/v7/src/edwin/bufwfs.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: bufwfs.scm,v 1.17 1993/08/25 05:11:12 cph Exp $
+;;;	$Id: bufwfs.scm,v 1.18 1993/10/05 23:05:51 cph Exp $
 ;;;
 ;;;	Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology
 ;;;
@@ -213,28 +213,26 @@
 		(y y-start))
 	     (if (fix:< y yu)
 		 (let loop
-		     ((interval (and (group-text-properties group)
-				     (find-interval group index)))
-		      (column-offset column-offset)
+		     ((column-offset column-offset)
 		      (xl* xl)
 		      (index index))
 		   (let ((end-index*
-			  (if interval
-			      (let ((iend (interval-end interval)))
-				(if (fix:< end-index iend) end-index iend))
+			  (or (next-specific-property-change group
+							     index
+							     end-index
+							     'HIGHLIGHTED)
 			      end-index))
 			 ;; If line is clipped off top of window, draw it 
 			 ;; anyway so that index and column calculations
 			 ;; get done. Use first visible line for image
 			 ;; output so as to avoid consing a dummy image
 			 ;; buffer.
-			 (line (screen-get-output-line
-				screen
-				(if (fix:< y yl) yl y)
-				xl* xu
-				(and interval
-				     (interval-property interval
-							'HIGHLIGHTED #f)))))
+			 (line
+			  (screen-get-output-line
+			   screen
+			   (if (fix:< y yl) yl y)
+			   xl* xu
+			   (get-text-property group index 'HIGHLIGHTED #f))))
 		     (let ((fill-line
 			    (lambda (index xl*)
 			      (group-image! group index end-index*
@@ -251,8 +249,7 @@
 					     ((fix:= x xu))
 					   (string-set! line x #\space)))))
 				    ((fix:= (vector-ref results 0) end-index*)
-				     (loop (next-interval interval)
-					   (fix:+ column-offset
+				     (loop (fix:+ column-offset
 						  (fix:- (vector-ref results 1)
 							 xl*))
 					   (vector-ref results 1)
diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg
index 6e3930dd9..1e629c400 100644
--- a/v7/src/edwin/edwin.pkg
+++ b/v7/src/edwin/edwin.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: edwin.pkg,v 1.133 1993/09/09 21:42:13 cph Exp $
+$Id: edwin.pkg,v 1.134 1993/10/05 23:05:56 cph Exp $
 
 Copyright (c) 1989-1993 Massachusetts Institute of Technology
 
@@ -837,7 +837,6 @@ MIT in each case. |#
   (files "txtprp")
   (parent (edwin))
   (export (edwin)
-	  add-text-properties
 	  add-text-property
 	  get-text-properties
 	  get-text-property
@@ -846,9 +845,7 @@ MIT in each case. |#
 	  next-specific-property-change
 	  previous-property-change
 	  previous-specific-property-change
-	  remove-text-properties
-	  remove-text-property
-	  set-text-properties)
+	  remove-text-property)
   (export (edwin group-operations)
 	  text-not-deleteable?
 	  text-not-insertable?
@@ -856,12 +853,8 @@ MIT in each case. |#
 	  update-intervals-for-insertion!)
   (export (edwin undo)
 	  group-extract-properties
-	  group-reinsert-properties!)
-  (export (edwin window)
-	  find-interval
-	  interval-end
-	  interval-property
-	  next-interval))
+	  group-reinsert-properties!
+	  reinsert-properties-size))
 
 ;;;; This is the variant used under DOS and NT (for now)
 
diff --git a/v7/src/edwin/txtprp.scm b/v7/src/edwin/txtprp.scm
index c129d3e8e..1290acb09 100644
--- a/v7/src/edwin/txtprp.scm
+++ b/v7/src/edwin/txtprp.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: txtprp.scm,v 1.11 1993/09/09 21:43:12 cph Exp $
+;;;	$Id: txtprp.scm,v 1.12 1993/10/05 23:05:18 cph Exp $
 ;;;
 ;;;	Copyright (c) 1993 Massachusetts Institute of Technology
 ;;;
@@ -42,78 +42,184 @@
 ;;; of that license should have been included along with this file.
 ;;;
 
-;;;; Based on the text-properties in GNU Emacs
+;;;; Text Properties
+;;;  An improved version of a mechanism from GNU Emacs 19
 
 (declare (usual-integrations))
 
 (define (add-text-property group start end key datum)
   (validate-region-arguments group start end 'ADD-TEXT-PROPERTY)
   (validate-symbol-argument key 'ADD-TEXT-PROPERTY)
-  (step group start end
-	(lambda (alist)
-	  (let ((entry (assq key alist)))
-	    (and entry
-		 (eq? (cdr entry) datum))))
-	(lambda (alist)
-	  (let loop ((alist alist))
-	    (cond ((null? alist)
-		   (list (cons key datum)))
-		  ((eq? key (caar alist))
-		   (cons (cons key datum) (cdr alist)))
-		  (else
-		   (cons (car alist) (loop (cdr alist)))))))))
-
-(define (add-text-properties group start end alist)
-  (validate-region-arguments group start end 'ADD-TEXT-PROPERTIES)
-  (validate-alist-argument alist 'ADD-TEXT-PROPERTIES)
-  (step group start end
-	(lambda (alist*)
-	  (alist-subset? alist alist*))
-	(lambda (alist*)
-	  (append (alist-copy alist)
-		  (list-transform-negative alist*
-		    (lambda (association)
-		      (assq (car association) alist)))))))
+  (modify-text-properties group start end
+    (lambda (properties)
+      (eq? (properties/lookup properties key no-datum) datum))
+    (lambda (interval)
+      (properties/insert! (interval-properties interval) key datum))))
 
 (define (remove-text-property group start end key)
   (validate-region-arguments group start end 'REMOVE-TEXT-PROPERTY)
   (validate-symbol-argument key 'REMOVE-TEXT-PROPERTY)
-  (step group start end
-	(lambda (alist)
-	  (not (assq key alist)))
-	(lambda (alist)
-	  (let loop ((alist alist))
-	    (cond ((null? alist) '())
-		  ((eq? key (caar alist)) (cdr alist))
-		  (else (cons (car alist) (loop (cdr alist)))))))))
-
-(define (remove-text-properties group start end keys)
-  (validate-region-arguments group start end 'REMOVE-TEXT-PROPERTIES)
-  (if (not (and (list? keys)
-		(for-all? keys symbol?)))
-      (error:wrong-type-argument keys "list of symbols"
-				 'REMOVE-TEXT-PROPERTIES))
-  (step group start end
-	(lambda (alist*)
-	  (let loop ((keys keys))
-	    (or (null? keys)
-		(and (not (assq (car keys) alist*))
-		     (loop (cdr keys))))))
-	(lambda (alist*)
-	  (list-transform-negative alist*
-	    (lambda (association)
-	      (memq (car association) keys))))))
-
-(define (set-text-properties group start end alist)
-  (validate-region-arguments group start end 'SET-TEXT-PROPERTIES)
-  (validate-alist-argument alist 'SET-TEXT-PROPERTIES)
-  (step group start end
-	(lambda (alist*)
-	  (alist-same-set? alist alist*))
-	(lambda (alist*)
-	  alist*
-	  (alist-copy alist))))
+  (modify-text-properties group start end
+    (lambda (properties)
+      (eq? (properties/lookup properties key no-datum) no-datum))
+    (lambda (interval)
+      (properties/delete! (interval-properties interval) key))))
+
+(define (get-text-properties group index)
+  (validate-point-arguments group index 'GET-TEXT-PROPERTIES)
+  (if (and (group-text-properties group) (fix:< index (group-length group)))
+      (properties->alist (interval-properties (find-interval group index)))
+      '()))
+
+(define (get-text-property group index key default)
+  (validate-point-arguments group index 'GET-TEXT-PROPERTY)
+  (validate-symbol-argument key 'GET-TEXT-PROPERTY)
+  (if (and (group-text-properties group) (fix:< index (group-length group)))
+      (interval-property (find-interval group index) key default)
+      default))
+
+(define (local-comtabs mark)
+  (get-text-property (mark-group mark) (mark-index mark) 'COMMAND-TABLE #f))
+
+(define (next-property-change group start end)
+  (validate-region-arguments group start end 'NEXT-PROPERTY-CHANGE)
+  (and (group-text-properties group)
+       (fix:< start end)
+       (let ((end* (interval-end (find-interval group start))))
+	 (and (fix:< end* end)
+	      end*))))
+
+(define (previous-property-change group start end)
+  (validate-region-arguments group start end 'PREVIOUS-PROPERTY-CHANGE)
+  (and (group-text-properties group)
+       (fix:< start end)
+       (let ((start* (interval-start (find-interval group (fix:- end 1)))))
+	 (and (fix:< start start*)
+	      start*))))
+
+(define (next-specific-property-change group start end key)
+  (validate-region-arguments group start end 'NEXT-SPECIFIC-PROPERTY-CHANGE)
+  (validate-symbol-argument key 'NEXT-SPECIFIC-PROPERTY-CHANGE)
+  (and (group-text-properties group)
+       (fix:< start end)
+       (let ((interval (find-interval group start)))
+	 (let ((datum (interval-property interval key no-datum)))
+	   (let loop ((interval interval))
+	     (let ((end* (interval-end interval)))
+	       (and (fix:< end* end)
+		    (let ((next (next-interval interval)))
+		      (if (datum=? datum (interval-property next key no-datum))
+			  (loop next)
+			  end*)))))))))
+
+(define (previous-specific-property-change group start end key)
+  (validate-region-arguments group start end 'PREV-SPECIFIC-PROPERTY-CHANGE)
+  (validate-symbol-argument key 'PREV-SPECIFIC-PROPERTY-CHANGE)
+  (and (group-text-properties group)
+       (fix:< start end)
+       (let ((interval (find-interval group (fix:- end 1))))
+	 (let ((datum (interval-property interval key no-datum)))
+	   (let loop ((interval interval))
+	     (let ((start* (interval-start interval)))
+	       (and (fix:< start start*)
+		    (let ((prev (previous-interval interval)))
+		      (if (datum=? datum (interval-property prev key no-datum))
+			  (loop prev)
+			  start*)))))))))
+
+(define (modify-text-properties group start end dont-modify? modify!)
+  (call-with-values
+      (lambda () (intervals-to-modify group start end dont-modify?))
+    (lambda (start-interval end-interval)
+      (if start-interval
+	  (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
+	    (prepare-to-modify-intervals group start-interval end-interval)
+	    (let loop ((interval start-interval))
+	      (modify! interval)
+	      (if (not (eq? interval end-interval))
+		  (loop (next-interval interval))))
+	    (let ((end (interval-end end-interval)))
+	      (let loop
+		  ((interval
+		    (or (previous-interval start-interval)
+			start-interval)))
+		(let ((next
+		       (let ((next (next-interval interval)))
+			 (if (and next
+				  (properties=? (interval-properties interval)
+						(interval-properties next)))
+			     (begin
+			       (increment-interval-length
+				next
+				(interval-length interval))
+			       (delete-interval interval group))
+			     next))))
+		  (if (and next
+			   (not (fix:= end (interval-start next))))
+		      (loop next)))))
+	    (set-interrupt-enables! interrupt-mask))))))
+
+(define (intervals-to-modify group start end dont-modify?)
+  (letrec
+      ((find-start
+	(lambda (interval)
+	  (if (fix:<= end (interval-end interval))
+	      (values #f #f)
+	      (let ((interval (next-interval interval)))
+		(if (dont-modify? (interval-properties interval))
+		    (find-start interval)
+		    (find-end interval))))))
+       (find-end
+	(lambda (start-interval)
+	  (let loop ((prev start-interval) (interval start-interval))
+	    (let ((end* (interval-end interval)))
+	      (if (fix:< end end*)
+		  (if (dont-modify? (interval-properties interval))
+		      (values start-interval prev)
+		      (let ((end-interval
+			     (split-interval-left interval end group)))
+			(values (if (eq? interval start-interval)
+				    end-interval
+				    start-interval)
+				end-interval)))
+		  (let ((prev
+			 (if (dont-modify? (interval-properties interval))
+			     prev
+			     interval)))
+		    (if (fix:= end end*)
+			(values start-interval prev)
+			(loop prev (next-interval interval))))))))))
+    (if (fix:< start end)
+	(let ((interval
+	       (if (group-text-properties group)
+		   (find-interval group start)
+		   (make-initial-interval group))))
+	  (if (dont-modify? (interval-properties interval))
+	      (find-start interval)
+	      (find-end
+	       (if (fix:= start (interval-start interval))
+		   interval
+		   (split-interval-right interval start group)))))
+	(values #f #f))))
 
+(define (prepare-to-modify-intervals group start-interval end-interval)
+  (undo-record-intervals group start-interval end-interval)
+  (let ((start (interval-start start-interval))
+	(end (interval-end end-interval)))
+    (if (group-start-changes-index group)
+	(begin
+	  (if (fix:< start (group-start-changes-index group))
+	      (set-group-start-changes-index! group start))
+	  (if (fix:> end (group-end-changes-index group))
+	      (set-group-end-changes-index! group end)))
+	(begin
+	  (set-group-start-changes-index! group start)
+	  (set-group-end-changes-index! group end))))
+  (set-group-modified?! group #t)
+  (vector-set! group
+	       group-index:modified-tick
+	       (fix:+ (group-modified-tick group) 1)))
+
 (define (validate-region-arguments group start end procedure)
   (validate-group group procedure)
   (validate-group-index group start procedure)
@@ -125,170 +231,25 @@
   (validate-group group procedure)
   (validate-group-index group index procedure))
 
-(define (validate-group group procedure)
-  (if (not (group? group))
-      (error:wrong-type-argument group "group" procedure)))
-
 (define (validate-group-index group index procedure)
   (if (not (fix:fixnum? index))
       (error:wrong-type-argument index "fixnum" procedure))
-  (if (not (and (fix:<= (group-start-index group) index)
-		(fix:<= index (group-end-index group))))
+  (if (not (and (fix:<= 0 index) (fix:<= index (group-length group))))
       (error:bad-range-argument index procedure)))
 
-(define (validate-alist-argument alist procedure)
-  (if (not (alist? alist))
-      (error:wrong-type-argument alist "alist" procedure))
-  (if (not (let loop ((alist alist))
-	     (or (null? alist)
-		 (and (symbol? (caar alist))
-		      (not (assq (caar alist) (cdr alist)))
-		      (loop (cdr alist))))))
-      (error:bad-range-argument alist procedure)))
+(define (validate-group group procedure)
+  (if (not (group? group))
+      (error:wrong-type-argument group "group" procedure)))
 
 (define (validate-symbol-argument key procedure)
-  (if (not (symbol? key))
+  (if (not (interned-symbol? key))
       (error:wrong-type-argument key "symbol" procedure)))
 
-(define (alist-subset? x y)
-  (let loop ((x x))
-    (or (null? x)
-	(let ((entry (assq (caar x) y)))
-	  (and entry
-	       (eq? (cdar x) (cdr entry))
-	       (loop (cdr x)))))))
-
-(define (alist-same-set? x y)
-  ;; Slow but effective.
-  (and (alist-subset? x y)
-       (alist-subset? y x)))
-
-(define (step group start end dont-modify? modify-alist)
-  (define (loop i lst)
-    ;; we now know that we are starting on the begining of an interval
-    (let ((next (next-interval i))
-	  (p (interval-properties i))
-	  (start (interval-start i)))
-      (let ((end* (if next (interval-start next) (interval-end i))))
-	(if (fix:> end end*)
-	    (loop next
-		  (if (dont-modify? p)
-		      lst
-		      (begin
-			(set-interval-properties! i (modify-alist p))
-			(cons (list start end* p) lst))))
-	    (let ((i
-		   (if (fix:< end end*) (split-interval-left i end group) i)))
-	      (if (dont-modify? p)
-		  lst
-		  (begin
-		    (set-interval-properties! i (modify-alist p))
-		    (cons (list start end p) lst))))))))
-  (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
-    (let ((p
-	   (let ((i
-		  (if (group-text-properties group)
-		      (find-interval group start)
-		      (create-initial-interval group))))
-	     (let ((start* (interval-start i)))
-	       (if (fix:= start start*)
-		   (loop i '())
-		   (let ((dont-split? (dont-modify? (interval-properties i)))
-			 (next (next-interval i)))
-		     (if (and dont-split?
-			      (or (not next)
-				  (fix:<= end (interval-start next))))
-			 '()
-			 (loop (if dont-split?
-				   next
-				   (split-interval-right i start group))
-			       '()))))))))
-      (cond ((group-start-changes-index group)
-	     =>
-	     (lambda (gsc)
-	       (set-group-start-changes-index!
-		group
-		(if (fix:< start gsc) start gsc))
-	       (set-group-end-changes-index!
-		group
-		(let ((gec (group-end-changes-index group)))
-		  (if (fix:> end gec) end gec)))))
-	    (else
-	     (set-group-start-changes-index! group start)
-	     (set-group-end-changes-index! group end)))
-      (if (not (null? p))
-	  (begin
-	    (undo-record-property-changes! group p)
-	    (set-group-modified?! group true)
-	    (vector-set! group group-index:modified-tick
-			 (fix:+ (group-modified-tick group) 1)))))
-    (set-interrupt-enables! interrupt-mask)))
+(define no-datum
+  (list 'NO-DATUM))
 
-(define (get-text-properties group index)
-  (validate-point-arguments group index 'GET-TEXT-PROPERTIES)
-  (if (group-text-properties group)
-      (alist-copy (interval-properties (find-interval group index)))
-      '()))
+;;;; READ-ONLY Property
 
-(define (get-text-property group index key default)
-  (validate-point-arguments group index 'GET-TEXT-PROPERTY)
-  (validate-symbol-argument key 'GET-TEXT-PROPERTY)
-  (if (group-text-properties group)
-      (interval-property (find-interval group index) key default)
-      default))
-
-(define (local-comtabs mark)
-  (get-text-property (mark-group mark) (mark-index mark) 'COMMAND-TABLE #f))
-
-;;; The next four procedures are all about the same
-;;; and none have been tested.
-
-(define (next-property-change group index)
-  (validate-point-arguments group index 'NEXT-PROPERTY-CHANGE)
-  (and (group-text-properties group)
-       (let ((z (find-interval group index)))
-	 (let ((p1 (interval-properties z)))
-	   (let loop ((next (next-interval z)))
-	     (and next
-		  (if (alist-same-set? p1 (interval-properties next))
-		      (loop (next-interval next))
-		      (interval-start next))))))))
-
-(define (next-specific-property-change group index key)
-  (validate-point-arguments group index 'NEXT-SPECIFIC-PROPERTY-CHANGE)
-  (validate-symbol-argument key 'NEXT-SPECIFIC-PROPERTY-CHANGE)
-  (and (group-text-properties group)
-       (let ((z (find-interval group index)))
-	 (let ((p (assq key (interval-properties z))))
-	   (let loop ((next (next-interval z)))
-	     (and next
-		  (if (eq? p (assq key (interval-properties next)))
-		      (loop (next-interval next))
-		      (interval-start next))))))))
-
-(define (previous-property-change group index)
-  (validate-point-arguments group index 'PREVIOUS-PROPERTY-CHANGE)
-  (and (group-text-properties group)
-       (let ((z (find-interval group index)))
-	 (let ((p1 (interval-properties z)))
-	   (let loop ((prev (previous-interval z)))
-	     (and prev
-		  (if (alist-same-set? p1 (interval-properties prev))
-		      (loop (previous-interval prev))
-		      (interval-start prev))))))))
-
-(define (previous-specific-property-change group index key)
-  (validate-point-arguments group index 'PREV-SPECIFIC-PROPERTY-CHANGE)
-  (validate-symbol-argument key 'PREV-SPECIFIC-PROPERTY-CHANGE)
-  (and (group-text-properties group)
-       (let ((z (find-interval group index)))
-	 (let ((p (assq key (interval-properties z))))
-	   (let loop ((prev (previous-interval z)))
-	     (and prev
-		  (if (eq? p (assq key (interval-properties prev)))
-		      (loop (previous-interval prev))
-		      (interval-start prev))))))))
-
 ;;; The READ-ONLY property is applied to a contiguous region of
 ;;; characters.  No insertions are allowed within that region, and no
 ;;; deletions may intersect that region.  However, insertions may
@@ -303,11 +264,10 @@
 ;;; between the regions, but not inside of them.
 
 (define (text-not-insertable? group start)
-  (and (not (let ((root (group-text-properties group)))
-	      (or (not root)
-		  (fix:= start 0)
-		  (fix:= start (interval-total-length root)))))
-       (not (eq? 'FULLY (group-writable? group)))
+  ;; Assumes that (GROUP-TEXT-PROPERTIES GROUP) is not #F.
+  (and (not (eq? 'FULLY (group-writable? group)))
+       (not (fix:= start 0))
+       (not (fix:= start (group-length group)))
        (let ((interval (find-interval group start)))
 	 (let ((datum (interval-property interval 'READ-ONLY #f)))
 	   (and datum
@@ -320,165 +280,233 @@
 			     (interval-property (next-interval interval)
 						'READ-ONLY #f)))))))))
 
-(define (update-intervals-for-insertion! group start amount)
-  (if (group-text-properties group)
-      (begin
-	(add-amount-up-tree (find-interval group start) amount)
-	(set-text-properties group start (fix:+ start amount) '()))))
-
 (define (text-not-deleteable? group start end)
-  (and (group-text-properties group)
-       (not (eq? 'FULLY (group-writable? group)))
+  ;; Assumes that (GROUP-TEXT-PROPERTIES GROUP) is not #F.
+  (and (not (eq? 'FULLY (group-writable? group)))
+       (fix:< start end)
        (let loop ((interval (find-interval group start)))
 	 (or (interval-property interval 'READ-ONLY #f)
-	     (let ((next (next-interval interval)))
-	       (and next
-		    (fix:> end (interval-start next))
-		    (loop next)))))))
+	     (and (not (fix:<= end (interval-end interval)))
+		  (let ((next (next-interval interval)))
+		    (and next
+			 (loop next))))))))
+
+;;;; Insertion and Deletion
+
+(define (update-intervals-for-insertion! group start length)
+  ;; Assumes that (GROUP-TEXT-PROPERTIES GROUP) is not #F.
+  ;; Depends on FIND-INTERVAL returning the rightmost interval when
+  ;; START is GROUP-LENGTH.
+  (let ((interval (find-interval group start)))
+    (increment-interval-length interval length)
+    (if (not (properties/empty? (interval-properties interval)))
+	(set-interval-properties!
+	 (let ((interval
+		(if (fix:= start (interval-start interval))
+		    interval
+		    (split-interval-right interval start group)))
+	       (end (fix:+ start length)))
+	   (if (fix:= end (interval-end interval))
+	       interval
+	       (split-interval-left interval end group)))
+	 (make-empty-properties)))))
 
 (define (update-intervals-for-deletion! group start end)
-  (if (group-text-properties group)
-      (letrec ((loop
-		;; we know that we are starting on an interval boundary
-		(lambda (interval amount)
-		  (let ((amount* (interval-length interval)))
-		    (cond ((fix:= amount amount*)
-			   (add-amount-up-tree interval (fix:- 0 amount))
-			   (delete-interval interval group))
-			  ((fix:> amount amount*)
-			   (add-amount-up-tree interval (fix:- 0 amount*))
-			   (let ((next (next-interval interval)))
-			     (delete-interval interval group)
-			     (loop next (fix:- amount amount*))))
-			  (else
-			   (add-amount-up-tree interval (fix:- 0 amount))))))))
-	(let ((amount (fix:- end start)))
-	  (let* ((interval (find-interval group start))
-		 (start* (interval-start interval)))
-	    (if (fix:= start* start)
-		(loop interval amount)
-		(let ((amount* (fix:- (interval-length interval)
-				      (fix:- start start*))))
-		  (if (fix:>= amount* amount)
-		      (add-amount-up-tree interval (fix:- 0 amount))
-		      (begin
-			(add-amount-up-tree interval (fix:- 0 amount*))
-			(loop (next-interval interval)
-			      (fix:- amount amount*)))))))))))
+  ;; Assumes that (GROUP-TEXT-PROPERTIES GROUP) is not #F.
+  ;; Assumes that (FIX:< START END).
+  (letrec
+      ((deletion-loop
+	(lambda (interval length)
+	  (let ((length* (interval-length interval)))
+	    (cond ((fix:< length length*)
+		   (decrement-interval-length interval length))
+		  ((fix:= length length*)
+		   (delete-interval interval group))
+		  (else
+		   (deletion-loop (delete-interval interval group)
+				  (fix:- length length*))))))))
+    (let ((interval (find-interval group start))
+	  (length (fix:- end start)))
+      (let ((start* (interval-start interval)))
+	(if (fix:= start start*)
+	    (deletion-loop interval length)
+	    (let ((length* (interval-length interval)))
+	      (if (fix:<= end (fix:+ start* length*))
+		  (decrement-interval-length interval length)
+		  (let ((delta (fix:- (fix:+ start* length*) start)))
+		    (decrement-interval-length interval delta)
+		    (deletion-loop (next-interval interval)
+				   (fix:- length delta))))))))))
 
-;;; These procedures are called from the undo code to preserve the
-;;; properties in text that is being deleted.
+;;;; Undo
 
 (define (group-extract-properties group start end)
-  (and (group-text-properties group)
-       (let loop ((interval (find-interval group start))
-		  (start start))
-	 (let ((ie (interval-end interval)))
-	   (if (fix:<= end ie)
-	       (cons (vector start end (interval-properties interval))
-		     '())
-	       (cons (vector start
-			     ie
-			     (interval-properties interval))
-		     (let ((next (next-interval interval)))
-		       (loop next (interval-start next)))))))))
-
-(define (group-reinsert-properties! group index end-index properties)
-  index
-  end-index
-  (if properties
-      (for-each (lambda (x)
-		  (set-text-properties group
-				       (vector-ref x 0)
-				       (vector-ref x 1)
-				       (vector-ref x 2)))
-		properties)))
+  ;; Assumes that (GROUP-TEXT-PROPERTIES GROUP) is not #F.
+  ;; Assumes that (FIX:< START END).
+  (let loop ((interval (find-interval group start)) (start start))
+    (let ((end* (interval-end interval)))
+      (if (fix:<= end end*)
+	  (cons (vector start
+			end
+			(properties->alist (interval-properties interval)))
+		'())
+	  (cons (vector start
+			end*
+			(properties->alist (interval-properties interval)))
+		(let ((next (next-interval interval)))
+		  (loop next
+			(interval-start next))))))))
+
+(define (undo-record-intervals group start-interval end-interval)
+  (if (not (eq? #t (group-undo-data group)))
+      (undo-record-property-changes!
+       group
+       (let loop ((interval start-interval))
+	 (cons (vector (interval-start interval)
+		       (interval-end interval)
+		       (properties->alist (interval-properties interval)))
+	       (if (eq? interval end-interval)
+		   '()
+		   (loop (next-interval interval))))))))
+
+(define (group-reinsert-properties! group plist)
+  (do ((plist plist (cdr plist)))
+      ((null? plist))
+    (let ((properties* (alist->properties (vector-ref (car plist) 2))))
+      (modify-text-properties group
+			      (vector-ref (car plist) 0)
+			      (vector-ref (car plist) 1)
+	(lambda (properties)
+	  (properties=? properties properties*))
+	(lambda (interval)
+	  (set-interval-properties! interval properties*))))))
+
+(define (reinsert-properties-size plist)
+  (let loop ((plist plist) (size 0))
+    (if (null? plist)
+	size
+	(loop (cdr plist)
+	      (fix:+ (fix:+ (vector-length (car plist)) 1)
+		     (fix:* (length (vector-ref (car plist) 2)) 4))))))
 
-(define-structure (interval
-		   (constructor make-interval
-				(total-length start properties size)))
-  (left false)
-  (right false)
-  (parent false)
+;;;; Properties
+
+(define-integrable properties->alist rb-tree->alist)
+(define-integrable properties/copy rb-tree/copy)
+(define-integrable properties/delete! rb-tree/delete!)
+(define-integrable properties/empty? rb-tree/empty?)
+(define-integrable properties/insert! rb-tree/insert!)
+(define-integrable properties/lookup rb-tree/lookup)
+
+(define-integrable (make-empty-properties)
+  (make-rb-tree key=? key<?))
+
+(define-integrable (alist->properties alist)
+  (alist->rb-tree alist key=? key<?))
+
+(define-integrable (properties=? x y)
+  (rb-tree/equal? x y datum=?))
+
+(define-integrable key=?
+  eq?)
+
+(define (key<? x y)
+  (let ((sx (system-pair-car x))
+	(sy (system-pair-car y)))
+    (let ((lx (string-length sx))
+	  (ly (string-length sy)))
+      (let ((l (if (fix:< lx ly) lx ly)))
+	(let loop ((i 0))
+	  (cond ((fix:= i l)
+		 (fix:< lx ly))
+		((fix:= (vector-8b-ref sx i) (vector-8b-ref sy i))
+		 (loop (fix:+ i 1)))
+		(else
+		 (fix:< (vector-8b-ref sx i) (vector-8b-ref sy i)))))))))
+
+(define-integrable datum=?
+  eqv?)
+
+;;;; Intervals
+
+;;; These are balanced using the red-black tree balancing algorithm.
+;;; See Cormen, Leiserson, and Rivest, "Introduction to Algorithms",
+;;; Chapter 14, "Red-Black Trees".
+
+(define-structure interval
+  up
+  left
+  right
+  color
   total-length
   start
-  properties
-  size)
+  properties)
+
+(define (make-initial-interval group)
+  (let ((interval
+	 (make-interval #f
+			#f
+			#f
+			'BLACK
+			(group-length group)
+			0
+			(make-empty-properties))))
+    (set-group-text-properties! group interval)
+    interval))
+
+(declare (integrate-operator interval-length))
+(define (interval-length interval)
+  (if (interval-left interval)
+      (if (interval-right interval)
+	  (fix:- (interval-total-length interval)
+		 (fix:+ (interval-total-length (interval-left interval))
+			(interval-total-length (interval-right interval))))
+	  (fix:- (interval-total-length interval)
+		 (interval-total-length (interval-left interval))))
+      (if (interval-right interval)
+	  (fix:- (interval-total-length interval)
+		 (interval-total-length (interval-right interval)))
+	  (interval-total-length interval))))
+
+(declare (integrate-operator interval-end))
+(define (interval-end interval)
+  (fix:+ (interval-start interval)
+	 (interval-length interval)))
+
+(define (increment-interval-length interval length)
+  (do ((interval interval (interval-up interval)))
+      ((not interval))
+    (set-interval-total-length! interval
+				(fix:+ (interval-total-length interval)
+				       length))))
+
+(define (decrement-interval-length interval length)
+  (do ((interval interval (interval-up interval)))
+      ((not interval))
+    (set-interval-total-length! interval
+				(fix:- (interval-total-length interval)
+				       length))))
 
 (define-integrable (interval-property interval key default)
-  (let ((entry (assq key (interval-properties interval))))
-    (if entry
-	(cdr entry)
-	default)))
-
-(define-integrable (null-right-child? t)
-  (not (interval-right t)))
-
-(define-integrable (null-left-child? t)
-  (not (interval-left t)))
-
-(define-integrable (left-total-length t)
-  (if (interval-left t)
-      (interval-total-length (interval-left t))
-      0))
-
-(define-integrable (right-total-length t)
-  (if (interval-right t)
-      (interval-total-length (interval-right t))
-      0))
-
-(define-integrable (interval-length i)
-  (if (not i)
-      0
-      (fix:- (interval-total-length i)
-	     (fix:+ (right-total-length i)
-		    (left-total-length i)))))
-
-(define-integrable (interval-end i)
-  (fix:+ (interval-start i)
-	 (interval-length i)))
-
-(define-integrable (connect-left! parent child)
-  (set-interval-left! parent child)
-  (if child
-      (set-interval-parent! child parent)))
-
-(define-integrable (connect-right! parent child)
-  (set-interval-right! parent child)
-  (if child
-      (set-interval-parent! child parent)))
-
-(define (create-initial-interval group)
-  (let ((i (make-interval (group-length group) 0 '() 1)))
-    (set-group-text-properties! group i)
-    i))
-
-(define-integrable (size i)
-  (if i (interval-size i) 0))
-
-(define (add-amount-up-tree interval amt)
-  (let loop ((interval interval))
-    (if (not interval)
-	true				; return true on purpose
-	(begin
-	  (set-interval-total-length!
-	   interval
-	   (fix:+ (interval-total-length interval) amt))
-	  (loop (interval-parent interval))))))
+  (properties/lookup (interval-properties interval) key default))
 
+;;;; Interval Tree Search
+
 (define (find-interval group index)
   ;; Find the interval in GROUP that contains INDEX.  Assumes that
-  ;; GROUP has non-empty GROUP-TEXT-PROPERTIES and that INDEX is
-  ;; strictly less than GROUP-LENGTH.  The interval returned has a
-  ;; valid INTERVAL-START, and INDEX is guaranteed to be between
+  ;; GROUP has non-empty GROUP-TEXT-PROPERTIES and that INDEX is at
+  ;; most GROUP-LENGTH.  The interval returned has a valid
+  ;; INTERVAL-START, and INDEX is guaranteed to be between
   ;; INTERVAL-START (inclusive) and INTERVAL-END (exclusive).
-  (let loop ((relative-index index) (interval (group-text-properties group)))
-    ;;(let ((left (interval-left interval))))
+  ;; Exception: if INDEX is GROUP-LENGTH, the interval returned is the
+  ;; rightmost interval, and INDEX is its INTERVAL-END.
+  (let loop
+      ((relative-index index)
+       (interval (group-text-properties group)))
     (if (and (interval-left interval)
-	     (fix:< relative-index (interval-total-length
-				    (interval-left interval))))
+	     (fix:< relative-index
+		    (interval-total-length (interval-left interval))))
 	(loop relative-index (interval-left interval))
-	;;(let ((right (interval-right interval))))
 	(if (and (interval-right interval)
 		 (fix:>= relative-index
 			 (fix:- (interval-total-length interval)
@@ -490,317 +518,230 @@
 				 (interval-right interval))))
 		  (interval-right interval))
 	    (begin
-	      (set-interval-start! interval
-				   (fix:+ (fix:- index relative-index)
-					  (if (interval-left interval)
-					      (interval-total-length
-					       (interval-left interval))
-					      0)))
+	      (set-interval-start!
+	       interval
+	       (if (interval-left interval)
+		   (fix:+ (fix:- index relative-index)
+			  (interval-total-length (interval-left interval)))
+		   (fix:- index relative-index)))
 	      interval)))))
 
 (define (next-interval interval)
-  (let ((right (interval-right interval))
-	(finish
+  (let ((finish
 	 (lambda (interval*)
-	   (set-interval-start! interval*
-				;; changed from fix:- to fix:+
-				(fix:+ (interval-start interval)
-				       (interval-length interval)))
+	   (set-interval-start! interval* (interval-end interval))
 	   interval*)))
-    (if right
-	(finish (leftmost-interval right))
+    (if (interval-right interval)
+	(let loop ((interval (interval-right interval)))
+	  (if (interval-left interval)
+	      (loop (interval-left interval))
+	      (finish interval)))
 	(let loop ((interval interval))
-	  (let ((parent (interval-parent interval)))
-	    (and parent
-		 (if (eq? interval (interval-left parent))
-		     (finish parent)
-		     (loop parent))))))))
+	  (let ((up (interval-up interval)))
+	    (and up
+		 (if (eq? interval (interval-left up))
+		     (finish up)
+		     (loop up))))))))
 
 (define (previous-interval interval)
-  (let ((left (interval-left interval))
-	(finish
+  (let ((finish
 	 (lambda (interval*)
 	   (set-interval-start! interval*
 				(fix:- (interval-start interval)
 				       (interval-length interval*)))
 	   interval*)))
-    (if left
-	(finish (rightmost-interval left))
+    (if (interval-left interval)
+	(let loop ((interval (interval-left interval)))
+	  (if (interval-right interval)
+	      (loop (interval-right interval))
+	      (finish interval)))
 	(let loop ((interval interval))
-	  (let ((parent (interval-parent interval)))
-	    (and parent
-		 (if (eq? interval (interval-right parent))
-		     (finish parent)
-		     (loop parent))))))))
-
-(define (leftmost-interval t)
-  (let ((l (interval-left t)))
-    (if l
-	(leftmost-interval l)
-	t)))
-
-(define (rightmost-interval t)
-  (let ((r (interval-right t)))
-    (if r
-	(rightmost-interval r)
-	t)))
+	  (let ((up (interval-up interval)))
+	    (and up
+		 (if (eq? interval (interval-right up))
+		     (finish up)
+		     (loop up))))))))
 
-;;;
-;;;     interval                  interval
-;;;      /    \       --->         /    \
-;;;   left   right                i    right
-;;;                              /
-;;;                            left
-(define (split-interval-right interval start* group)
-  (let ((start (interval-start interval))
-	(left (interval-left interval)))
-    (let ((i (make-interval (fix:+ (if left (interval-total-length left) 0)
-				   (fix:- start* start))
-			    start
-			    (interval-properties interval)
-			    (size left))))
-      (if left (connect-left! i left))
-      (connect-left! interval i)
-      (set-interval-start! interval start*)
-      (balance i group 1)
-      interval)))
-
-;;; Do the same operation as above but return a different node.
-(define (split-interval-left interval end* group)
+;;;; Interval Tree Modification
+
+(define (split-interval-right interval index group)
+  (split-interval-left interval index group)
+  interval)
+
+(define (split-interval-left interval index group)
   (let ((start (interval-start interval))
 	(left (interval-left interval)))
-    (let ((i (make-interval (fix:+ (if left (interval-total-length left) 0)
-				   (fix:- end* start))
-			    start
-			    (interval-properties interval)
-			    (size left))))
-      (if left (connect-left! i left))
-      (connect-left! interval i)
-      (set-interval-start! interval end*)
-      (balance i group 1)
-      i)))
-
-(define (delete-interval i group)
-  (define (delete-node i)
-    (cond ((null-left-child? i)
-	   (interval-right i))
-	  ((null-right-child? i)
-	   (interval-left i))
-	  (else
-	   ;;; this creates a balancing problem
-	   ;;; we should do some balancing along the way
-	   (let* ((l (interval-left i))
-		  (r (interval-right i))
-		  (amt (interval-total-length l))
-		  (s (interval-size l)))
-	     (let loop ((this r))
-	       (set-interval-total-length!
-		this (fix:+ (interval-total-length this) amt))
-	       (set-interval-size!
-		this (fix:+ (interval-size this) s))
-	       (if (interval-left this)
-		   (loop (interval-left this))
-		   (begin
-		     (connect-left! this l)
-		     r)))))))
-  (let ((new (delete-node i)))
-    (cond ((am-left-child? i)
-	   (connect-left! (interval-parent i) new))
-	  ((am-right-child? i)
-	   (connect-right! (interval-parent i) new))
-	  (else
-	   (if new (set-interval-parent! new false))
-	   (set-group-text-properties! group new)))
-    (balance (interval-parent i) group -1)))
-
-(define (am-left-child? i)
-  (let ((p (interval-parent i)))
-    (and p
-	 (eq? (interval-left p) i))))
-
-(define (am-right-child? i)
-  (let ((p (interval-parent i)))
-    (and p
-	 (eq? (interval-right p) i))))
+    (let ((interval*
+	   (make-interval interval
+			  left
+			  #f
+			  'RED
+			  (fix:+ (if left (interval-total-length left) 0)
+				 (fix:- index start))
+			  start
+			  (properties/copy (interval-properties interval)))))
+      (set-interval-left! interval interval*)
+      (if left (set-interval-up! left interval*))
+      (set-interval-start! interval index)
+      (insert-fixup! group
+		     (if (and left (eq? 'RED (interval-color left)))
+			 left
+			 interval*))
+      interval*)))
+
+(define (insert-fixup! group x)
+  ;; Assumptions: X is red, and the only possible violation of the
+  ;; tree properties is that (INTERVAL-UP X) is also red.
+  (let loop ((x x))
+    (let ((u (interval-up x)))
+      (if (and u (eq? 'RED (interval-color u)))
+	  (let ((d (b->d (eq? u (interval-left (interval-up u))))))
+	    (let ((y (get-link- (interval-up u) d)))
+	      (if (and y (eq? 'RED (interval-color y)))
+		  ;; case 1
+		  (begin
+		    (set-interval-color! u 'BLACK)
+		    (set-interval-color! y 'BLACK)
+		    (set-interval-color! (interval-up u) 'RED)
+		    (loop (interval-up u)))
+		  (let ((x
+			 (if (eq? x (get-link- u d))
+			     ;; case 2
+			     (begin
+			       (rotate+! group u d)
+			       u)
+			     x)))
+		    ;; case 3
+		    (let ((u (interval-up x)))
+		      (set-interval-color! u 'BLACK)
+		      (set-interval-color! (interval-up u) 'RED)
+		      (rotate-! group (interval-up u) d)))))))))
+  (set-interval-color! (group-text-properties group) 'BLACK))
 
-;;; Balance by the number of interval nodes.  There does not appear to be
-;;; a good way to balance based on total-length because it does not tell
-;;; us anything about the sub-intervals.  The balancing works by walking
-;;; up the tree from the point of change rotating as necessary.
-(define (balance t group size-inc-amount)
-
-  (define-integrable (smart-connect! parent child other)
-    (if parent
-	(if (eq? other (interval-left parent))
-	    (connect-left! parent child)
-	    (connect-right! parent child))
-	(begin
-	  (set-interval-parent! child false)
-	  (set-group-text-properties! group child))))
-
-  ;;     a             b
-  ;;    / \           / \
-  ;;   X   b   -->   a   Z
-  ;;      / \       / \
-  ;;     Y   Z     X   Y
-  (define-integrable (single-left a)
-    (let ((b (interval-right a))
-	  (p (interval-parent a))
-	  (lx (left-total-length a))
-	  (la (interval-length a)))
-      (let ((y (interval-left b))
-	    (lb (interval-length b))
-	    (ly (left-total-length b))
-	    (lz (right-total-length b))
-	    (nx (size (interval-left a)))
-	    (ny (size (interval-left b)))
-	    (nz (size (interval-right b))))
-	(smart-connect! p b a)
-	(connect-left! b a)
-	(connect-right! a y)
-
-	(set-interval-total-length! a (fix:+ (fix:+ lx la) ly))
-	(set-interval-total-length! b (fix:+ (fix:+ (fix:+ lx la) ly)
-					     (fix:+ lz lb)))
-	(set-interval-size! a (fix:+ (fix:+ nx ny) 1))
-	(set-interval-size! b (fix:+ (fix:+ (fix:+ nx ny) nz) 2))
-	(balance p group size-inc-amount))))
-
-  ;;     a                 b
-  ;;    / \               / \
-  ;;   X   c             /   \
-  ;;      / \   -->     a     c
-  ;;     b   Z         / \   / \
-  ;;    / \           X  Y1 Y2  Z
-  ;;   Y1  Y2
-  (define-integrable (double-left a)
-    (let* ((c (interval-right a))
-	   (b (interval-left c))
-	   (y1 (interval-left b))
-	   (y2 (interval-right b))
-	   (p (interval-parent a))
-
-	   (la (interval-length a))
-	   (lb (interval-length b))
-	   (lc (interval-length c))
-	   (lx (left-total-length a))
-	   (ly1 (left-total-length b))
-	   (ly2 (right-total-length b))
-	   (lz (right-total-length c))
-	   (nx (size (interval-left a)))
-	   (ny1 (size (interval-left b)))
-	   (ny2 (size (interval-right b)))
-	   (nz (size (interval-right c))))
-      (smart-connect! p b a)
-      (connect-left! b a)
-      (connect-right! b c)
-      (connect-right! a y1)
-      (connect-left! c y2)
-
-      (set-interval-total-length! a (fix:+ (fix:+ lx ly1) la))
-      (set-interval-total-length! b
-				  (fix:+ (fix:+ (fix:+ lx ly1) (fix:+ ly2 lz))
-					 (fix:+ (fix:+ la lc) lb)))
-      (set-interval-total-length! c (fix:+ (fix:+ ly2 lz) lc))
-      (set-interval-size! a (fix:+ (fix:+ nx ny1) 1))
-      (set-interval-size! c (fix:+ (fix:+ ny2 nz) 1))
-      (set-interval-size! b (fix:+ (fix:+ (fix:+ nx ny1) (fix:+ ny2 nz)) 3))
-      (balance p group size-inc-amount)))
-
-  ;;      a            b
-  ;;     / \          / \
-  ;;    b   X  -->   Z   a
-  ;;   / \              / \
-  ;;  Z   Y            Y   X
-  (define-integrable (single-right a)
-    (let ((b (interval-left a))
-	  (p (interval-parent a))
-	  (lx (right-total-length a))
-	  (la (interval-length a)))
-      (let ((y (interval-right b))
-	    (lb (interval-length b))
-	    (ly (right-total-length b))
-	    (lz (left-total-length b))
-	    (nz (size (interval-left b)))
-	    (ny (size (interval-right b)))
-	    (nx (size (interval-right a))))
-	(smart-connect! p b a)
-	(connect-right! b a)
-	(connect-left! a y)
-
-	(set-interval-total-length! a (fix:+ (fix:+ lx la) ly))
-	(set-interval-total-length! b (fix:+ (fix:+ (fix:+ lx la) ly)
-					     (fix:+ lb lz)))
-	(set-interval-size! a (fix:+ (fix:+ ny nx) 1))
-	(set-interval-size! b (fix:+ (fix:+ (fix:+ ny nx) nz) 2))
-	(balance p group size-inc-amount))))
-
-  ;;      a              b
-  ;;     / \            / \
-  ;;    c   X          /   \
-  ;;   / \     -->    c     a
-  ;;  Z   b          / \   / \
-  ;;     / \        Z  Y2 Y1  X
-  ;;    Y2 Y1
-  (define-integrable (double-right a)
-    (let* ((c (interval-left a))
-	   (b (interval-right c))
-	   (y2 (interval-left b))
-	   (y1 (interval-right b))
-	   (p (interval-parent a))
-
-	   (nx (size (interval-right a)))
-	   (nz (size (interval-left c)))
-	   (ny1 (size (interval-right b)))
-	   (ny2 (size (interval-left b)))
-
-	   (la (interval-length a))
-	   (lb (interval-length b))
-	   (lc (interval-length c))
-	   (lx (right-total-length a))
-	   (ly1 (right-total-length b))
-	   (ly2 (left-total-length b))
-	   (lz (left-total-length c))
-	   )
-      (smart-connect! p b a)
-      (connect-right! b a)
-      (connect-left! b c)
-      (connect-left! a y1)
-      (connect-right! c y2)
-
-      (set-interval-total-length! a (fix:+ (fix:+ lx ly1) la))
-      (set-interval-total-length! b
-				  (fix:+ (fix:+ (fix:+ lx ly1) (fix:+ ly2 lz))
-					 (fix:+ (fix:+ la lb) lc)))
-      (set-interval-total-length! c (fix:+ (fix:+ ly2 lz) lc))
-
-      (set-interval-size! a (fix:+ (fix:+ ny1 nx) 1))
-      (set-interval-size! c (fix:+ (fix:+ nz ny2) 1))
-      (set-interval-size! b (fix:+ (fix:+ (fix:+ ny1 nx) (fix:+ nz ny2))
-				   3))
-      (balance p group size-inc-amount)))
-
-  (if (not t)
-      true
-      (let ((ln (size (interval-left t)))
-	    (rn (size (interval-right t))))
-	(cond ((fix:< (fix:+ ln rn) 2)
-	       (set-interval-size! t (fix:+ (interval-size t)
-					    size-inc-amount))
-	       (balance (interval-parent t) group size-inc-amount))
-	      ((fix:> rn (fix:* 5 ln))	; right is too big
-	       (let ((rln (size (interval-left (interval-right t))))
-		     (rrn (size (interval-right (interval-right t)))))
-		 (if (fix:< rln rrn)
-		     (single-left t)
-		     (double-left t))))
-	      ((fix:> ln (fix:* 5 rn))	; left is too big
-	       (let ((lln (size (interval-left (interval-left t))))
-		     (lrn (size (interval-right (interval-left t)))))
-		 (if (fix:< lrn lln)
-		     (single-right t)
-		     (double-right t))))
+(define (delete-interval interval group)
+  ;; Returns the next interval after INTERVAL.  This might be EQ? to
+  ;; INTERVAL because the algorithm might swap INTERVAL with its next
+  ;; node.
+  (decrement-interval-length interval (interval-length interval))
+  (let ((finish
+	 (lambda (z n)
+	   (let ((x (or (interval-left z) (interval-right z)))
+		 (u (interval-up z)))
+	     (if x (set-interval-up! x u))
+	     (cond ((not u) (set-group-text-properties! group x))
+		   ((eq? z (interval-left u)) (set-interval-left! u x))
+		   (else (set-interval-right! u x)))
+	     (if (eq? 'BLACK (interval-color z))
+		 (delete-fixup! group x u)))
+	   n)))
+    (let ((y (next-interval interval)))
+      (if (and (interval-left interval)
+	       (interval-right interval))
+	  (begin
+	    (let ((length (interval-length y)))
+	      (do ((y y (interval-up y)))
+		  ((eq? y interval))
+		(set-interval-total-length! y
+					    (fix:- (interval-total-length y)
+						   length))))
+	    (set-interval-start! interval (interval-start y))
+	    (set-interval-properties! interval (interval-properties y))
+	    (finish y interval))
+	  (finish interval y)))))
+
+(define (delete-fixup! group x u)
+  (let loop ((x x) (u u))
+    (if (or (not u)
+	    (and x (eq? 'RED (interval-color x))))
+	(if x (set-interval-color! x 'BLACK))
+	(let ((d (b->d (eq? x (interval-left u)))))
+	  (let ((w
+		 (let ((w (get-link- u d)))
+		   (if (eq? 'RED (interval-color w))
+		       ;; case 1
+		       (begin
+			 (set-interval-color! w 'BLACK)
+			 (set-interval-color! u 'RED)
+			 (rotate+! group u d)
+			 (get-link- u d))
+		       w)))
+		(case-4
+		 (lambda (w)
+		   (set-interval-color! w (interval-color u))
+		   (set-interval-color! u 'BLACK)
+		   (set-interval-color! (get-link- w d) 'BLACK)
+		   (rotate+! group u d)
+		   (set-interval-color! (group-text-properties group)
+					'BLACK))))
+	    (if (let ((n- (get-link- w d)))
+		  (and n-
+		       (eq? 'RED (interval-color n-))))
+		(case-4 w)
+		(let ((n+ (get-link+ w d)))
+		  (if (or (not n+)
+			  (eq? 'BLACK (interval-color (get-link+ w d))))
+		      ;; case 2
+		      (begin
+			(set-interval-color! w 'RED)
+			(loop u (interval-up u)))
+		      ;; case 3
+		      (begin
+			(set-interval-color! n+ 'BLACK)
+			(set-interval-color! w 'RED)
+			(rotate-! group w d)
+			(case-4 (get-link- u d)))))))))))
+
+;;; The algorithms are left/right symmetric, so abstract "directions"
+;;; permit code to be used for either symmetry:
+
+(define-integrable (b->d left?)
+  (if left? 'LEFT 'RIGHT))
+
+(define-integrable (-d d)
+  (if (eq? 'LEFT d) 'RIGHT 'LEFT))
+
+(define-integrable (get-link+ p d)
+  (if (eq? 'LEFT d)
+      (interval-left p)
+      (interval-right p)))
+
+(define-integrable (set-link+! p d l)
+  (if (eq? 'LEFT d)
+      (set-interval-left! p l)
+      (set-interval-right! p l)))
+
+(define-integrable (get-link- p d)
+  (if (eq? 'RIGHT d)
+      (interval-left p)
+      (interval-right p)))
+
+(define-integrable (set-link-! p d l)
+  (if (eq? 'RIGHT d)
+      (set-interval-left! p l)
+      (set-interval-right! p l)))
+
+(define (rotate+! group x d)
+  ;; Assumes (NOT (NOT (GET-LINK- X D))).
+  (let ((y (get-link- x d)))
+    (let ((beta (get-link+ y d)))
+      (set-link-! x d beta)
+      (if beta (set-interval-up! beta x))
+      (let ((u (interval-up x)))
+	(set-interval-up! y u)
+	(cond ((not u)
+	       (set-group-text-properties! group y))
+	      ((eq? x (get-link+ u d))
+	       (set-link+! u d y))
 	      (else
-	       (set-interval-size! t (fix:+ (interval-size t)
-					    size-inc-amount))
-	       (balance (interval-parent t) group size-inc-amount))))))
\ No newline at end of file
+	       (set-link-! u d y))))
+      (set-link+! y d x)
+      (set-interval-up! x y)
+      (let ((tlx (interval-total-length x)))
+	(set-interval-total-length!
+	 x
+	 (fix:+ (fix:- tlx (interval-total-length y))
+		(if beta (interval-total-length beta) 0)))
+	(set-interval-total-length! y tlx)))))
+
+(define-integrable (rotate-! group x d)
+  (rotate+! group x (-d d)))
\ No newline at end of file
diff --git a/v7/src/edwin/undo.scm b/v7/src/edwin/undo.scm
index 951ffa7d2..e01c8cc24 100644
--- a/v7/src/edwin/undo.scm
+++ b/v7/src/edwin/undo.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: undo.scm,v 1.55 1993/08/09 19:11:49 jawilson Exp $
+;;;	$Id: undo.scm,v 1.56 1993/10/05 23:05:35 cph Exp $
 ;;;
 ;;;	Copyright (c) 1985, 1989-93 Massachusetts Institute of Technology
 ;;;
@@ -128,8 +128,7 @@
 	    (set-group-undo-data!
 	     group
 	     (cons (cons 'REINSERT-PROPERTIES
-			 (vector start end
-				 (group-extract-properties group start end)))
+			 (group-extract-properties group start end))
 		   (group-undo-data group))))
 	(set-group-undo-data!
 	 group
@@ -153,7 +152,7 @@
 	      (undo-record-first-change! group))
 	  (set-group-undo-data!
 	   group
-	   (cons (cons 'SET-TEXT-PROPERTIES properties)
+	   (cons (cons 'REINSERT-PROPERTIES properties)
 		 (group-undo-data group))))))
 
 (define (undo-record-first-change! group)
@@ -203,7 +202,7 @@ which includes both the saved text and other data."
 	     (words->bytes (ref-variable undo-strong-limit buffer)))))))))
 
 (add-gc-daemon! truncate-buffer-undo-lists!)
-
+
 (define (truncate-undo-data! undo-data min-size max-size)
   (letrec
       ((loop
@@ -226,10 +225,17 @@ which includes both the saved text and other data."
 		 (loop (cdr undo-data)
 		       undo-data
 		       (fix:+ size
-			      (cond ((not (pair? (car undo-data))) 2)
-				    ((not (string? (caar undo-data))) 4)
-				    (else (fix:+ 5 (system-vector-length
-						    (caar undo-data))))))
+			      (if (pair? (car undo-data))
+				  (fix:+
+				   4
+				   (let ((a (caar undo-data))
+					 (b (cdar undo-data)))
+				     (cond ((eq? 'REINSERT-PROPERTIES a)
+					    (reinsert-properties-size b))
+					   ((string? a)
+					    (fix:+ 1 (system-vector-length a)))
+					   (else 0))))
+				  2))
 		       boundary))))))
     (cond ((or (null? undo-data)
 	       (eq? #t undo-data))
@@ -317,18 +323,8 @@ A numeric argument serves as a repeat count."
 			       ;; (#t . MOD-TIME) means first modification
 			       (if (eqv? b (buffer-modification-time buffer))
 				   (buffer-not-modified! buffer)))
-			      ((eq? 'SET-TEXT-PROPERTIES a)
-			       (for-each (lambda (entry)
-					   (set-text-properties group
-								(car entry)
-								(cadr entry)
-								(caddr entry)))
-					 b))
 			      ((eq? 'REINSERT-PROPERTIES a)
-			       (group-reinsert-properties! group
-							   (vector-ref b 0)
-							   (vector-ref b 1)
-							   (vector-ref b 2)))
+			       (group-reinsert-properties! group b))
 			      ((fix:fixnum? a)
 			       ;; (START . END) means insertion
 			       (if (or (fix:< a (group-start-index group))
-- 
2.25.1