diff options
| -rw-r--r-- | par/piece-table.scm | 277 | ||||
| -rw-r--r-- | par/piece-table.sld | 4 | ||||
| -rw-r--r-- | tests/piece-table.scm | 13 |
3 files changed, 178 insertions, 116 deletions
diff --git a/par/piece-table.scm b/par/piece-table.scm index 65e733f..54cb9a9 100644 --- a/par/piece-table.scm +++ b/par/piece-table.scm @@ -19,8 +19,37 @@ (length piece-length set-piece-length!) (type piece-type set-piece-type!) (linebreaks piece-linebreaks set-piece-linebreaks!) - (next piece-next set-piece-next!) - (prev piece-prev set-piece-prev!)) + (next %piece-next %set-piece-next!) + (prev %piece-prev %set-piece-prev!)) + +(define-record-type <sentinel-piece> + (make-sentinel-piece next prev) + sentinel-piece? + (next %sentinel-piece-next %set-sentinel-piece-next!) + (prev %sentinel-piece-prev %set-sentinel-piece-prev!)) + +;; TODO think about a way to make all this polymorphism automagic +(define (piece-next p) + (cond + ((sentinel-piece? p) (%sentinel-piece-next p)) + ((piece? p) (%piece-next p)))) + +(define (piece-prev p) + (cond + ((sentinel-piece? p) (%sentinel-piece-prev p)) + ((piece? p) (%piece-prev p)))) + +(define (set-piece-prev! p prev) + (cond + ((sentinel-piece? p) (%set-sentinel-piece-prev! p prev)) + ((piece? p) (%set-piece-prev! p prev)))) + +(define (set-piece-next! p next) + (cond + ((sentinel-piece? p) (%set-sentinel-piece-next! p next)) + ((piece? p) (%set-piece-next! p next)))) +;; + (define (index-linebreaks buffer start length) (define str (buffer->string buffer)) @@ -38,13 +67,9 @@ start length) (list->vector (reverse outlist))) -(define (make-piece buffer start length type prev next) - (%make-piece buffer start length type (index-linebreaks buffer start length) - prev next)) - (define (can-merge-pieces? a b) ;; Maybe simplify the and/or/not magic? - (and (not (or (null? a) (null? b))) + (and (not (or (sentinel-piece? a) (sentinel-piece? b))) (or (or (= 0 (piece-length a)) (= 0 (piece-length b))) (and (eq? (piece-buffer a) (piece-buffer b)) @@ -58,14 +83,7 @@ (set-piece-linebreaks! a (vector-append (piece-linebreaks a) (piece-linebreaks b))) (set-piece-next! a (piece-next b)) - (unless (null? (piece-next b)) (set-piece-prev! (piece-next b) a))) - -(define (connect-pieces! a b) - (if (can-merge-pieces? a b) - (merge-pieces! a b) - (begin - (set-piece-next! a b) - (set-piece-prev! b a)))) + (unless (sentinel-piece? (piece-next b)) (set-piece-prev! (piece-next b) a))) (define (split-linebreaks linebreaks at) (let* ((lb-l (vector-length linebreaks)) @@ -78,20 +96,34 @@ (vector-map (lambda (x) (- x at)) (vector-copy linebreaks lb-at lb-l))))) +;; Piece API +(define (make-piece buffer start length type prev next) + (%make-piece buffer start length type (index-linebreaks buffer start length) + prev next)) + +(define (connect-pieces! a b) + (begin + (set-piece-next! a b) + (set-piece-prev! b a))) + (define (split-piece! a at) - (let-values (((lb-a lb-b) (split-linebreaks (piece-linebreaks a) at))) - (letrec* ((b (%make-piece (piece-buffer a) - (+ at (piece-start a)) - (- (piece-length a) at) - (piece-type a) - lb-b - (piece-next a) - a))) - (unless (null? (piece-next a)) (set-piece-prev! (piece-next a) b)) - (set-piece-length! a at) - (set-piece-linebreaks! a lb-a) - (set-piece-next! a b) - (values a b)))) + (if (and (= at 0) (sentinel-piece? a)) + (values a a) ;; Just return the sentinel twice, as this is only used to + ;; take one of them + (let-values (((lb-a lb-b) (split-linebreaks (piece-linebreaks a) at))) + (letrec* ((b (%make-piece (piece-buffer a) + (+ at (piece-start a)) + (- (piece-length a) at) + (piece-type a) + lb-b + (piece-next a) + a))) + (unless (sentinel-piece? (piece-next a)) + (set-piece-prev! (piece-next a) b)) + (set-piece-length! a at) + (set-piece-linebreaks! a lb-a) + (set-piece-next! a b) + (values a b))))) @@ -114,11 +146,13 @@ (string add-buffer-string set-add-buffer-string!) (used add-buffer-used set-add-buffer-used!)) +;; TODO think about a way to make all this polymorphism automagic (define (buffer->string buffer) "Returns the underlying string of the buffer" (cond ((add-buffer? buffer) (add-buffer-string buffer)) - ((ro-buffer? buffer) (ro-buffer-string buffer)))) + ((ro-buffer? buffer) (ro-buffer-string buffer)))) +;; (define add-buffer-length (make-parameter 100)) @@ -134,24 +168,14 @@ (string-copy! new 0 str))) (define (add-buffer-append! add-buffer str) - "Appends to add buffer, growing if necessary and returns the resulting piece - as a template function" + "Appends to add buffer, growing if necessary" (let ((append-len (string-length str)) (buffer-used (add-buffer-used add-buffer)) (buffer-size (string-length (add-buffer-string add-buffer)))) (when (>= (+ append-len buffer-used) buffer-size) (enlarge-add-buffer! add-buffer append-len)) (string-copy! (add-buffer-string add-buffer) buffer-used str) - (set-add-buffer-used! add-buffer (+ append-len buffer-used)) - - ;; TODO: make this another way? maybe it's fine to do it like this... - (lambda (type) - (make-piece add-buffer - buffer-used - (string-length str) - type - (list) - (list))))) + (set-add-buffer-used! add-buffer (+ append-len buffer-used)))) @@ -167,26 +191,43 @@ (define (make-piece-table original) - (let ((ro-buffer (make-ro-buffer original))) + (letrec* ((ro-buffer (make-ro-buffer original)) + (piece (make-piece ro-buffer 0 (string-length original) 'normal + sentinel sentinel)) + (sentinel (make-sentinel-piece piece piece))) + (set-piece-prev! piece sentinel) + (set-piece-next! piece sentinel) (%make-piece-table - ro-buffer (make-add-buffer) - (make-piece ro-buffer 0 (string-length original) 'normal (list) (list))))) + ro-buffer (make-add-buffer) piece))) + +(define (piece-table-index->piece+index piece-table pos) + "Returns (values piece remainder) or eof-object" + (let loop ((piece (piece-table-piece piece-table)) + (rem pos)) + (cond + ((sentinel-piece? piece) + (if (= rem 0) + (values piece rem) + (error "Requested position out of piece-table"))) + ((< rem (piece-length piece)) + (values piece rem)) + (else + (loop (piece-next piece) (- rem (piece-length piece))))))) + + + +;; API (define (piece-table-index piece-table pos) ;; TODO: Validate input - (let loop ((p (piece-table-piece piece-table)) - (start 0)) - (let* ((end (piece-length p))) - (if (<= start pos (+ start end -1)) - (string-ref (buffer->string (piece-buffer p)) (- pos start)) - (if (not (null? (piece-next p))) - (loop (piece-next p) (+ start end)) - (eof-object)))))) + (let-values (((piece idx) (piece-table-index->piece+index piece-table pos))) + (string-ref (buffer->string (piece-buffer piece)) + (+ (piece-start piece) idx)))) (define (piece-table-text-length piece-table) (let loop ((piece (piece-table-piece piece-table)) (acc 0)) - (if (null? (piece-next piece)) + (if (sentinel-piece? (piece-next piece)) (+ acc (piece-length piece)) (loop (piece-next piece) (+ (piece-length piece) acc))))) @@ -202,7 +243,7 @@ (piece (piece-table-piece piece-table))) (let* ((len (piece-length piece)) (end (+ start len)) - (more? (not (null? (piece-next piece))))) + (more? (not (sentinel-piece? (piece-next piece))))) (when (< idx to) ;; Skip tail (if (or (= idx end) (<= end from)) ;; Current piece doesn't contain the section we need or finished @@ -220,44 +261,12 @@ ;; There are chars to process in this piece (loop (+ idx 1) start piece))))))) -(define (piece-table-find-line-break piece-table idx) - (let loop ((idx 0) - (piece (piece-table-piece piece-table)) - (rem idx)) - (let* ((len (piece-length piece)) - (lines (piece-linebreaks piece)) - (lc (vector-length lines))) - (cond - ((< rem lc) - (+ idx (vector-ref lines rem))) - ;; TODO: No more pieces, return the end or eof? - ((null? (piece-next piece)) - (eof-object)) - (else - (loop (+ idx len) (piece-next piece) (- rem lc))))))) - -(define (piece-table-index->piece+index piece-table pos) - "Returns (values piece remainder) or eof-object" - (let loop ((piece (piece-table-piece piece-table)) - (rem pos)) - (let ((len (piece-length piece))) - (cond - ((<= rem len) - (values piece rem)) - ((null? (piece-next piece)) - ;; TODO: No more pieces, return the end or eof? - (error "Requested position out of piece-table")) - (else - (loop (piece-next piece) (- rem len))))))) +(define (piece-table-for-each-right piece-table f from to) + "-right version of piece-table-for-each, it finds the tail and goes + backwards" + ;; TODO: not implemented yet + ) -(define (piece-table-piece-index piece-table i) - (let ((piece-prev/next (if (< i 0) piece-prev piece-next)) - (inc/dec (if (< i 0) - +))) - (let loop ((piece (piece-table-piece piece-table)) - (idx 0)) - (if (= idx i) - piece - (loop (piece-prev/next piece) (inc/dec idx 1)))))) (define (piece-table-insert! piece-table pos str type) ;; TODO: validate input @@ -265,35 +274,72 @@ ;; there? Is this maximum evilness? => it's just a string-ref and it prevents ;; us from creating pieces! - ;; TODO Maybe remove this? - (define candidate ((add-buffer-append! - (piece-table-add-buffer piece-table) str) - type)) - - (unless (= 0 (string-length str)) - (let*-values (((piece idx) (piece-table-index->piece+index piece-table pos))) - (if (and (= idx (piece-length piece)) - (can-merge-pieces? piece candidate)) - (merge-pieces! piece candidate) - (let-values (((first second) (split-piece! piece idx))) - (connect-pieces! first candidate) - (connect-pieces! candidate second)))))) + (let* ((add-buffer (piece-table-add-buffer piece-table)) + (start (add-buffer-used add-buffer)) + (_ (add-buffer-append! add-buffer str)) + (candidate (make-piece add-buffer + start + (string-length str) + type + #f #f))) + (unless (= 0 (string-length str)) + (let*-values (((piece idx) + (piece-table-index->piece+index piece-table pos))) + (cond + ((= idx 0) + (connect-pieces! (piece-prev piece) candidate) + (connect-pieces! candidate piece) + (when (can-merge-pieces? (piece-prev piece) candidate) + (merge-pieces! (piece-prev piece) candidate))) + (else + (let-values (((first second) (split-piece! piece idx))) + (connect-pieces! first candidate) + (connect-pieces! candidate second) + (when (can-merge-pieces? first candidate) + (merge-pieces! first candidate))))))))) (define (piece-table-delete! piece-table from len) - ;; TODO: Validate input (unless (= 0 len) (let*-values (((start-piece idx) (piece-table-index->piece+index piece-table from)) ((first second) (split-piece! start-piece idx)) - ;; We can search from the `second` here, because it's going - ;; to be at least in second, and we only iterate once that - ;; way ((end-piece end-idx) (piece-table-index->piece+index piece-table (+ from len))) ((third fourth) (split-piece! end-piece end-idx))) (connect-pieces! first fourth)))) +;; Finding: +;; NOTE: Line breaks are optimized. + +(define (piece-table-find-line-break piece-table idx) + (let loop ((idx 0) + (piece (piece-table-piece piece-table)) + (rem idx)) + (let* ((len (piece-length piece)) + (lines (piece-linebreaks piece)) + (lc (vector-length lines))) + (cond + ((< rem lc) + (+ idx (vector-ref lines rem))) + ;; TODO: No more pieces, return the end or eof? + ((sentinel-piece? (piece-next piece)) + (eof-object)) + (else + (loop (+ idx len) (piece-next piece) (- rem lc))))))) + +(define (piece-table-find piece-table char from) + ;; TODO: generalize the from + (call/cc (lambda (cont) + (piece-table-for-each + piece-table + (lambda (c i p) + (when (char=? c char) + (cont i))) + from + (piece-table-text-length piece-table)) + (cont (eof-object))))) + ;; Serialization - Deserialization @@ -313,15 +359,16 @@ (let ((out-string (make-string (- to from)))) (let loop ((piece (piece-table-piece piece-table)) (acc 0)) - (if (or (null? piece) (>= acc to)) + (if (or (sentinel-piece? piece) (>= acc to)) out-string (begin - (string-copy! - out-string - (max (- acc from) 0) - (buffer->string (piece-buffer piece)) - (+ (piece-start piece) (max (- from acc) 0)) - (+ (piece-start piece) (min (- to acc) (piece-length piece)))) + (when (>= (+ (piece-length piece) acc) from) + (string-copy! + out-string + (max (- acc from) 0) + (buffer->string (piece-buffer piece)) + (+ (piece-start piece) (max (- from acc) 0)) + (+ (piece-start piece) (min (- to acc) (piece-length piece))))) (loop (piece-next piece) (+ acc (piece-length piece)))))))) (define (piece-table->string piece-table) diff --git a/par/piece-table.sld b/par/piece-table.sld index c197181..7209baf 100644 --- a/par/piece-table.sld +++ b/par/piece-table.sld @@ -3,6 +3,7 @@ (srfi 11)) (export make-piece-table piece-table-index + piece-table-text-length piece-table-insert! piece-table-delete! piece-table->string @@ -10,5 +11,6 @@ string->piece-table add-buffer-length piece-table-line - piece-table-for-each) + piece-table-for-each + piece-table-find) (include "piece-table.scm")) diff --git a/tests/piece-table.scm b/tests/piece-table.scm index 76176a9..62ff11d 100644 --- a/tests/piece-table.scm +++ b/tests/piece-table.scm @@ -7,9 +7,17 @@ (test-begin "index") (define table (make-piece-table "HOLA")) + (test-equal #\H (piece-table-index table 0)) + (test-equal #\O (piece-table-index table 1)) (test-equal #\L (piece-table-index table 2)) + (test-equal #\A (piece-table-index table 3)) (test-end "index") +(test-begin "length") + (define table (make-piece-table "HOLA")) + (test-equal 4 (piece-table-text-length table)) +(test-end "length") + (test-begin "insert") (define table (make-piece-table "HOLA")) (piece-table-insert! table 4 "9" 'normal) @@ -61,3 +69,8 @@ 0 10) (test-end "for-each") + +(test-begin "find") + (define table (make-piece-table "1234567890")) + (test-equal 8 (piece-table-find table #\9 0)) +(test-end "find") |