1 ;;; implentation of an interval tree
5 (defvar *text-property-default-nonsticky
* nil
6 "Alist of properties vs the corresponding non-stickinesses.
7 Each element has the form (PROPERTY . NONSTICKINESS).
9 If a character in a buffer has PROPERTY, new text inserted adjacent to
10 the character doesn't inherit PROPERTY if NONSTICKINESS is non-nil,
11 inherits it if NONSTICKINESS is nil. The front-sticky and
12 rear-nonsticky properties of the character overrides NONSTICKINESS.")
14 (defvar *char-property-alias-alist
* nil
15 "Alist of alternative properties for properties without a value.
16 Each element should look like (PROPERTY ALTERNATIVE1 ALTERNATIVE2...).
17 If a piece of text has no direct value for a particular property, then
18 this alist is consulted. If that property appears in the alist, then
19 the first non-nil value from the associated alternative properties is
22 (defvar *default-text-properties
* nil
23 "Property-list used as default values.
24 The value of a property in this list is seen as the value for every
25 character that does not have its own value for that property.")
27 (defmacro doplist
((sym val plist
&optional ret
) &body body
)
28 "Loop through each symbol value pair in PLIST executing BODY."
29 (let ((csym (gensym)))
30 `(do* ((,csym
,plist
(cddr ,csym
)))
32 (let ((,sym
(car ,csym
))
36 ;; interval node is a list: (key left right &rest plist)
38 (defun print-interval (i s d
)
39 (format s
"#S(interval ~s ~s ~s | ~s ~s)"
47 (:print-function print-interval
))
52 (parent nil
:type
(or null pstring buffer interval
))
53 (plist nil
:type list
))
55 ;; MOVITZ's defstruct doesn't create copy-interval
57 (defun copy-interval (interval)
58 (make-interval :pt
(interval-pt interval
)
59 :length
(interval-length interval
)
60 :left
(interval-left interval
)
61 :right
(interval-right interval
)
62 :parent
(interval-parent interval
)
63 :plist
(interval-plist interval
)))
65 (defun interval-has-object (interval)
66 (and (interval-parent interval
)
67 (not (typep (interval-parent interval
) 'interval
))))
69 (defun interval-has-parent (interval)
70 (and (interval-parent interval
)
71 (typep (interval-parent interval
) 'interval
)))
73 (defun check-total-length (interval)
74 (when (< (interval-length interval
) 0)
75 (error "Interval length < 0 ~a" interval
)))
77 (defun create-root-interval (object)
78 "Return a fresh interval for OBJECT."
79 (let ((i (make-interval :pt
0 :length
0 :parent object
80 :left nil
:right nil
:plist nil
)))
82 ((typep object
'buffer
)
83 (setf (intervals object
) i
84 ;; XXX: are buffer-max buffer-min the right functions to use?
85 (interval-length i
) (- (buffer-max object
) (buffer-min object
))
86 (interval-pt i
) (buffer-min object
)))
87 ((typep object
'pstring
)
88 (setf (intervals object
) i
89 (interval-length i
) (pstring-length object
))))
92 (defun plists-equal (p1 p2
)
93 "Return 1 if the two properties lists are equal, 0 otherwise."
96 (doplist (sym val p1 t
)
97 (unless (eql val
(getf p2 sym
))
98 (return-from plists-equal nil
)))))
100 (defun intervals-equal (i1 i2
)
101 "Return T if the two intervals have the same properties, NIL otherwise."
102 (plists-equal (interval-plist i1
) (interval-plist i2
)))
104 (defun lookup-char-property (plist prop textprop
)
105 (let* ((val (getf plist prop
))
106 (cat (getf plist
'category
)))
108 (return-from lookup-char-property val
))
109 ;; This is what GNU emacs does...
110 (when (and (symbolp cat
)
112 (return-from lookup-char-property
(get cat prop
)))
113 ;; Check for alternative properties
114 (let ((tail (assoc prop
*char-property-alias-alist
*)))
116 (or (find-if (lambda (p)
120 (consp *default-text-properties
*)
121 (getf *default-text-properties
* prop
)))))))
123 (defun textget (plist sym
)
124 "Get the value of property PROP from PLIST,
125 which is the plist of an interval.
126 We check for direct properties, for categories with property PROP,
127 and for PROP appearing on the default-text-properties list."
128 (lookup-char-property plist sym t
))
130 (defun split-interval-left (interval offset
)
131 (let* ((new-length offset
)
132 (new (make-interval :pt
(interval-pt interval
)
135 (incf (interval-pt interval
) offset
)
136 (if (interval-left interval
)
138 (setf (interval-left new
) (interval-left interval
)
139 (interval-parent (interval-left new
)) new
140 (interval-left interval
) new
141 (interval-length new
) (+ new-length
(interval-length (interval-left new
))))
142 (check-total-length new
)
143 (balance-an-interval new
))
145 (setf (interval-left interval
) new
146 (interval-length new
) new-length
)
147 (check-total-length new
)))
148 (balance-possible-root-interval interval
)
151 (defun split-interval-right (interval offset
)
152 (let* ((position (interval-pt interval
))
153 (new-length (- (interval-text-length interval
) offset
))
154 (new (make-interval :pt
(+ position offset
)
157 (setf (interval-parent new
) interval
)
158 (if (interval-right interval
)
160 (setf (interval-right new
) (interval-right interval
)
161 (interval-parent (interval-right interval
)) new
162 (interval-right interval
) new
163 (interval-length new
) (+ new-length
(interval-length (interval-right new
))))
164 (check-total-length new
)
165 (balance-an-interval new
))
167 (setf (interval-right interval
) new
168 (interval-length new
) new-length
)
169 (check-total-length new
)))
170 (balance-possible-root-interval interval
)
173 (defun right-child-p (root)
174 (eq root
(interval-right (interval-parent root
))))
176 (defun left-child-p (root)
177 (eq root
(interval-left (interval-parent root
))))
179 (defun interval-past-top-p (interval)
180 "Return t if INTERVAL is not an interval. Used to check when we've
181 climbed past the root interval."
182 (not (typep (interval-parent interval
) 'interval
)))
184 (defun rotate-right (interval)
185 "Assuming that a left child exists, perform the following operation:
193 (let ((old-total (interval-length interval
))
194 (b (interval-left interval
))
196 ;; Change interval's parent to point b.
197 (unless (root-interval-p interval
)
198 (if (left-child-p interval
)
199 (setf (interval-left (interval-parent interval
)) b
)
200 (setf (interval-right (interval-parent interval
)) b
)))
201 (setf (interval-parent b
) (interval-parent interval
))
202 ;; Make b the parent of a
203 (setf i
(interval-right b
)
204 (interval-right b
) interval
205 (interval-parent interval
) b
)
207 (setf (interval-left interval
) i
)
209 (setf (interval-parent i
) interval
))
210 ;; A's total length is decreased by the length of B and its left child.
211 (decf (interval-length interval
) (- (interval-length b
)
212 (left-total-length interval
)))
213 (check-total-length interval
)
214 ;; B must have the same total length of A.
215 (setf (interval-length b
) old-total
)
216 (check-total-length b
)
219 (defun rotate-left (interval)
220 "Assuming that a right child exists, perform the following operation:
228 (let ((old-total (interval-length interval
))
229 (b (interval-right interval
))
231 ;; Change interval's parent to point b.
232 (unless (root-interval-p interval
)
233 (if (left-child-p interval
)
234 (setf (interval-left (interval-parent interval
)) b
)
235 (setf (interval-right (interval-parent interval
)) b
)))
236 (setf (interval-parent b
) (interval-parent interval
))
237 ;; Make b the parent of a
238 (setf i
(interval-left b
)
239 (interval-left b
) interval
240 (interval-parent interval
) b
)
242 (setf (interval-right interval
) i
)
244 (setf (interval-parent i
) interval
))
245 ;; A's total length is decreased by the length of B and its left child.
246 (decf (interval-length interval
) (- (interval-length b
)
247 (right-total-length interval
)))
248 (check-total-length interval
)
249 ;; B must have the same total length of A.
250 (setf (interval-length b
) old-total
)
251 (check-total-length b
)
254 (defun total-length (root)
257 (interval-length root
)
260 (defun left-total-length (root)
261 (if (interval-left root
)
262 (interval-length (interval-left root
))
265 (defun right-total-length (root)
266 (if (interval-right root
)
267 (interval-length (interval-right root
))
270 (defun interval-text-length (root)
271 "The size of text represented by this interval alone. LENGTH."
273 (- (total-length root
)
274 (total-length (interval-right root
))
275 (total-length (interval-left root
)))
278 (defun balance-an-interval (i)
282 (setf old-diff
(- (left-total-length i
) (right-total-length i
)))
283 (cond ((> old-diff
0)
284 ;; Since the left child is longer, there must be one.
285 (setf new-diff
(+ (- (interval-length i
)
286 (interval-length (interval-left i
)))
287 (- (right-total-length (interval-left i
))
288 (left-total-length (interval-left i
)))))
289 (when (>= (abs new-diff
) old-diff
)
290 (return-from balance-an-interval i
))
291 (setf i
(rotate-right i
))
292 (balance-an-interval (interval-right i
)))
294 (setf new-diff
(+ (- (interval-length i
)
295 (interval-length (interval-right i
)))
296 (- (left-total-length (interval-right i
))
297 (right-total-length (interval-right i
)))))
298 (when (>= (abs new-diff
) (- old-diff
))
299 (return-from balance-an-interval i
))
300 (setf i
(rotate-left i
))
301 (balance-an-interval (interval-left i
)))
302 (t (return-from balance-an-interval i
))))))
304 (defun balance-possible-root-interval (interval)
305 (let ((has-parent nil
)
307 (when (null (interval-parent interval
))
308 (return-from balance-possible-root-interval interval
))
309 (when (interval-has-object interval
)
310 (setf parent
(interval-parent interval
)
312 (setf interval
(balance-intervals interval
))
314 (setf (intervals parent
) interval
))
317 (defun balance-intervals (tree)
318 "Balance the interval tree TREE. Balancing is by weight: the amount
320 (labels ((balance (tree)
321 (when (interval-left tree
)
322 (balance (interval-left tree
)))
323 (when (interval-right tree
)
324 (balance (interval-right tree
)))
325 (balance-an-interval tree
)))
329 (defun find-interval (tree position
)
330 (let ((relative-position position
))
332 (return-from find-interval nil
))
333 (assert (<= relative-position
(total-length tree
)))
334 (balance-possible-root-interval tree
)
336 (cond ((< relative-position
(left-total-length tree
))
337 (setf tree
(interval-left tree
)))
338 ((and (interval-right tree
)
339 (>= relative-position
(- (total-length tree
)
340 (right-total-length tree
))))
341 (decf relative-position
(- (total-length tree
)
342 (right-total-length tree
)))
343 (setf tree
(interval-right tree
)))
345 (setf (interval-pt tree
) (+ (- position relative-position
)
346 (left-total-length tree
)))
347 (return-from find-interval tree
))))))
349 (defun next-interval (interval)
350 (unless (null interval
)
352 (next-position (+ (interval-pt interval
)
353 (interval-text-length interval
))))
354 (when (interval-right interval
)
355 (setf i
(interval-right i
))
356 (loop while
(interval-left i
)
357 do
(setf i
(interval-left i
)))
358 (setf (interval-pt i
) next-position
)
359 (return-from next-interval i
))
360 (loop until
(interval-past-top-p i
)
363 (setf i
(interval-parent i
)
364 (interval-pt i
) next-position
)
365 (return-from next-interval i
))
366 do
(setf i
(interval-parent i
))))))
368 (defun previous-interval (interval)
369 (unless (null interval
)
371 (when (interval-left interval
)
372 (setf i
(interval-left i
))
373 (loop while
(interval-right i
)
374 do
(setf i
(interval-right i
)))
375 (setf (interval-pt i
) (- (interval-pt interval
)
376 (interval-text-length i
)))
377 (return-from previous-interval i
))
378 (loop until
(interval-past-top-p i
)
381 (setf i
(interval-parent i
)
382 (interval-pt i
) (- (interval-pt interval
)
383 (interval-text-length i
)))
384 (return-from previous-interval i
))
385 do
(setf i
(interval-parent i
))))))
387 (defun merge-interval-right (i)
388 (let ((absorb (interval-text-length i
))
390 (decf (interval-length i
) absorb
)
391 (check-total-length i
)
392 (when (interval-right i
)
393 (setf successor
(interval-right i
))
394 (loop while
(interval-left successor
)
396 (incf (interval-length successor
) absorb
)
397 (check-total-length successor
)
398 (setf successor
(interval-left successor
))))
399 (incf (interval-length successor
) absorb
)
400 (check-total-length successor
)
402 (return-from merge-interval-right successor
))
404 (loop while
(interval-parent successor
)
405 do
(if (left-child-p successor
)
407 (setf successor
(interval-parent successor
))
409 (return-from merge-interval-right successor
))
411 (setf successor
(interval-parent successor
))
412 (decf (interval-length successor
) absorb
)
413 (check-total-length successor
))))
414 (error "merge-interval-right: gak")))
416 (defun merge-interval-left (i)
417 (let ((absorb (interval-text-length i
))
419 (decf (interval-length i
) absorb
)
420 (check-total-length i
)
421 (when (interval-left i
)
422 (setf predecessor
(interval-left i
))
423 (loop while
(interval-right predecessor
)
424 do
(incf (interval-length predecessor
) absorb
)
425 (check-total-length predecessor
)
426 do
(setf predecessor
(interval-right predecessor
)))
427 (incf (interval-length predecessor
) absorb
)
428 (check-total-length predecessor
)
430 (return-from merge-interval-left predecessor
))
432 (loop while
(interval-parent predecessor
)
433 do
(when (interval-right predecessor
)
434 (setf predecessor
(interval-parent predecessor
))
436 (return-from merge-interval-left predecessor
))
437 do
(setf predecessor
(interval-parent predecessor
))
438 do
(decf (interval-length predecessor
) absorb
)
439 (check-total-length predecessor
)
441 (error "merge-interval-left: gak")))
444 ;; adjust_intervals_for_insertion (tree, position, length)
446 (defun adjust-intervals-for-insertion (tree position length
)
447 "Effect an adjustment corresponding to the addition of LENGTH characters
448 of text. Do this by finding the interval containing POSITION in the
449 interval tree TREE, and then adjusting all of its ancestors by adding
452 If POSITION is the first character of an interval, meaning that point
453 is actually between the two intervals, make the new text belong to
454 the interval which is \"sticky\".
456 If both intervals are \"sticky\", then make them belong to the left-most
457 interval. Another possibility would be to create a new interval for
458 this text, and make it have the merged properties of both ends."
459 (let* ((parent (interval-parent tree
))
460 (offset (if (typep parent
'buffer
)
464 ;; If inserting at point-max of a buffer, that position will be out
465 ;; of range. Remember that buffer positions are 1-based.
466 (when (>= position
(+ (total-length tree
) offset
))
467 (setf position
(+ (total-length tree
) offset
)
469 (setf i
(find-interval tree position
))
470 ;; If in middle of an interval which is not sticky either way,
471 ;; we must not just give its properties to the insertion.
472 ;; So split this interval at the insertion point.
474 ;; Originally, the if condition here was this:
475 ;; (! (position == i->position || eobp)
476 ;; && END_NONSTICKY_P (i)
477 ;; && FRONT_NONSTICKY_P (i))
478 ;; But, these macros are now unreliable because of introduction of
479 ;; Vtext_property_default_nonsticky. So, we always check properties
480 ;; one by one if POSITION is in middle of an interval.
481 (unless (or (= position
(interval-pt i
))
483 (let* ((rear (getf (interval-plist i
) 'rear-nonsticky
))
484 (front (getf (interval-plist i
) 'front-sticky
))
486 (when (or (and (not (consp rear
)) rear
)
487 (and (not (consp front
)) front
))
488 ;; All properties are nonsticky. We split the interval.
491 ;; Does any actual property pose an actual problem? We break
492 ;; the loop if we find a nonsticky property.
494 (setf problem
(do* ((tail (interval-plist i
) (cddr tail
))
495 (prop (cdr tail
) (cdr tail
)))
497 (and (not (and (consp front
)
498 (not (find prop front
))))
499 (or (and (consp rear
)
500 (not (find prop rear
)))
501 (let ((tmp (assoc prop
*text-property-default-nonsticky
*)))
502 (and (consp tmp
) tmp
)))))
504 ;; If any property is a real problem, split the interval.
506 (setf temp
(split-interval-right i
(- position
(interval-pt i
))))
507 (copy-properties i temp
)
509 ;; If we are positioned between intervals, check the stickiness of
510 ;; both of them. We have to do this too, if we are at BEG or Z.
511 (if (or (= position
(interval-pt i
))
513 (let ((prev (cond ((= position
+beg
+) nil
)
515 (t (previous-interval i
)))))
518 ;; Even if we are positioned between intervals, we default
519 ;; to the left one if it exists. We extend it now and split
520 ;; off a part later, if stickiness demands it.
521 (do ((tmp (or prev i
) (when (interval-has-parent tmp
)
522 (interval-parent tmp
))))
524 (incf (interval-length tmp
) length
)
525 ;; CHECK_TOTAL_LENGTH (temp);
526 (setf tmp
(balance-possible-root-interval tmp
)))
527 ;; If at least one interval has sticky properties, we check
528 ;; the stickiness property by property.
530 ;; Originally, the if condition here was this:
531 ;; (END_NONSTICKY_P (prev) || FRONT_STICKY_P (i))
532 ;; But, these macros are now unreliable because of introduction
533 ;; of Vtext_property_default_nonsticky. So, we always have to
534 ;; check stickiness of properties one by one. If cache of
535 ;; stickiness is implemented in the future, we may be able to
536 ;; use those macros again.
537 (let* ((pleft (when prev
538 (interval-plist prev
)))
541 (new-props (merge-properties-sticky pleft pright
)))
543 ;; /* i.e. position == BEG */
544 (unless (plists-equal (interval-plist i
) new-props
)
545 (setf i
(split-interval-left i length
)
546 (interval-plist i
) new-props
)))
547 ((not (plists-equal (interval-plist prev
) new-props
))
548 (setf prev
(split-interval-right prev
(- position
(interval-pt prev
)))
549 (interval-plist prev
) new-props
)
551 (plists-equal (interval-plist prev
) (interval-plist i
)))
552 (merge-interval-right prev
)))
554 (not (null (interval-plist i
))))
555 ;; Just split off a new interval at the left.
556 ;; Since I wasn't front-sticky, the empty plist is ok.
557 (setf i
(split-interval-left i length
))))))
558 ;; Otherwise just extend the interval.
559 (do ((tmp i
(when (interval-has-parent tmp
)
560 (interval-parent tmp
))))
562 (incf (interval-length tmp
) length
)
563 ;; CHECK_TOTAL_LENGTH (temp);
564 (setf tmp
(balance-possible-root-interval tmp
))))
567 (defun interval-deletion-adjustment (tree from amount
)
568 "Find the interval in TREE corresponding to the relative position
569 FROM and delete as much as possible of AMOUNT from that interval.
570 Return the amount actually deleted, and if the interval was
571 zeroed-out, delete that interval node from the tree.
573 Note that FROM is actually origin zero, aka relative to the
574 leftmost edge of tree. This is appropriate since we call ourselves
575 recursively on subtrees.
577 Do this by recursing down TREE to the interval in question, and
578 deleting the appropriate amount of text."
579 (let ((relative-position from
))
584 ((< relative-position
(left-total-length tree
))
585 (let ((subtract (interval-deletion-adjustment (interval-left tree
)
588 (decf (interval-length tree
) subtract
)
589 ;; CHECK_TOTAL_LENGTH
592 ((>= relative-position
(- (total-length tree
)
593 (right-total-length tree
)))
594 (decf relative-position
(- (interval-length tree
)
595 (right-total-length tree
)))
596 (let ((subtract (interval-deletion-adjustment (interval-right tree
)
599 (decf (interval-length tree
) subtract
)
600 ;; CHECK_TOTAL_LENGTH
604 ;; How much can we delete from this interval?
605 (let ((my-amount (- (interval-length tree
)
606 (right-total-length tree
)
608 (when (> amount my-amount
)
609 (setf amount my-amount
))
610 (decf (interval-length tree
) amount
)
611 ;; CHECK_TOTAL_LENGTH
612 (when (zerop (total-length tree
))
613 (delete-interval tree
))
616 (defun adjust-intervals-for-deletion (buffer start length
)
617 "Effect the adjustments necessary to the interval tree of BUFFER to
618 correspond to the deletion of LENGTH characters from that buffer
619 text. The deletion is effected at position START (which is a
620 buffer position, i.e. origin 1)."
621 (let ((left-to-delete length
)
622 (tree (intervals buffer
))
623 (offset (buffer-min buffer
)))
626 ((or (> start
(+ offset
(total-length tree
)))
627 (> (+ start length
) (+ offset
(total-length tree
))))
628 (error "gak ~a ~a ~a ~a" tree offset
(total-length tree
) length
))
629 ((= length
(total-length tree
))
630 (setf (intervals buffer
) nil
))
631 ((only-interval-p tree
)
632 (decf (interval-length tree
) length
)) ;; CHECK_TOTAL_LENGTH
634 (when (> start
(+ offset
(total-length tree
)))
635 (setf start
(+ offset
(total-length tree
))))
636 (loop while
(> left-to-delete
0) do
639 (interval-deletion-adjustment tree
(- start offset
) left-to-delete
))
640 (setf tree
(intervals buffer
))
641 (when (= left-to-delete
(interval-length tree
))
642 (setf (intervals buffer
) nil
)
645 (defun interval-start-pos (source)
646 (if (or (null source
)
647 (not (typep (interval-parent source
) 'buffer
)))
649 (buffer-min (interval-parent source
))))
651 (defun graft-intervals-into-buffer (source position length buffer inherit
)
652 "Insert the intervals of SOURCE into BUFFER at POSITION.
653 LENGTH is the length of the text in SOURCE.
655 The `position' field of the SOURCE intervals is assumed to be
656 consistent with its parent; therefore, SOURCE must be an
657 interval tree made with copy_interval or must be the whole
658 tree of a buffer or a string.
660 This is used in insdel.c when inserting Lisp_Strings into the
661 buffer. The text corresponding to SOURCE is already in the buffer
662 when this is called. The intervals of new tree are a copy of those
663 belonging to the string being inserted; intervals are never
666 If the inserted text had no intervals associated, and we don't
667 want to inherit the surrounding text's properties, this function
668 simply returns -- offset_intervals should handle placing the
669 text in the correct interval, depending on the sticky bits.
671 If the inserted text had properties (intervals), then there are two
672 cases -- either insertion happened in the middle of some interval,
673 or between two intervals.
675 If the text goes into the middle of an interval, then new
676 intervals are created in the middle with only the properties of
677 the new text, *unless* the macro MERGE_INSERTIONS is true, in
678 which case the new text has the union of its properties and those
679 of the text into which it was inserted.
681 If the text goes between two intervals, then if neither interval
682 had its appropriate sticky property set (front_sticky, rear_sticky),
683 the new text has only its properties. If one of the sticky properties
684 is set, then the new text \"sticks\" to that region and its properties
685 depend on merging as above. If both the preceding and succeeding
686 intervals to the new text are \"sticky\", then the new text retains
687 only its properties, as if neither sticky property were set. Perhaps
688 we should consider merging all three sets of properties onto the new
690 (let ((tree (intervals buffer
))
692 under over this prev
)
693 ;; /* If the new text has no properties, then with inheritance it
694 ;; becomes part of whatever interval it was inserted into.
695 ;; To prevent inheritance, we must clear out the properties
696 ;; of the newly inserted text. */
698 (when (and (not inherit
)
701 ;; XSETBUFFER (buf, buffer);
702 (set-text-properties-1 position
(+ position length
) nil buffer
0))
703 (when (intervals buffer
)
704 (setf (intervals buffer
) (balance-an-interval (intervals buffer
))))
705 (return-from graft-intervals-into-buffer
))
707 ;; /* The inserted text constitutes the whole buffer, so
708 ;; simply copy over the interval structure. */
709 (when (= (- (buffer-size buffer
) (buffer-min buffer
))
710 (total-length source
))
711 (setf (intervals buffer
) (reproduce-tree source buffer
)
712 (interval-pt (intervals buffer
)) (buffer-min buffer
))
713 (return-from graft-intervals-into-buffer
))
714 ;; /* Create an interval tree in which to place a copy
715 ;; of the intervals of the inserted string. */
716 (setf tree
(create-root-interval buffer
)))
717 ((= (total-length tree
)
718 (total-length source
))
719 ;; /* If the buffer contains only the new string, but
720 ;; there was already some interval tree there, then it may be
721 ;; some zero length intervals. Eventually, do something clever
722 ;; about inserting properly. For now, just waste the old intervals. */
723 (setf (intervals buffer
) (reproduce-tree source
(interval-parent tree
))
724 (interval-pt (intervals buffer
)) (buffer-min buffer
))
725 (return-from graft-intervals-into-buffer
))
726 ((zerop (total-length tree
))
728 (setf under
(find-interval tree position
)
730 over
(find-interval source
(interval-start-pos source
)))
731 (if (> position
(interval-pt under
))
732 (let ((end-unchanged (split-interval-left this
(- position
(interval-pt under
)))))
733 (copy-properties under end-unchanged
)
734 (setf (interval-pt under
) position
))
735 (setf prev
(previous-interval under
)))
738 (if (< (- (interval-text-length over
) over-used
)
739 (interval-text-length under
))
741 (setf this
(split-interval-left under
(- (interval-text-length over
)
743 (copy-properties under this
))
745 ;; /* THIS is now the interval to copy or merge into.
746 ;; OVER covers all of it. */
748 (merge-properties over this
)
749 (copy-properties over this
))
750 ;; /* If THIS and OVER end at the same place,
751 ;; advance OVER to a new source interval. */
752 (if (= (interval-text-length this
)
753 (- (interval-text-length over
) over-used
))
755 (setf over
(next-interval over
)
757 ;; /* Otherwise just record that more of OVER has been used. */
758 (incf over-used
(interval-text-length this
)))
759 ;; /* Always advance to a new target interval. */
760 (setf under
(next-interval this
)))
761 (when (intervals buffer
)
762 (setf (intervals buffer
) (balance-an-interval (intervals buffer
))))))
764 (defun root-interval-p (i)
765 "Return true if i is the root interval node."
766 (or (null (interval-parent i
))
767 (not (typep (interval-parent i
) 'interval
))))
769 (defun root-interval (interval)
770 "Return the root of interval."
771 (do ((i interval
(interval-parent i
)))
772 ((root-interval-p i
) i
)))
774 (defun leaf-interval-p (i)
775 "Return T if this interval has no children."
776 (and (null (interval-left i
))
777 (null (interval-right i
))))
779 (defun only-interval-p (i)
780 "Return T if this interval is the only interval in the interval tree."
781 (and (root-interval-p i
)
782 (leaf-interval-p i
)))
785 (defun delete-node (i)
787 (when (null (interval-left i
))
788 (return-from delete-node
(interval-right i
)))
789 (when (null (interval-right i
))
790 (return-from delete-node
(interval-left i
)))
792 (let ((migrate (interval-left i
))
793 (this (interval-right i
))
794 (migrate-amt (interval-length (interval-left i
))))
795 (loop while
(interval-left this
)
796 do
(setf this
(interval-left this
))
797 do
(incf (interval-length this
) migrate-amt
))
798 (check-total-length this
)
799 (setf (interval-left this
) migrate
)
800 (setf (interval-parent migrate
) this
)
803 (defun delete-interval (i)
804 (let ((amt (interval-text-length i
))
807 (error "only used on zero length intervals."))
808 (when (root-interval-p i
)
809 (let ((owner (interval-parent i
)))
810 (setf parent
(delete-node i
))
811 (when (interval-parent parent
)
812 (setf (interval-parent parent
) owner
))
813 (setf (intervals owner
) parent
)
814 (return-from delete-interval
)))
815 (setf parent
(interval-parent i
))
818 (setf (interval-left parent
) (delete-node i
))
819 (when (interval-left parent
)
820 (setf (interval-parent (interval-left parent
)) parent
)))
822 (setf (interval-right parent
) (delete-node i
))
823 (when (interval-right parent
)
824 (setf (interval-parent (interval-right parent
)) parent
))))))
826 (defun default-interval-p (i)
828 (null (interval-plist i
))))
830 (defun reproduce-tree (source parent
)
831 (let ((tree (copy-interval source
)))
832 (setf (interval-plist tree
) (copy-list (interval-plist source
))
833 (interval-parent tree
) parent
)
834 (when (interval-left source
)
835 (setf (interval-left tree
) (reproduce-tree (interval-left source
) tree
)))
836 (when (interval-right source
)
837 (setf (interval-right tree
) (reproduce-tree (interval-right source
) tree
)))
840 (defun merge-properties (source target
)
841 "/* Merge the properties of interval SOURCE into the properties of
842 interval TARGET. That is to say, each property in SOURCE is added to
843 TARGET if TARGET has no such property as yet. */"
844 (unless (and (default-interval-p source
)
845 (default-interval-p target
))
846 (doplist (sym val
(interval-plist source
))
847 (let ((found (getf (interval-plist target
) sym
)))
849 (setf (getf (interval-plist target
) sym
) val
))))))
851 (defun merge-properties-sticky (pleft pright
)
852 "Any property might be front-sticky on the left, rear-sticky on the left,
853 front-sticky on the right, or rear-sticky on the right; the 16 combinations
854 can be arranged in a matrix with rows denoting the left conditions and
855 columns denoting the right conditions:
863 left-props = '(front-sticky (p8 p9 pa pb pc pd pe pf)
864 rear-nonsticky (p4 p5 p6 p7 p8 p9 pa pb)
865 p0 L p1 L p2 L p3 L p4 L p5 L p6 L p7 L
866 p8 L p9 L pa L pb L pc L pd L pe L pf L)
867 right-props = '(front-sticky (p2 p3 p6 p7 pa pb pe pf)
868 rear-nonsticky (p1 p2 p5 p6 p9 pa pd pe)
869 p0 R p1 R p2 R p3 R p4 R p5 R p6 R p7 R
870 p8 R p9 R pa R pb R pc R pd R pe R pf R)
872 We inherit from whoever has a sticky side facing us. If both sides
873 do (cases 2, 3, E, and F), then we inherit from whichever side has a
874 non-nil value for the current property. If both sides do, then we take
877 When we inherit a property, we get its stickiness as well as its value.
878 So, when we merge the above two lists, we expect to get this:
880 result = '(front-sticky (p6 p7 pa pb pc pd pe pf)
881 rear-nonsticky (p6 pa)
882 p0 L p1 L p2 L p3 L p6 R p7 R
883 pa R pb R pc L pd L pe L pf L)
885 The optimizable special cases are:
886 left rear-nonsticky = nil, right front-sticky = nil (inherit left)
887 left rear-nonsticky = t, right front-sticky = t (inherit right)
888 left rear-nonsticky = t, right front-sticky = nil (inherit none)"
889 (labels ((tmem (sym set
)
890 ;; Test for membership, allowing for t (actually any
891 ;; non-cons) to mean the universal set."
898 (lfront (getf pleft
'front-sticky
))
899 (lrear (getf pleft
'rear-nonsticky
))
900 (rfront (getf pright
'front-sticky
))
901 (rrear (getf pright
'rear-nonsticky
))
902 cat use-left use-right
)
903 (doplist (sym rval pright
)
904 (unless (or (eq sym
'rear-nonsticky
)
905 (eq sym
'front-sticky
))
906 ;; Indicate whether the property is explicitly
907 ;; defined on the left. (We know it is defined
908 ;; explicitly on the right because otherwise we don't
910 (let* ((lval (getf pleft sym
))
911 ;; Even if lrear or rfront say nothing about the
912 ;; stickiness of SYM,
913 ;; Vtext_property_default_nonsticky may give
914 ;; default stickiness to SYM.
915 (tmp (assoc sym
*text-property-default-nonsticky
*)))
916 (setf use-left
(and lval
917 (not (or (tmem sym lrear
)
920 use-right
(or (tmem sym lrear
)
928 (setf use-right nil
))))
930 ;; We build props as (value sym ...) rather than (sym value ...)
931 ;; because we plan to nreverse it when we're done.
932 (setf (getf props sym
) lval
)
933 (when (tmem sym lfront
)
935 (when (tmem sym lrear
)
938 (setf (getf props sym
) rval
)
939 (when (tmem sym rfront
)
941 (when (tmem sym rrear
)
942 (push sym rear
)))))))
943 ;; Now go through each element of PLEFT.
944 (doplist (sym lval pleft
)
945 (unless (or (eq sym
'rear-nonsticky
)
946 (eq sym
'front-sticky
))
947 ;; If sym is in PRIGHT, we've already considered it.
948 (let* ((present (getf pright sym
))
949 ;; Even if lrear or rfront say nothing about the
950 ;; stickiness of SYM,
951 ;; Vtext_property_default_nonsticky may give
952 ;; default stickiness to SYM.
953 (tmp (assoc sym
*text-property-default-nonsticky
*)))
954 ;; XXX: if sym is set in pright to nil, its the same
955 ;; as sym not being in the list.
957 ;; Since rval is known to be nil in this loop, the test simplifies.
958 (cond ((not (or (tmem sym lrear
)
961 (setf (getf props sym
) lval
)
962 (when (tmem sym lfront
)
964 ((or (tmem sym rfront
)
967 ;; The value is nil, but we still inherit the stickiness
969 (setf (getf props sym
) lval
)
970 (when (tmem sym rrear
)
971 (push sym rear
))))))))
973 (setf (getf props
'rear-nonsticky
) (nreverse rear
)))
974 (setf cat
(textget props
'category
))
975 ;; If we have inherited a front-stick category property that is t,
976 ;; we don't need to set up a detailed one.
980 (eq (get cat
'front-sticky
) t
))))
981 (setf (getf props
'front-sticky
) (nreverse front
)))
984 (defun offset-intervals (buffer start length
)
985 "Make the adjustments necessary to the interval tree of BUFFER to
986 represent an addition or deletion of LENGTH characters starting
987 at position START. Addition or deletion is indicated by the sign
989 (unless (or (null (intervals buffer
))
992 (adjust-intervals-for-insertion (intervals buffer
) start length
)
993 (adjust-intervals-for-deletion buffer
(+ start length
) (- length
)))))
995 (provide :lice-0.1
/intervals
)