diff --git a/rmacs/rope.rkt b/rmacs/rope.rkt index 778abeb..e49878f 100644 --- a/rmacs/rope.rkt +++ b/rmacs/rope.rkt @@ -8,7 +8,8 @@ strand-equal? strand-empty? - rope? + (rename-out [rope?* rope?]) + rope-empty? empty-rope strand->rope string->rope @@ -19,7 +20,6 @@ rope-split rope-append rope-concat - subrope* subrope rope-generator rope-seek @@ -83,14 +83,15 @@ text (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 t (if (string? t0) (string->strand t0) t0)) - (define lo (if (not lo0) - 0 - (modulo lo0 (strand-count t)))) - (define hi (if (not hi0) - (strand-count t) - (modulo hi0 (strand-count t)))) + (define lo (compute-index lo0 0 (strand-count t))) + (define hi (compute-index hi0 (strand-count t) (strand-count t))) (strand (strand-text t) (+ (strand-offset t) lo) (- hi lo))) @@ -124,8 +125,15 @@ (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) - (rope t #f #f (strand-count t) (seteq) (hasheq))) + (rope t (empty-rope) (empty-rope) (strand-count t) (seteq) (hasheq))) (define (string->rope s) (strand->rope (string->strand s))) @@ -197,7 +205,7 @@ (values lo (+ lo (strand-count (rope-strand r))))) (define (find-position pos r) - (if (not r) + (if (rope-empty? r) (values 'here (zero? pos)) (let-values (((lo hi) (rope-lo+hi r))) (cond @@ -280,10 +288,10 @@ (define (set-mark r0 mtype position value) (define r (splay-to-pos 'set-mark r0 position (lambda () (format " setting mark ~a" mtype)))) (reindex - (if (not r) + (if (rope-empty? r) (rope (empty-strand) - #f - #f + (empty-rope) + (empty-rope) 'will-be-recomputed 'will-be-recomputed (hasheq mtype (hash position value))) @@ -334,20 +342,23 @@ (list->seteq (hash-keys (rope-mark-index r))))])) (define (rope-split r0 position) - (define r (splay-to-pos 'rope-split r0 position)) - ;; 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 offset (- position lo)) - (define-values (left-index right-index) (partition-mark-index mark-index offset)) - (define left-strand (substrand t 0 offset)) - (define right-strand (substrand t offset)) - (values (if (strand-empty? left-strand) - rl - (reindex (rope left-strand rl #f 'will-be-recomputed (seteq) left-index))) - (if (strand-empty? right-strand) - rr - (reindex (rope right-strand #f rr 'will-be-recomputed (seteq) right-index))))) + (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. + (define-values (lo hi) (rope-lo+hi r)) + (define offset (- position lo)) + (define-values (left-index right-index) (partition-mark-index mark-index offset)) + (define left-strand (substrand t 0 offset)) + (define right-strand (substrand t offset)) + (values (if (strand-empty? left-strand) + rl + (reindex + (rope left-strand rl (empty-rope) 'will-be-recomputed (seteq) left-index))) + (if (strand-empty? right-strand) + rr + (reindex + (rope right-strand (empty-rope) rr 'will-be-recomputed (seteq) right-index))))])) (define (partition-mark-index index offset) (for*/fold [(l (hasheq)) (r (hasheq))] @@ -362,12 +373,12 @@ (define (rope-append rl0 rr0) (cond - [(not rl0) rr0] - [(not rr0) rl0] + [(rope-empty? rl0) rr0] + [(rope-empty? rr0) rl0] [else (define-values (_l rl) (splay-to rl0 find-position (rope-size rl0))) (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))) (if t (let ((merged-index (merge-mark-indexes (rope-mark-index rl) @@ -385,19 +396,11 @@ ((pos val) (in-hash posvals))] (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-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) (define (rope-generator r #:forward? [forward? #t]) @@ -511,4 +514,7 @@ (test-with-pieces (list "hello" ", " "world")) (test-with-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))) )