#| -*-Scheme-*-

$Id: txtprp.scm,v 1.28 2007/01/05 21:19:24 cph Exp $

Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
    2006, 2007 Massachusetts Institute of Technology

This file is part of MIT/GNU Scheme.

MIT/GNU Scheme is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.

MIT/GNU Scheme is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
USA.

|#

;;;; Text Properties
;;;  An improved version of a mechanism from GNU Emacs 19

(declare (usual-integrations))

(define (add-text-property group start end key datum #!optional no-overwrite?)
  (validate-region-arguments group start end 'ADD-TEXT-PROPERTY)
  (validate-key-argument key 'ADD-TEXT-PROPERTY)
  (modify-text-properties group start end
    (if (not (if (default-object? no-overwrite?) #f no-overwrite?))
	(lambda (properties)
	  (not (eq? (properties/lookup properties key no-datum) datum)))
	(lambda (properties)
	  (eq? (properties/lookup properties key no-datum) no-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-key-argument key 'REMOVE-TEXT-PROPERTY)
  (modify-text-properties group start end
    (lambda (properties)
      (not (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-key-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 (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-key-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-key-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 modify? modify!)
  (call-with-values
      (lambda () (intervals-to-modify group start end 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 modify?)
  (letrec
      ((find-start
	(lambda (interval)
	  (if (fix:<= end (interval-end interval))
	      (values #f #f)
	      (let ((interval (next-interval interval)))
		(if (modify? (interval-properties interval))
		    (find-end interval)
		    (find-start interval))))))
       (find-end
	(lambda (start-interval)
	  (let loop ((prev start-interval) (interval start-interval))
	    (let ((end* (interval-end interval)))
	      (if (fix:< end end*)
		  (if (modify? (interval-properties interval))
		      (let ((end-interval
			     (split-interval-left interval end group)))
			(values (if (eq? interval start-interval)
				    end-interval
				    start-interval)
				end-interval))
		      (values start-interval prev))
		  (let ((prev
			 (if (modify? (interval-properties interval))
			     interval
			     prev)))
		    (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 (modify? (interval-properties interval))
	      (find-end
	       (if (fix:= start (interval-start interval))
		   interval
		   (split-interval-right interval start group)))
	      (find-start interval)))
	(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)
  (set-group-modified-tick! group (fix:+ (group-modified-tick group) 1)))

(define (validate-region-arguments group start end procedure)
  (validate-group group procedure)
  (validate-group-index group start procedure)
  (validate-group-index group end procedure)
  (if (not (fix:<= start end))
      (error "Indexes incorrectly related:" start end procedure)))

(define (validate-point-arguments group index procedure)
  (validate-group group procedure)
  (validate-group-index group index procedure))

(define (validate-group-index group index procedure)
  (if (not (fix:fixnum? index))
      (error:wrong-type-argument index "fixnum" procedure))
  (if (not (and (fix:<= 0 index) (fix:<= index (group-length group))))
      (error:bad-range-argument index procedure)))

(define (validate-group group procedure)
  (if (not (group? group))
      (error:wrong-type-argument group "group" procedure)))

(define (validate-key-argument key procedure)
  (if (not (or (interned-symbol? key) (variable? key)))
      (error:wrong-type-argument key "key" procedure)))

(define no-datum
  (list 'NO-DATUM))

;;;; READ-ONLY Property

;;; 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
;;; occur at either end of the region.

;;; This behavior is implemented by using a unique datum for the
;;; READ-ONLY property of a given contiguous region.  The code for
;;; insertion checks the READ-ONLY properties to the left and right of
;;; the insertion point, and disallows insertion only when they are
;;; the same.  If two different READ-ONLY regions are placed
;;; immediately adjacent to one another, insertions may occur in
;;; between the regions, but not inside of them.

(define (subgroup-read-only group start end)
  (add-text-property group start end 'READ-ONLY (list 'READ-ONLY)))

(define (subgroup-writeable group start end)
  (remove-text-property group start end 'READ-ONLY))

(define (region-read-only region)
  (subgroup-read-only (region-group region)
		      (region-start-index region)
		      (region-end-index region)))

(define (region-writeable region)
  (subgroup-writeable (region-group region)
		      (region-start-index region)
		      (region-end-index region)))

(define (text-not-insertable? group start)
  ;; Assumes that (GROUP-TEXT-PROPERTIES GROUP) is not #F.
  (and (not (eq? 'FULLY (group-writeable? 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
		(if (fix:= start (interval-start interval))
		    (eq? datum
			 (interval-property (previous-interval interval)
					    'READ-ONLY #f))
		    (or (fix:< start (interval-end interval))
			(eq? datum
			     (interval-property (next-interval interval)
						'READ-ONLY #f)))))))))

(define (text-not-deleteable? group start end)
  ;; Assumes that (GROUP-TEXT-PROPERTIES GROUP) is not #F.
  (and (not (eq? 'FULLY (group-writeable? group)))
       (fix:< start end)
       (let loop ((interval (find-interval group start)))
	 (or (interval-property interval 'READ-ONLY #f)
	     (and (not (fix:<= end (interval-end interval)))
		  (let ((next (next-interval interval)))
		    (and next
			 (loop next))))))))

(define text-not-replaceable?
  text-not-deleteable?)

;;;; Miscellaneous Properties

(define (highlight-subgroup group start end highlight)
  (if highlight
      (add-text-property group start end 'HIGHLIGHTED highlight)
      (remove-text-property group start end 'HIGHLIGHTED)))

(define (highlight-region region highlight)
  (highlight-subgroup (region-group region)
		      (region-start-index region)
		      (region-end-index region)
		      highlight))

(define (highlight-region-excluding-indentation region highlight)
  (let ((start (region-start region))
	(end (region-end region)))
    (let loop ((start start))
      (let ((start (horizontal-space-end start))
	    (lend (line-end start 0)))
	(if (mark<= lend end)
	    (begin
	      (let ((end (horizontal-space-start lend)))
		(if (mark< start end)
		    (highlight-region (make-region start end) highlight)))
	      (if (not (group-end? lend))
		  (loop (mark1+ lend))))
	    (let ((end (horizontal-space-start end)))
	      (if (mark< start end)
		  (highlight-region (make-region start end) highlight))))))))

(define (local-comtabs mark)
  (get-text-property (mark-group mark) (mark-index mark) 'COMMAND-TABLE #f))

(define (set-subgroup-local-comtabs! group start end comtabs)
  (if comtabs
      (add-text-property group start end 'COMMAND-TABLE comtabs)
      (remove-text-property group start end 'COMMAND-TABLE)))

(define (set-region-local-comtabs! region comtabs)
  (set-subgroup-local-comtabs! (region-group region)
			       (region-start-index region)
			       (region-end-index region)
			       comtabs))

;;;; Buffer modification

(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)
  ;; 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))))))))))

(define (update-intervals-for-replacement! group start end)
  ;; Assumes that (GROUP-TEXT-PROPERTIES GROUP) is not #F.
  ;; Assumes that (FIX:< START END).
  group start end
  ;; Not sure what to do about this right now.  For current uses of
  ;; replacement, it's reasonable to leave the properties alone.
  unspecific)

;;;; Undo

(define (group-extract-properties group start end)
  ;; 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)
	  (not (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))))))

;;;; 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-integrable datum=? eqv?)

(define (key<? k1 k2)
  (let ((lose
	 (lambda (k)
	   (error:wrong-type-argument k "key" 'KEY<?))))
    (cond ((symbol? k1)
	   (cond ((symbol? k2) (symbol<? k1 k2))
		 ((variable? k2) #t)
		 (else (lose k2))))
	  ((variable? k1)
	   (cond ((symbol? k2) #f)
		 ((variable? k2)
		  (symbol<? (variable-name k1) (variable-name k2)))
		 (else (lose k2))))
	  (else (lose k1)))))

;;;; 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)

(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)
  (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 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).
  ;; 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))))
	(loop relative-index (interval-left interval))
	(if (and (interval-right interval)
		 (fix:>= relative-index
			 (fix:- (interval-total-length interval)
				(interval-total-length
				 (interval-right interval)))))
	    (loop (fix:- relative-index
			 (fix:- (interval-total-length interval)
				(interval-total-length
				 (interval-right interval))))
		  (interval-right interval))
	    (begin
	      (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 ((finish
	 (lambda (interval*)
	   (set-interval-start! interval* (interval-end interval))
	   interval*)))
    (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 ((up (interval-up interval)))
	    (and up
		 (if (eq? interval (interval-left up))
		     (finish up)
		     (loop up))))))))

(define (previous-interval interval)
  (let ((finish
	 (lambda (interval*)
	   (set-interval-start! interval*
				(fix:- (interval-start interval)
				       (interval-length interval*)))
	   interval*)))
    (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 ((up (interval-up interval)))
	    (and up
		 (if (eq? interval (interval-right up))
		     (finish up)
		     (loop up))))))))

;;;; 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 ((delta (fix:- index (interval-start interval)))
	(start (interval-start interval)))
    (set-interval-start! interval index)
    (let ((new
	   (lambda (parent d)
	     (let ((interval*
		    (make-interval parent #f #f 'RED delta start
				   (properties/copy
				    (interval-properties interval)))))
	       (set-link+! parent d interval*)
	       (insert-fixup! group interval*)
	       interval*))))
      (if (not (interval-left interval))
	  (new interval 'LEFT)
	  (let loop ((parent (interval-left interval)))
	    (set-interval-total-length! parent
					(fix:+ (interval-total-length parent)
					       delta))
	    (if (not (interval-right parent))
		(new parent 'RIGHT)
		(loop (interval-right parent))))))))

(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))

(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-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)))