;;; -*-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
;;;
;;; 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))
\f
(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*)))))))))
+\f
+(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))))
\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)
(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)))
-\f
-(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))
\f
-(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))))))))
-\f
;;; 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
;;; 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
(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))))))))
+\f
+;;;; 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))))))))))
\f
-;;; 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))))))
\f
-(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?)
+\f
+;;;; 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))
\f
+;;;; 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)
(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))))))))
\f
-;;;
-;;; 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))
\f
-;;; 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)))))))))))
+\f
+;;; 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
projects / mit-scheme.git / commitdiff