misc-deps
/
racket-ansi
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fixes wrt empty ropes

This commit is contained in:
Tony Garnock-Jones 2014-12-22 14:03:02 -05:00
parent ee71d7ad44
commit 3c17ddd755
1 changed files with 48 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
rmacs/rope.rkt
View File

@ -8,7 +8,8 @@
strand-equal? strand-equal?
strand-empty? strand-empty?
rope? (rename-out [rope?* rope?])
rope-empty?
empty-rope empty-rope
strand->rope strand->rope
string->rope string->rope
@ -19,7 +20,6 @@
rope-split rope-split
rope-append rope-append
rope-concat rope-concat
subrope*
subrope subrope
rope-generator rope-generator
rope-seek rope-seek
@ -83,14 +83,15 @@
text text
(substring text offset (+ offset count)))) (substring text offset (+ offset count))))
(define (compute-index index default limit)
(cond [(not index) default]
[(zero? limit) 0]
[else (modulo index limit)]))
(define (substrand t0 [lo0 #f] [hi0 #f]) (define (substrand t0 [lo0 #f] [hi0 #f])
(define t (if (string? t0) (string->strand t0) t0)) (define t (if (string? t0) (string->strand t0) t0))
(define lo (if (not lo0) (define lo (compute-index lo0 0 (strand-count t)))
0 (define hi (compute-index hi0 (strand-count t) (strand-count t)))
(modulo lo0 (strand-count t))))
(define hi (if (not hi0)
(strand-count t)
(modulo hi0 (strand-count t))))
(strand (strand-text t) (strand (strand-text t)
(+ (strand-offset t) lo) (+ (strand-offset t) lo)
(- hi lo))) (- hi lo)))
@ -124,8 +125,15 @@
(define (empty-rope) #f) (define (empty-rope) #f)
(define (rope-empty? r)
(equal? r (empty-rope)))
(define (rope?* r)
(or (rope-empty? r)
(rope? r)))
(define (strand->rope t) (define (strand->rope t)
(rope t #f #f (strand-count t) (seteq) (hasheq))) (rope t (empty-rope) (empty-rope) (strand-count t) (seteq) (hasheq)))
(define (string->rope s) (define (string->rope s)
(strand->rope (string->strand s))) (strand->rope (string->strand s)))
@ -197,7 +205,7 @@
(values lo (+ lo (strand-count (rope-strand r))))) (values lo (+ lo (strand-count (rope-strand r)))))
(define (find-position pos r) (define (find-position pos r)
(if (not r) (if (rope-empty? r)
(values 'here (zero? pos)) (values 'here (zero? pos))
(let-values (((lo hi) (rope-lo+hi r))) (let-values (((lo hi) (rope-lo+hi r)))
(cond (cond
@ -280,10 +288,10 @@
(define (set-mark r0 mtype position value) (define (set-mark r0 mtype position value)
(define r (splay-to-pos 'set-mark r0 position (lambda () (format " setting mark ~a" mtype)))) (define r (splay-to-pos 'set-mark r0 position (lambda () (format " setting mark ~a" mtype))))
(reindex (reindex
(if (not r) (if (rope-empty? r)
(rope (empty-strand) (rope (empty-strand)
#f (empty-rope)
#f (empty-rope)
'will-be-recomputed 'will-be-recomputed
'will-be-recomputed 'will-be-recomputed
(hasheq mtype (hash position value))) (hasheq mtype (hash position value)))
@ -334,9 +342,10 @@
(list->seteq (hash-keys (rope-mark-index r))))])) (list->seteq (hash-keys (rope-mark-index r))))]))
(define (rope-split r0 position) (define (rope-split r0 position)
(define r (splay-to-pos 'rope-split r0 position)) (match (splay-to-pos 'rope-split r0 position)
[(? rope-empty?) (values (empty-rope) (empty-rope))]
[(and r (rope t rl rr size marks mark-index))
;; We know the position is in the root of r. ;; We know the position is in the root of r.
(match-define (rope t rl rr size marks mark-index) r)
(define-values (lo hi) (rope-lo+hi r)) (define-values (lo hi) (rope-lo+hi r))
(define offset (- position lo)) (define offset (- position lo))
(define-values (left-index right-index) (partition-mark-index mark-index offset)) (define-values (left-index right-index) (partition-mark-index mark-index offset))
@ -344,10 +353,12 @@
(define right-strand (substrand t offset)) (define right-strand (substrand t offset))
(values (if (strand-empty? left-strand) (values (if (strand-empty? left-strand)
rl rl
(reindex (rope left-strand rl #f 'will-be-recomputed (seteq) left-index))) (reindex
(rope left-strand rl (empty-rope) 'will-be-recomputed (seteq) left-index)))
(if (strand-empty? right-strand) (if (strand-empty? right-strand)
rr rr
(reindex (rope right-strand #f rr 'will-be-recomputed (seteq) right-index))))) (reindex
(rope right-strand (empty-rope) rr 'will-be-recomputed (seteq) right-index))))]))
(define (partition-mark-index index offset) (define (partition-mark-index index offset)
(for*/fold [(l (hasheq)) (r (hasheq))] (for*/fold [(l (hasheq)) (r (hasheq))]
@ -362,12 +373,12 @@
(define (rope-append rl0 rr0) (define (rope-append rl0 rr0)
(cond (cond
[(not rl0) rr0] [(rope-empty? rl0) rr0]
[(not rr0) rl0] [(rope-empty? rr0) rl0]
[else [else
(define-values (_l rl) (splay-to rl0 find-position (rope-size rl0))) (define-values (_l rl) (splay-to rl0 find-position (rope-size rl0)))
(define-values (_r rr) (splay-to rr0 find-position 0)) (define-values (_r rr) (splay-to rr0 find-position 0))
;; Both rl's right and rr's left are #f. ;; Both rl's right and rr's left are (empty-rope).
(define t (strand-maybe-append (rope-strand rl) (rope-strand rr))) (define t (strand-maybe-append (rope-strand rl) (rope-strand rr)))
(if t (if t
(let ((merged-index (merge-mark-indexes (rope-mark-index rl) (let ((merged-index (merge-mark-indexes (rope-mark-index rl)
@ -385,19 +396,11 @@
((pos val) (in-hash posvals))] ((pos val) (in-hash posvals))]
(add-mark-to-table i mtype (+ pos offset) val))) (add-mark-to-table i mtype (+ pos offset) val)))
(define (subrope* r0 [lo0 #f] [hi0 #f])
(define lo (if (not lo0)
0
(modulo lo0 (rope-size r0))))
(define hi (if (not hi0)
(rope-size r0)
(modulo hi0 (rope-size r0))))
(define-values (_l left-marks-at-split mr) (rope-split r0 lo))
(define-values (m right-marks-at-split _r) (rope-split mr (- hi lo)))
(values left-marks-at-split m right-marks-at-split))
(define (subrope r0 [lo0 #f] [hi0 #f]) (define (subrope r0 [lo0 #f] [hi0 #f])
(define-values (_l m _r) (subrope* r0 lo0 hi0)) (define lo (compute-index lo0 0 (rope-size r0)))
(define hi (compute-index hi0 (rope-size r0) (rope-size r0)))
(define-values (_l mr) (rope-split r0 lo))
(define-values (m _r) (rope-split mr (- hi lo)))
m) m)
(define (rope-generator r #:forward? [forward? #t]) (define (rope-generator r #:forward? [forward? #t])
@ -511,4 +514,7 @@
(test-with-pieces (list "hello" ", " "world")) (test-with-pieces (list "hello" ", " "world"))
(test-with-pieces prejudice-pieces) (test-with-pieces prejudice-pieces)
(test-with-pieces (atomize-pieces prejudice-pieces)) (test-with-pieces (atomize-pieces prejudice-pieces))
(check-equal? (call-with-values (lambda () (rope-split (empty-rope) 0)) list)
(list (empty-rope) (empty-rope)))
) )