diff options
| -rw-r--r-- | par/piece-table.scm | 155 | ||||
| -rw-r--r-- | par/piece-table.sld | 3 | ||||
| -rw-r--r-- | tests/piece-table.scm | 3 |
3 files changed, 143 insertions, 18 deletions
diff --git a/par/piece-table.scm b/par/piece-table.scm index 6876541..7a1cae7 100644 --- a/par/piece-table.scm +++ b/par/piece-table.scm @@ -14,40 +14,152 @@ +;; INTERNAL BUFFERS: The indirection level of the buffer records is cool, so we +;; can resize the underlying strings and keep all the pieces untouched and +;; pointing to the correct thing. + +;; There's nothing preventing the programmer from writing in the ro-buffer... +;; but it will be hidden under the piece-table interface so nothing should +;; happen +(define-record-type <ro-buffer> + (make-ro-buffer string) + ro-buffer? + (string ro-buffer-string)) + +;; This is where things are added, it's able to grow to handle new additions +(define-record-type <add-buffer> + (%make-add-buffer string used) + add-buffer? + (string add-buffer-string set-add-buffer-string!) + (used add-buffer-used set-add-buffer-used!)) + +(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)))) + +(define %DEFAULT-ADD-BUFFER-LENGTH 64) + +(define (make-add-buffer) + (%make-add-buffer (make-string %DEFAULT-ADD-BUFFER-LENGTH) 0)) + +(define (enlarge-add-buffer! add-buffer at-least) + (let* ((str (add-buffer-string add-buffer)) + (len (string-length str)) + ; TODO: Better algo here? + (new (make-string (+ len at-least %DEFAULT-ADD-BUFFER-LENGTH)))) + (set-add-buffer-string! add-buffer new) + (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" + (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)) + + (lambda (type) + (make-piece add-buffer + buffer-used + (string-length str) + type)))) + + + ;; The piece table itself; -;; original and add are strings and pieces is a list of pieces +;; original is a ro-buffer, add is an add-buffer (a string designed to grow) +;; and pieces is a list of pieces (define-record-type <piece-table> - (%make-piece-table original add pieces) + (%make-piece-table original-buffer add-buffer pieces) piece-table? - (original piece-table-original set-piece-table-original!) - (add piece-table-add set-piece-table-add!) + (original-buffer piece-table-original-buffer set-piece-table-original-buffer!) + (add-buffer piece-table-add-buffer set-piece-table-add-buffer!) (pieces piece-table-pieces set-piece-table-pieces!)) -(define %DEFAULT-ADD-BUFFER-LENGTH 1024) (define (make-piece-table original) - (%make-piece-table - original - (make-string %DEFAULT-ADD-BUFFER-LENGTH) - (list (make-piece original 0 (string-length original) 'normal)))) + (let ((ro-buffer (make-ro-buffer original))) + (%make-piece-table + ro-buffer (make-add-buffer) + (list (make-piece ro-buffer 0 (string-length original) 'normal))))) (define (add-piece-table-piece! piece-table piece) - (append (piece-table-pieces piece-table) (list piece))) - + "Add a new piece to the piece table. Piece is added in the end. Order is + important." + (set-piece-table-pieces! piece-table + (append! (piece-table-pieces piece-table) (list piece)))) (define (piece-table-index piece-table pos) (let loop ((pieces (piece-table-pieces piece-table)) (start 0)) (let* ((piece (car pieces)) (end (piece-length piece))) - (if (<= start pos (- end 1)) - (string-ref (piece-buffer piece) (+ start pos)) + (if (<= start pos (+ start end -1)) + (string-ref (buffer->string (piece-buffer piece)) (- pos start)) (if (not (null? (cdr pieces))) (loop (cdr pieces) (+ start end)) (eof-object)))))) -(define (piece-table-insert! piece-table pos char) - #f) +(define (piece-table-text-length piece-table) + (reduce + 0 (map piece-length (piece-table-pieces piece-table)))) + +(define (piece-table-insert! piece-table pos str) + + (define (pos->piece-idx-pos ps pos) + (let loop ((idx 0) + (pieces ps) + (rem pos)) + (let* ((current (car pieces)) + (len (piece-length current))) + (if (<= rem len) + (values idx rem) + (loop (+ idx 1) (cdr pieces) (- rem len)))))) + + ;; Write to add-buffer first + (let ((piece-to-insert (add-buffer-append! (piece-table-add-buffer piece-table) str))) + + ;; Now assign a piece for what we wrote + ;; It's probably reasonable to combine both branches in just the one in the + ;; bottom + (if (= (piece-table-text-length piece-table) pos) + ;; last position + (let ((last-piece (last (piece-table-pieces piece-table)))) + (if (eq? (piece-table-add-buffer piece-table) + (piece-buffer last-piece)) + (set-piece-length! last-piece (+ (string-length str) + (piece-length last-piece))) + (add-piece-table-piece! piece-table + (piece-to-insert #f)))) + + ;; not last + (call-with-values + (lambda () (pos->piece-idx-pos (piece-table-pieces piece-table) pos)) + (lambda (idx rem) + (call-with-values + (lambda () + (split-at! (piece-table-pieces piece-table) idx)) + (lambda (beg end) + (let* ((altered (car end)) + (rest (cdr end)) + (buffer (piece-buffer altered)) + (start (piece-start altered)) + (length (piece-length altered)) + (add-buffer (piece-table-add-buffer piece-table))) + (set-piece-table-pieces! + piece-table + (append beg + (list (make-piece buffer start rem #f) + (piece-to-insert #f) + (make-piece buffer + (+ start rem) + (- length rem) + #f)) + rest)))))))))) (define (piece-table-delete! piece-table pos) #f) @@ -68,4 +180,15 @@ (define string->piece-table make-piece-table) (define (piece-table->string piece-table) - #f) + (let ((out-string (make-string (piece-table-text-length piece-table)))) + (let loop ((pieces (piece-table-pieces piece-table)) + (acc 0)) + (if (null? pieces) + out-string + (let ((piece (car pieces))) + (string-copy! out-string + acc + (buffer->string (piece-buffer piece)) + (piece-start piece) + (+ (piece-start piece) (piece-length piece))) + (loop (cdr pieces) (+ acc (piece-length piece)))))))) diff --git a/par/piece-table.sld b/par/piece-table.sld index 4f428b0..1c915d7 100644 --- a/par/piece-table.sld +++ b/par/piece-table.sld @@ -1,5 +1,6 @@ (define-library (par piece-table) - (import (scheme base)) + (import (scheme base) + (srfi 1)) (export make-piece-table piece-table-index piece-table-insert! diff --git a/tests/piece-table.scm b/tests/piece-table.scm index 8f3af80..d1fa32a 100644 --- a/tests/piece-table.scm +++ b/tests/piece-table.scm @@ -12,8 +12,9 @@ (test-begin "insert") (define table (make-piece-table "HOLA")) - (piece-table-insert! table 2 #\9) + (piece-table-insert! table 2 "90") (test-equal #\9 (piece-table-index table 2)) + (test-equal #\0 (piece-table-index table 3)) (test-end "insert") (test-begin "delete") |